diff --git a/.gitignore b/.gitignore
index 22dda8efb4..b52c593b49 100644
--- a/.gitignore
+++ b/.gitignore
@@ -25,3 +25,5 @@ build-support/wordsize
.#*
*.swo
checksums.txt
+*.so
+a.out
diff --git a/Makefile b/Makefile
old mode 100644
new mode 100755
index 5e63017218..18cb7d15c7
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,5 @@
CC = gcc
+CPP = g++
AR = ar
LD = ld
@@ -7,18 +8,18 @@ CONSOLE_EXECUTABLE = factor-console
TEST_LIBRARY = factor-ffi-test
VERSION = 0.92
-IMAGE = factor.image
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall
-FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG
- CFLAGS += -g
+ CFLAGS += -g -DFACTOR_DEBUG
else
- CFLAGS += -O3 $(SITE_CFLAGS)
+ CFLAGS += -O3
endif
+CFLAGS += $(SITE_CFLAGS)
+
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
ifdef CONFIG
@@ -27,25 +28,36 @@ endif
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \
+ vm/arrays.o \
vm/bignum.o \
+ vm/booleans.o \
+ vm/byte_arrays.o \
vm/callstack.o \
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 \
+ vm/dispatch.o \
vm/errors.o \
vm/factor.o \
vm/image.o \
+ vm/inline_cache.o \
vm/io.o \
+ vm/jit.o \
+ vm/local_roots.o \
vm/math.o \
vm/primitives.o \
vm/profiler.o \
vm/quotations.o \
vm/run.o \
- vm/types.o \
- vm/utilities.o
+ vm/strings.o \
+ vm/tuples.o \
+ vm/utilities.o \
+ vm/words.o \
+ vm/write_barrier.o
EXE_OBJS = $(PLAF_EXE_OBJS)
@@ -151,22 +163,28 @@ macosx.app: factor
@executable_path/../Frameworks/libfactor.dylib \
Factor.app/Contents/MacOS/factor
-factor: $(DLL_OBJS) $(EXE_OBJS)
+$(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)
-factor-console: $(DLL_OBJS) $(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)
-factor-ffi-test: vm/ffi_test.o
+$(TEST_LIBRARY): vm/ffi_test.o
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:
rm -f vm/*.o
- rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,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
@@ -177,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 $@ $<
-
-.PHONY: factor
+.mm.o:
+ $(CPP) -c $(CFLAGS) -o $@ $<
+
+.PHONY: factor tags clean
+
+.SUFFIXES: .mm
diff --git a/README.txt b/README.txt
index c5d53de842..addbe38f0d 100755
--- a/README.txt
+++ b/README.txt
@@ -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
@@ -59,10 +59,10 @@ On Unix, Factor can either run a graphical user interface using X11, or
a terminal listener.
For X11 support, you need recent development libraries for libc,
-Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
+Pango, X11, and OpenGL. On a Debian-derived Linux distribution
(like Ubuntu), you can use the following line to grab everything:
- sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
+ sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
If your DISPLAY environment variable is set, the UI will start
automatically:
@@ -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
diff --git a/basis/alarms/alarms-tests.factor b/basis/alarms/alarms-tests.factor
index d1161e4cee..7c64680a83 100644
--- a/basis/alarms/alarms-tests.factor
+++ b/basis/alarms/alarms-tests.factor
@@ -15,5 +15,3 @@ tools.test threads concurrency.count-downs ;
[ resume ] curry instant later drop
] "test" suspend drop
] unit-test
-
-\ alarm-thread-loop must-infer
diff --git a/basis/alarms/alarms.factor b/basis/alarms/alarms.factor
index 9cc05b4159..f9fdce806f 100644
--- a/basis/alarms/alarms.factor
+++ b/basis/alarms/alarms.factor
@@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
] when* ;
: init-alarms ( -- )
- alarms global [ cancel-alarms <min-heap> ] change-at
+ alarms [ cancel-alarms <min-heap> ] change-global
[ alarm-thread-loop t ] "Alarms" spawn-server
alarm-thread set-global ;
diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor
index 6a182f8dbf..15e67bf0fe 100755
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@@ -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
+
diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor
index 46afc05e2d..c9c1ecd0e5 100644
--- a/basis/alien/c-types/c-types-docs.factor
+++ b/basis/alien/c-types/c-types-docs.factor
@@ -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
diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor
index 988dc180e0..ea9e881fd4 100644
--- a/basis/alien/c-types/c-types-tests.factor
+++ b/basis/alien/c-types/c-types-tests.factor
@@ -2,8 +2,6 @@ IN: alien.c-types.tests
USING: alien alien.syntax alien.c-types kernel tools.test
sequences system libc alien.strings io.encodings.utf8 ;
-\ expand-constants must-infer
-
CONSTANT: xyz 123
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index dc35f8bbb0..9cd57f61ab 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -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 ;
diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor
index 71efa1aa24..b27c62b9a1 100644
--- a/basis/alien/fortran/fortran.factor
+++ b/basis/alien/fortran/fortran.factor
@@ -8,7 +8,7 @@ io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting strings system alien.libraries ;
IN: alien.fortran
-SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;
+SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
<<
: add-f2c-libraries ( -- )
@@ -42,30 +42,35 @@ library-fortran-abis [ H{ } clone ] initialize
HOOK: fortran-c-abi fortran-abi ( -- abi )
M: f2c-abi fortran-c-abi "cdecl" ;
+M: g95-abi fortran-c-abi "cdecl" ;
M: gfortran-abi fortran-c-abi "cdecl" ;
M: intel-unix-abi fortran-c-abi "cdecl" ;
M: intel-windows-abi fortran-c-abi "cdecl" ;
HOOK: real-functions-return-double? fortran-abi ( -- ? )
M: f2c-abi real-functions-return-double? t ;
+M: g95-abi real-functions-return-double? f ;
M: gfortran-abi real-functions-return-double? f ;
M: intel-unix-abi real-functions-return-double? f ;
M: intel-windows-abi real-functions-return-double? f ;
HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
M: f2c-abi complex-functions-return-by-value? f ;
+M: g95-abi complex-functions-return-by-value? f ;
M: gfortran-abi complex-functions-return-by-value? t ;
M: intel-unix-abi complex-functions-return-by-value? f ;
M: intel-windows-abi complex-functions-return-by-value? f ;
HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
M: f2c-abi character(1)-maps-to-char? f ;
+M: g95-abi character(1)-maps-to-char? f ;
M: gfortran-abi character(1)-maps-to-char? f ;
M: intel-unix-abi character(1)-maps-to-char? t ;
M: intel-windows-abi character(1)-maps-to-char? t ;
HOOK: mangle-name fortran-abi ( name -- name' )
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
+M: g95-abi mangle-name lowercase-name-with-extra-underscore ;
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
M: intel-windows-abi mangle-name >upper ;
diff --git a/basis/alien/libraries/libraries-docs.factor b/basis/alien/libraries/libraries-docs.factor
old mode 100644
new mode 100755
index 3b9c56c8fb..eac7655c38
--- a/basis/alien/libraries/libraries-docs.factor
+++ b/basis/alien/libraries/libraries-docs.factor
@@ -15,7 +15,7 @@ HELP: libraries
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
HELP: library
-{ $values { "name" "a string" } { "library" "a hashtable" } }
+{ $values { "name" "a string" } { "library" assoc } }
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }
@@ -58,3 +58,10 @@ $nl
"} cond >>"
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
+
+ARTICLE: "loading-libs" "Loading native libraries"
+"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
+{ $subsection add-library }
+"Once a library has been defined, you can try loading it to see if the path name is correct:"
+{ $subsection load-library }
+"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor
index 3fcc15974c..6c18065ab6 100644
--- a/basis/alien/libraries/libraries.factor
+++ b/basis/alien/libraries/libraries.factor
@@ -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 ;
\ No newline at end of file
diff --git a/basis/alien/parser/parser.factor b/basis/alien/parser/parser.factor
index 193893fabc..df1dd15bfb 100644
--- a/basis/alien/parser/parser.factor
+++ b/basis/alien/parser/parser.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals ;
+parser sequences splitting words fry locals lexer namespaces ;
IN: alien.parser
: parse-arglist ( parameters return -- types effect )
@@ -12,8 +12,15 @@ IN: alien.parser
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
-:: define-function ( return library function parameters -- )
+:: make-function ( return library function parameters -- word quot effect )
function create-in dup reset-generic
return library function
- parameters return parse-arglist [ function-quot ] dip
- define-declared ;
+ parameters return parse-arglist [ function-quot ] dip ;
+
+: (FUNCTION:) ( -- word quot effect )
+ scan "c-library" get scan ";" parse-tokens
+ [ "()" subseq? not ] filter
+ make-function ;
+
+: define-function ( return library function parameters -- )
+ make-function define-declared ;
diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor
index 4da06ec4c9..b72c79e478 100644
--- a/basis/alien/remote-control/remote-control.factor
+++ b/basis/alien/remote-control/remote-control.factor
@@ -15,7 +15,7 @@ IN: alien.remote-control
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
- dup optimized>> [ execute ] [ drop f ] if ; inline
+ dup optimized? [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv
diff --git a/basis/alien/strings/strings-docs.factor b/basis/alien/strings/strings-docs.factor
deleted file mode 100644
index 19c29e613e..0000000000
--- a/basis/alien/strings/strings-docs.factor
+++ /dev/null
@@ -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"
diff --git a/basis/alien/strings/strings.factor b/basis/alien/strings/strings.factor
deleted file mode 100644
index e9053cd5c1..0000000000
--- a/basis/alien/strings/strings.factor
+++ /dev/null
@@ -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
diff --git a/basis/alien/strings/unix/summary.txt b/basis/alien/strings/unix/summary.txt
deleted file mode 100644
index 27e7f4cfb1..0000000000
--- a/basis/alien/strings/unix/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Default string encoding on Unix
diff --git a/basis/alien/strings/unix/unix.factor b/basis/alien/strings/unix/unix.factor
deleted file mode 100644
index a7b1467344..0000000000
--- a/basis/alien/strings/unix/unix.factor
+++ /dev/null
@@ -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 ;
diff --git a/basis/alien/strings/windows/summary.txt b/basis/alien/strings/windows/summary.txt
deleted file mode 100644
index 42bffbb300..0000000000
--- a/basis/alien/strings/windows/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Default string encoding on Windows
diff --git a/basis/alien/strings/windows/windows.factor b/basis/alien/strings/windows/windows.factor
deleted file mode 100644
index 55c69246de..0000000000
--- a/basis/alien/strings/windows/windows.factor
+++ /dev/null
@@ -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
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
index 6a1bf7f635..0cc6d51446 100644
--- a/basis/alien/syntax/syntax.factor
+++ b/basis/alien/syntax/syntax.factor
@@ -16,9 +16,7 @@ SYNTAX: BAD-ALIEN <bad-alien> parsed ;
SYNTAX: LIBRARY: scan "c-library" set ;
SYNTAX: FUNCTION:
- scan "c-library" get scan ";" parse-tokens
- [ "()" subseq? not ] filter
- define-function ;
+ (FUNCTION:) define-declared ;
SYNTAX: TYPEDEF:
scan scan typedef ;
diff --git a/extra/advice/tags.txt b/basis/alien/syntax/tags.txt
similarity index 100%
rename from extra/advice/tags.txt
rename to basis/alien/syntax/tags.txt
diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor
index ddefff35bb..9094286575 100644
--- a/basis/base64/base64-tests.factor
+++ b/basis/base64/base64-tests.factor
@@ -23,5 +23,5 @@ IN: base64.tests
ascii encode >base64-lines >string
] unit-test
-\ >base64 must-infer
-\ base64> must-infer
+[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
+[ malformed-base64? ] must-fail-with
diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor
index c51d871bb5..47147fa306 100644
--- a/basis/base64/base64.factor
+++ b/basis/base64/base64.factor
@@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces
sequences strings io.crlf ;
IN: base64
+ERROR: malformed-base64 ;
+
<PRIVATE
: read1-ignoring ( ignoring -- ch )
@@ -25,7 +27,7 @@ IN: base64
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49 50 51
- } nth ; inline
+ } nth [ malformed-base64 ] unless* ; inline
SYMBOL: column
@@ -48,8 +50,6 @@ SYMBOL: column
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
-ERROR: malformed-base64 ;
-
: decode4 ( seq -- )
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
[ [ CHAR: = = ] count ] bi head-slice*
diff --git a/basis/binary-search/binary-search-docs.factor b/basis/binary-search/binary-search-docs.factor
index cf7915159a..20b33a0bcb 100644
--- a/basis/binary-search/binary-search-docs.factor
+++ b/basis/binary-search/binary-search-docs.factor
@@ -14,7 +14,7 @@ $nl
HELP: sorted-index
{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
-{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
+{ $description "Outputs the index of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
{ index index-from last-index last-index-from sorted-index } related-words
diff --git a/basis/binary-search/binary-search-tests.factor b/basis/binary-search/binary-search-tests.factor
index 77b1c16505..63d2697418 100644
--- a/basis/binary-search/binary-search-tests.factor
+++ b/basis/binary-search/binary-search-tests.factor
@@ -1,8 +1,6 @@
IN: binary-search.tests
USING: binary-search math.order vectors kernel tools.test ;
-\ sorted-member? must-infer
-
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index 617073bbc4..7940703140 100644
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -5,7 +5,7 @@ sequences namespaces parser kernel kernel.private classes
classes.private arrays hashtables vectors classes.tuple sbufs
hashtables.private sequences.private math classes.tuple.private
growable namespaces.private assocs words command-line vocabs io
-io.encodings.string libc splitting math.parser
+io.encodings.string libc splitting math.parser memory
compiler.units math.order compiler.tree.builder
compiler.tree.optimizer compiler.cfg.optimizer ;
IN: bootstrap.compiler
@@ -23,10 +23,13 @@ IN: bootstrap.compiler
"cpu." cpu name>> append require
-enable-compiler
+enable-optimizer
+
+! Push all tuple layouts to tenured space to improve method caching
+gc
: compile-unoptimized ( words -- )
- [ optimized>> not ] filter compile ;
+ [ optimized? not ] filter compile ;
nl
"Compiling..." write flush
@@ -108,7 +111,7 @@ nl
"." write flush
-{ (compile) } compile-unoptimized
+{ compile-word } compile-unoptimized
"." write flush
diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor
index 36f6291bc6..ab08aa87a9 100644
--- a/basis/bootstrap/finish-bootstrap.factor
+++ b/basis/bootstrap/finish-bootstrap.factor
@@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ;
(command-line) parse-command-line
load-vocab-roots
run-user-init
- "e" get [ eval ] when*
+ "e" get [ eval( -- ) ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
diff --git a/basis/bootstrap/image/image-tests.factor b/basis/bootstrap/image/image-tests.factor
index c432a47ea4..e7070d3cf2 100644
--- a/basis/bootstrap/image/image-tests.factor
+++ b/basis/bootstrap/image/image-tests.factor
@@ -2,9 +2,6 @@ IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
-\ ' must-infer
-\ write-image must-infer
-
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 504afae018..cad40b6384 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -3,14 +3,13 @@
USING: alien arrays byte-arrays generic assocs hashtables assocs
hashtables.private io io.binary io.files io.encodings.binary
io.pathnames kernel kernel.private math namespaces make parser
-prettyprint sequences sequences.private strings sbufs
-vectors words quotations assocs system layouts splitting
-grouping growable classes classes.builtin classes.tuple
-classes.tuple.private words.private vocabs
-vocabs.loader source-files definitions debugger
-quotations.private sequences.private combinators
-math.order math.private accessors
-slots.private compiler.units fry ;
+prettyprint sequences sequences.private strings sbufs vectors words
+quotations assocs system layouts splitting grouping growable classes
+classes.builtin classes.tuple classes.tuple.private vocabs
+vocabs.loader source-files definitions debugger quotations.private
+sequences.private combinators math.order math.private accessors
+slots.private generic.single.private compiler.units compiler.constants
+fry ;
IN: bootstrap.image
: arch ( os cpu -- arch )
@@ -94,13 +93,30 @@ CONSTANT: -1-offset 9
SYMBOL: sub-primitives
-: make-jit ( quot rc rt offset -- quad )
- [ [ call( -- ) ] { } make ] 3dip 4array ;
+SYMBOL: jit-define-rc
+SYMBOL: jit-define-rt
+SYMBOL: jit-define-offset
-: jit-define ( quot rc rt offset name -- )
+: compute-offset ( -- offset )
+ building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
+
+: jit-rel ( rc rt -- )
+ jit-define-rt set
+ jit-define-rc set
+ compute-offset jit-define-offset set ;
+
+: make-jit ( quot -- quad )
+ [
+ call( -- )
+ jit-define-rc get
+ jit-define-rt get
+ jit-define-offset get 3array
+ ] B{ } make prefix ;
+
+: jit-define ( quot name -- )
[ make-jit ] dip set ;
-: define-sub-primitive ( quot rc rt offset word -- )
+: define-sub-primitive ( quot word -- )
[ make-jit ] dip sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers
@@ -119,7 +135,6 @@ SYMBOL: bootstrap-global
SYMBOL: bootstrap-boot-quot
! JIT parameters
-SYMBOL: jit-code-format
SYMBOL: jit-prolog
SYMBOL: jit-primitive-word
SYMBOL: jit-primitive
@@ -129,20 +144,36 @@ SYMBOL: jit-push-immediate
SYMBOL: jit-if-word
SYMBOL: jit-if-1
SYMBOL: jit-if-2
-SYMBOL: jit-dispatch-word
-SYMBOL: jit-dispatch
SYMBOL: jit-dip-word
SYMBOL: jit-dip
SYMBOL: jit-2dip-word
SYMBOL: jit-2dip
SYMBOL: jit-3dip-word
SYMBOL: jit-3dip
+SYMBOL: jit-execute-word
+SYMBOL: jit-execute-jump
+SYMBOL: jit-execute-call
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
-SYMBOL: jit-declare-word
SYMBOL: jit-save-stack
+! PIC stubs
+SYMBOL: pic-load
+SYMBOL: pic-tag
+SYMBOL: pic-hi-tag
+SYMBOL: pic-tuple
+SYMBOL: pic-hi-tag-tuple
+SYMBOL: pic-check-tag
+SYMBOL: pic-check
+SYMBOL: pic-hit
+SYMBOL: pic-miss-word
+
+! Megamorphic dispatch
+SYMBOL: mega-lookup
+SYMBOL: mega-lookup-word
+SYMBOL: mega-miss-word
+
! Default definition for undefined words
SYMBOL: undefined-quot
@@ -150,7 +181,6 @@ SYMBOL: undefined-quot
H{
{ bootstrap-boot-quot 20 }
{ bootstrap-global 21 }
- { jit-code-format 22 }
{ jit-prolog 23 }
{ jit-primitive-word 24 }
{ jit-primitive 25 }
@@ -159,20 +189,32 @@ SYMBOL: undefined-quot
{ jit-if-word 28 }
{ jit-if-1 29 }
{ jit-if-2 30 }
- { jit-dispatch-word 31 }
- { jit-dispatch 32 }
{ jit-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
{ jit-push-immediate 36 }
- { jit-declare-word 42 }
- { jit-save-stack 43 }
- { jit-dip-word 44 }
- { jit-dip 45 }
- { jit-2dip-word 46 }
- { jit-2dip 47 }
- { jit-3dip-word 48 }
- { jit-3dip 49 }
+ { jit-save-stack 38 }
+ { jit-dip-word 39 }
+ { jit-dip 40 }
+ { jit-2dip-word 41 }
+ { jit-2dip 42 }
+ { jit-3dip-word 43 }
+ { jit-3dip 44 }
+ { jit-execute-word 45 }
+ { jit-execute-jump 46 }
+ { jit-execute-call 47 }
+ { pic-load 48 }
+ { pic-tag 49 }
+ { pic-hi-tag 50 }
+ { pic-tuple 51 }
+ { pic-hi-tag-tuple 52 }
+ { pic-check-tag 53 }
+ { pic-check 54 }
+ { pic-hit 55 }
+ { pic-miss-word 56 }
+ { mega-lookup 57 }
+ { mega-lookup-word 58 }
+ { mega-miss-word 59 }
{ undefined-quot 60 }
} ; inline
@@ -205,8 +247,8 @@ SYMBOL: undefined-quot
: emit-fixnum ( n -- ) tag-fixnum emit ;
-: emit-object ( header tag quot -- addr )
- swap here-as [ swap tag-fixnum emit call align-here ] dip ;
+: emit-object ( class quot -- addr )
+ over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
inline
! Write an object to the image.
@@ -251,7 +293,7 @@ GENERIC: ' ( obj -- ptr )
M: bignum '
[
- bignum tag-number dup [ emit-bignum ] emit-object
+ bignum [ emit-bignum ] emit-object
] cache-object ;
! Fixnums
@@ -274,7 +316,7 @@ M: fake-bignum ' n>> tag-fixnum ;
M: float '
[
- float tag-number dup [
+ float [
align-here double>bits emit-64
] emit-object
] cache-object ;
@@ -309,7 +351,7 @@ M: f '
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
- [ drop f , ]
+ [ direct-entry-def>> , ] ! direct-entry-def
[ drop 0 , ] ! count
[ word-sub-primitive , ]
[ drop 0 , ] ! xt
@@ -318,8 +360,7 @@ M: f '
} cleave
] { } make [ ' ] map
] bi
- \ word type-number object tag-number
- [ emit-seq ] emit-object
+ \ word [ emit-seq ] emit-object
] keep put-object ;
: word-error ( word msg -- * )
@@ -340,8 +381,7 @@ M: word ' ;
! Wrappers
M: wrapper '
- wrapped>> ' wrapper type-number object tag-number
- [ emit ] emit-object ;
+ wrapped>> ' wrapper [ emit ] emit-object ;
! Strings
: native> ( object -- object )
@@ -370,7 +410,7 @@ M: wrapper '
: emit-string ( string -- ptr )
[ length ] [ extended-part ' ] [ ] tri
- string type-number object tag-number [
+ string [
[ emit-fixnum ]
[ emit ]
[ f ' emit ascii-part pad-bytes emit-bytes ]
@@ -387,12 +427,11 @@ M: string '
: emit-dummy-array ( obj type -- ptr )
[ assert-empty ] [
- type-number object tag-number
[ 0 emit-fixnum ] emit-object
] bi* ;
M: byte-array '
- byte-array type-number object tag-number [
+ byte-array [
dup length emit-fixnum
pad-bytes emit-bytes
] emit-object ;
@@ -406,7 +445,7 @@ ERROR: tuple-removed class ;
: (emit-tuple) ( tuple -- pointer )
[ tuple-slots ]
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
- tuple type-number dup [ emit-seq ] emit-object ;
+ tuple [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer )
dup class name>> "tombstone" =
@@ -421,8 +460,7 @@ M: tombstone '
! Arrays
: emit-array ( array -- offset )
- [ ' ] map array type-number object tag-number
- [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
+ [ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
M: array ' emit-array ;
@@ -448,7 +486,7 @@ M: tuple-layout-array '
M: quotation '
[
array>> '
- quotation type-number object tag-number [
+ quotation [
emit ! array
f ' emit ! compiled
f ' emit ! cached-effect
@@ -480,15 +518,16 @@ M: quotation '
: emit-jit-data ( -- )
\ if jit-if-word set
- \ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set
- \ declare jit-declare-word set
\ dip jit-dip-word set
\ 2dip jit-2dip-word set
\ 3dip jit-3dip-word set
+ \ (execute) jit-execute-word set
+ \ inline-cache-miss \ pic-miss-word set
+ \ mega-cache-lookup \ mega-lookup-word set
+ \ mega-cache-miss \ mega-miss-word set
[ undefined ] undefined-quot set
{
- jit-code-format
jit-prolog
jit-primitive-word
jit-primitive
@@ -498,19 +537,31 @@ M: quotation '
jit-if-word
jit-if-1
jit-if-2
- jit-dispatch-word
- jit-dispatch
jit-dip-word
jit-dip
jit-2dip-word
jit-2dip
jit-3dip-word
jit-3dip
+ jit-execute-word
+ jit-execute-jump
+ jit-execute-call
jit-epilog
jit-return
jit-profiling
- jit-declare-word
jit-save-stack
+ pic-load
+ pic-tag
+ pic-hi-tag
+ pic-tuple
+ pic-hi-tag-tuple
+ pic-check-tag
+ pic-check
+ pic-hit
+ pic-miss-word
+ mega-lookup
+ mega-lookup-word
+ mega-miss-word
undefined-quot
} [ emit-userenv ] each ;
diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index 6c824b6155..9d19e4a231 100644
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -4,7 +4,7 @@ USING: accessors init namespaces words words.symbol io
kernel.private math memory continuations kernel io.files
io.pathnames io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings
-definitions assocs compiler.errors compiler.units math.parser
+definitions assocs compiler.units math.parser
generic sets command-line ;
IN: bootstrap.stage2
@@ -16,13 +16,6 @@ SYMBOL: bootstrap-time
vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
-: do-crossref ( -- )
- "Cross-referencing..." print flush
- H{ } clone crossref set-global
- xref-words
- xref-generics
- xref-sources ;
-
: load-components ( -- )
"include" "exclude"
[ get-global " " split harvest ] bi@
@@ -42,14 +35,17 @@ SYMBOL: bootstrap-time
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
- [ optimized>> ] count-words " compiled words" print
- [ symbol? ] count-words " symbol words" print
- [ ] count-words " words total" print
-
"Bootstrapping is complete." print
"Now, you can run Factor:" print
vm write " -i=" write "output-image" get print flush ;
+: save/restore-error ( quot -- )
+ error get-global
+ error-continuation get-global
+ [ call ] 2dip
+ error-continuation set-global
+ error set-global ; inline
+
[
! We time bootstrap
millis
@@ -61,8 +57,6 @@ SYMBOL: bootstrap-time
(command-line) parse-command-line
- do-crossref
-
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
@@ -70,18 +64,18 @@ SYMBOL: bootstrap-time
"staging" get "deploy-vocab" get or [
"stage2: deployment mode" print
] [
+ "debugger" require
+ "inspector" require
+ "tools.errors" require
"listener" require
"none" require
] if
- [
- load-components
+ load-components
- millis over - core-bootstrap-time set-global
+ millis over - core-bootstrap-time set-global
- run-bootstrap-init
- ] with-compiler-errors
- :errors
+ run-bootstrap-init
f error set-global
f error-continuation set-global
@@ -104,6 +98,7 @@ SYMBOL: bootstrap-time
drop
[
load-help? off
- "vocab:bootstrap/bootstrap-error.factor" run-file
+ [ "vocab:bootstrap/bootstrap-error.factor" parse-file ] save/restore-error
+ call
] with-scope
] recover
diff --git a/basis/bootstrap/tools/tools.factor b/basis/bootstrap/tools/tools.factor
index b0afe4a1d9..6017469925 100644
--- a/basis/bootstrap/tools/tools.factor
+++ b/basis/bootstrap/tools/tools.factor
@@ -6,6 +6,7 @@ IN: bootstrap.tools
"bootstrap.image"
"tools.annotations"
"tools.crossref"
+ "tools.errors"
"tools.deploy"
"tools.disassembler"
"tools.memory"
@@ -13,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
diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor
index b6d8e74072..8d1071122d 100644
--- a/basis/calendar/calendar-tests.factor
+++ b/basis/calendar/calendar-tests.factor
@@ -1,11 +1,7 @@
USING: arrays calendar kernel math sequences tools.test
-continuations system math.order threads ;
+continuations system math.order threads accessors ;
IN: calendar.tests
-\ time+ must-infer
-\ time* must-infer
-\ time- must-infer
-
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
@@ -167,3 +163,10 @@ IN: calendar.tests
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
+
+[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
+[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
+
+[ f ] [ now dup midnight eq? ] unit-test
+[ f ] [ now dup easter eq? ] unit-test
+[ f ] [ now dup beginning-of-year eq? ] unit-test
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 7a03fe4408..4b58b1b496 100644
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.tuple combinators combinators.short-circuit
- kernel locals math math.functions math.order namespaces sequences strings
- summary system threads vocabs.loader ;
+USING: accessors arrays classes.tuple combinators
+combinators.short-circuit kernel locals math math.functions
+math.order sequences summary system threads vocabs.loader ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
@@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
- [let* | a [ 14 month - 12 /i ]
- y [ year 4800 + a - ]
- m [ month 12 a * + 3 - ] |
- day 153 m * 2 + 5 /i + 365 y * +
- y 4 /i + y 100 /i - y 400 /i + 32045 -
- ] ;
+ 14 month - 12 /i :> a
+ year 4800 + a - :> y
+ month 12 a * + 3 - :> m
+
+ day 153 m * 2 + 5 /i + 365 y * +
+ y 4 /i + y 100 /i - y 400 /i + 32045 - ;
:: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number
- [let* | a [ n 32044 + ]
- b [ 4 a * 3 + 146097 /i ]
- c [ a 146097 b * 4 /i - ]
- d [ 4 c * 3 + 1461 /i ]
- e [ c 1461 d * 4 /i - ]
- m [ 5 e * 2 + 153 /i ] |
- 100 b * d + 4800 -
- m 10 /i + m 3 +
- 12 m 10 /i * -
- e 153 m * 2 + 5 /i - 1+
- ] ;
+ n 32044 + :> a
+ 4 a * 3 + 146097 /i :> b
+ a 146097 b * 4 /i - :> c
+ 4 c * 3 + 1461 /i :> d
+ c 1461 d * 4 /i - :> e
+ 5 e * 2 + 153 /i :> m
+
+ 100 b * d + 4800 -
+ m 10 /i + m 3 +
+ 12 m 10 /i * -
+ e 153 m * 2 + 5 /i - 1+ ;
+
+GENERIC: easter ( obj -- obj' )
+
+:: easter-month-day ( year -- month day )
+ year 19 mod :> a
+ year 100 /mod :> c :> b
+ b 4 /mod :> e :> d
+ b 8 + 25 /i :> f
+ b f - 1 + 3 /i :> g
+ 19 a * b + d - g - 15 + 30 mod :> h
+ c 4 /mod :> k :> i
+ 32 2 e * + 2 i * + h - k - 7 mod :> l
+ a 11 h * + 22 l * + 451 /i :> m
+
+ h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
+ month day ;
+
+M: integer easter ( year -- timestamp )
+ dup easter-month-day <date> ;
+
+M: timestamp easter ( timestamp -- timestamp )
+ clone
+ dup year>> easter-month-day
+ swapd >>day swap >>month ;
: >date< ( timestamp -- year month day )
[ year>> ] [ month>> ] [ day>> ] tri ;
diff --git a/basis/calendar/format/macros/macros-tests.factor b/basis/calendar/format/macros/macros-tests.factor
index 544332770f..4ba2872b43 100644
--- a/basis/calendar/format/macros/macros-tests.factor
+++ b/basis/calendar/format/macros/macros-tests.factor
@@ -1,4 +1,4 @@
-USING: tools.test kernel ;
+USING: tools.test kernel accessors ;
IN: calendar.format.macros
[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test
@@ -10,6 +10,6 @@ IN: calendar.format.macros
: compiled-test-1 ( -- n )
{ [ 1 throw ] [ 2 ] } attempt-all-quots ;
-\ compiled-test-1 must-infer
+\ compiled-test-1 def>> must-infer
[ 2 ] [ compiled-test-1 ] unit-test
diff --git a/basis/calendar/windows/windows.factor b/basis/calendar/windows/windows.factor
index 508cbb0a49..caab530a23 100644
--- a/basis/calendar/windows/windows.factor
+++ b/basis/calendar/windows/windows.factor
@@ -1,5 +1,5 @@
-USING: calendar namespaces alien.c-types system windows
-windows.kernel32 kernel math combinators ;
+USING: calendar namespaces alien.c-types system
+windows.kernel32 kernel math combinators windows.errors ;
IN: calendar.windows
M: windows gmt-offset ( -- hours minutes seconds )
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
index 04c6c2497e..29620b089d 100644
--- a/basis/checksums/md5/md5.factor
+++ b/basis/checksums/md5/md5.factor
@@ -14,7 +14,7 @@ IN: checksums.md5
SYMBOLS: a b c d old-a old-b old-c old-d ;
: T ( N -- Y )
- sin abs 4294967296 * >integer ; foldable
+ sin abs 32 2^ * >integer ; foldable
: initialize-md5 ( -- )
0 bytes-read set
diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor
index 69d698f9b1..3e933e6643 100644
--- a/basis/cocoa/cocoa.factor
+++ b/basis/cocoa/cocoa.factor
@@ -7,7 +7,7 @@ compiler.units lexer init ;
IN: cocoa
: (remember-send) ( selector variable -- )
- global [ dupd ?set-at ] change-at ;
+ [ dupd ?set-at ] change-global ;
SYMBOL: sent-messages
diff --git a/basis/cocoa/dialogs/dialogs.factor b/basis/cocoa/dialogs/dialogs.factor
index 84a1ad46a3..7761286127 100644
--- a/basis/cocoa/dialogs/dialogs.factor
+++ b/basis/cocoa/dialogs/dialogs.factor
@@ -12,6 +12,9 @@ IN: cocoa.dialogs
dup 1 -> setResolvesAliases:
dup 1 -> setAllowsMultipleSelection: ;
+: <NSDirPanel> ( -- panel ) <NSOpenPanel>
+ dup 1 -> setCanChooseDirectories: ;
+
: <NSSavePanel> ( -- panel )
NSSavePanel -> savePanel
dup 1 -> setCanChooseFiles:
@@ -21,10 +24,12 @@ IN: cocoa.dialogs
CONSTANT: NSOKButton 1
CONSTANT: NSCancelButton 0
-: open-panel ( -- paths )
- <NSOpenPanel>
+: (open-panel) ( panel -- paths )
dup -> runModal NSOKButton =
[ -> filenames CF>string-array ] [ drop f ] if ;
+
+: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
+: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
: split-path ( path -- dir file )
"/" split1-last [ <NSString> ] bi@ ;
diff --git a/basis/cocoa/views/views-docs.factor b/basis/cocoa/views/views-docs.factor
index 3b533f98c3..871326fcd4 100644
--- a/basis/cocoa/views/views-docs.factor
+++ b/basis/cocoa/views/views-docs.factor
@@ -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 } ;
diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor
index 3c60a6a7c1..f65fddac58 100644
--- a/basis/cocoa/views/views.factor
+++ b/basis/cocoa/views/views.factor
@@ -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: ;
diff --git a/basis/colors/colors-docs.factor b/basis/colors/colors-docs.factor
index 8881d89711..5e2b09380d 100644
--- a/basis/colors/colors-docs.factor
+++ b/basis/colors/colors-docs.factor
@@ -23,7 +23,7 @@ $nl
ARTICLE: "colors" "Colors"
"The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them."
$nl
-"RGBA colors:"
+"RGBA colors with floating point components in the range " { $snippet "[0,1]" } ":"
{ $subsection rgba }
{ $subsection <rgba> }
"Converting a color to RGBA:"
diff --git a/basis/combinators/short-circuit/smart/tags.txt b/basis/combinators/short-circuit/smart/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/basis/combinators/short-circuit/smart/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/basis/combinators/short-circuit/tags.txt b/basis/combinators/short-circuit/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/basis/combinators/short-circuit/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor
index 75f83c1a55..d8ee89ef2d 100644
--- a/basis/combinators/smart/smart-docs.factor
+++ b/basis/combinators/smart/smart-docs.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations math sequences
-multiline ;
+multiline stack-checker ;
IN: combinators.smart
HELP: input<sequence
@@ -108,18 +108,21 @@ HELP: append-outputs-as
ARTICLE: "combinators.smart" "Smart combinators"
-"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl
-"Smart inputs from a sequence:"
+"A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
+"Call a quotation and discard all output values:"
+{ $subsection drop-outputs }
+"Take all input values from a sequence:"
{ $subsection input<sequence }
-"Smart outputs to a sequence:"
+"Store all output values to a sequence:"
{ $subsection output>sequence }
{ $subsection output>array }
-"Reducing the output of a quotation:"
+"Reducing the set of output values:"
{ $subsection reduce-outputs }
-"Summing the output of a quotation:"
+"Summing output values:"
{ $subsection sum-outputs }
-"Appending the results of a quotation:"
+"Concatenating output values:"
{ $subsection append-outputs }
-{ $subsection append-outputs-as } ;
+{ $subsection append-outputs-as }
+"New smart combinators can be created by defining " { $link "macros" } " which call " { $link infer } "." ;
ABOUT: "combinators.smart"
diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor
index 1cca697dde..a18ef1f3b8 100644
--- a/basis/combinators/smart/smart-tests.factor
+++ b/basis/combinators/smart/smart-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test combinators.smart math kernel ;
+USING: tools.test combinators.smart math kernel accessors ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
@@ -42,7 +42,7 @@ IN: combinators.smart.tests
: nested-smart-combo-test ( -- array )
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
-\ nested-smart-combo-test must-infer
+\ nested-smart-combo-test def>> must-infer
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor
index aa7960539c..9519847810 100644
--- a/basis/combinators/smart/smart.factor
+++ b/basis/combinators/smart/smart.factor
@@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
'[ _ firstn @ ] ;
+MACRO: input<sequence-unsafe ( quot -- newquot )
+ [ infer in>> ] keep
+ '[ _ firstn-unsafe @ ] ;
+
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;
diff --git a/basis/combinators/smart/tags.txt b/basis/combinators/smart/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/basis/combinators/smart/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor
index 3d06bd97b7..5aeb49d6f2 100644
--- a/basis/command-line/command-line-docs.factor
+++ b/basis/command-line/command-line-docs.factor
@@ -1,5 +1,4 @@
-USING: help.markup help.syntax parser vocabs.loader strings
-command-line.private ;
+USING: help.markup help.syntax parser vocabs.loader strings ;
IN: command-line
HELP: run-bootstrap-init
@@ -53,6 +52,7 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
+ { { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
}
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor
index 73a01aa352..f2da4ebdf5 100644
--- a/basis/command-line/command-line.factor
+++ b/basis/command-line/command-line.factor
@@ -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
@@ -60,7 +60,6 @@ SYMBOL: main-vocab-hook
: default-cli-args ( -- )
global [
"quiet" off
- "script" off
"e" off
"user-init" on
embedded? "quiet" set
diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index 0b303a8a43..58eae8181b 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -5,8 +5,6 @@ math.private compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
kernel.private math ;
-\ build-cfg must-infer
-
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index 6d0a8f8c8e..6b0aba6813 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -16,7 +16,7 @@ M: callable test-cfg
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
- [ build-tree-from-word optimize-tree ] keep build-cfg ;
+ [ build-tree optimize-tree ] keep build-cfg ;
SYMBOL: allocate-registers?
diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor
index 3a4c702bc5..938dbbccbf 100644
--- a/basis/compiler/cfg/intrinsics/allot/allot.factor
+++ b/basis/compiler/cfg/intrinsics/allot/allot.factor
@@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot
[ tuple ##set-slots ] [ ds-push drop ] 2bi
] [ drop emit-primitive ] if ;
-: store-length ( len reg -- )
- [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
+: store-length ( len reg class -- )
+ [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
-: store-initial-element ( elt reg len -- )
- [ 2 + object tag-number ##set-slot-imm ] with with each ;
+:: store-initial-element ( len reg elt class -- )
+ len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
@@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot
[let | elt [ ds-pop ]
reg [ len ^^allot-array ] |
ds-drop
- len reg store-length
- elt reg len store-initial-element
+ len reg array store-length
+ len reg elt array store-initial-element
reg ds-push
]
] [ node emit-primitive ] if
@@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot
: emit-allot-byte-array ( len -- dst )
ds-drop
dup ^^allot-byte-array
- [ store-length ] [ ds-push ] [ ] tri ;
+ [ byte-array store-length ] [ ds-push ] [ ] tri ;
: emit-(byte-array) ( node -- )
dup node-input-infos first literal>> dup expand-<byte-array>?
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
-: emit-<byte-array> ( node -- )
- dup node-input-infos first literal>> dup expand-<byte-array>? [
- nip
- [ 0 ^^load-literal ] dip
- [ emit-allot-byte-array ] keep
- bytes>cells store-initial-element
- ] [ drop emit-primitive ] if ;
+:: emit-<byte-array> ( node -- )
+ node node-input-infos first literal>> dup expand-<byte-array>? [
+ :> len
+ 0 ^^load-literal :> elt
+ len emit-allot-byte-array :> reg
+ len reg elt byte-array store-initial-element
+ ] [ drop node emit-primitive ] if ;
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 3d0a7bec9c..ec819f9440 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics
arrays:<array>
byte-arrays:<byte-array>
byte-arrays:(byte-array)
- math.private:<complex>
- math.private:<ratio>
kernel:<wrapper>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
@@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics
{ \ arrays:<array> [ emit-<array> iterate-next ] }
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
- { \ math.private:<complex> [ emit-simple-allot iterate-next ] }
- { \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index 8d00a14ea2..908bf2475b 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -99,7 +99,7 @@ SYMBOL: spill-counts
: interval-to-spill ( active-intervals current -- live-interval )
#! We spill the interval with the most distant use location.
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
- unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
+ [ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
: assign-spill ( before after -- before after )
#! If it has been spilled already, reuse spill location.
diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
index 9efc23651b..13c1783711 100644
--- a/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
+++ b/basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
@@ -1,4 +1,4 @@
USING: compiler.cfg.linear-scan.assignment tools.test ;
IN: compiler.cfg.linear-scan.assignment.tests
-\ assign-registers must-infer
+
diff --git a/basis/compiler/cfg/linearization/linearization-tests.factor b/basis/compiler/cfg/linearization/linearization-tests.factor
index 5e866d15db..fe8b4fd0c0 100644
--- a/basis/compiler/cfg/linearization/linearization-tests.factor
+++ b/basis/compiler/cfg/linearization/linearization-tests.factor
@@ -1,4 +1,4 @@
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;
-\ build-mr must-infer
+
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index ac9603522e..abd2720817 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -92,7 +92,7 @@ sequences ;
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
- T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
+ T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps
] unit-test
@@ -110,7 +110,7 @@ sequences ;
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
- T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
+ T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
T{ ##replace f V int-regs 6 D 0 }
} value-numbering trim-temps
] unit-test
@@ -132,7 +132,7 @@ sequences ;
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
- T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
+ T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
T{ ##replace f V int-regs 14 D 0 }
} value-numbering trim-temps
] unit-test
@@ -149,6 +149,6 @@ sequences ;
T{ ##peek f V int-regs 29 D -1 }
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
- T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
+ T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
} value-numbering trim-temps
] unit-test
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 65e70bd042..826fa87b73 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -3,8 +3,9 @@
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
compiler.alien
compiler.cfg
@@ -43,7 +44,7 @@ SYMBOL: calls
SYMBOL: compiling-word
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
+: compiled-stack-traces? ( -- ? ) 67 getenv ;
! Mapping _label IDs to label instances
SYMBOL: labels
@@ -374,47 +375,21 @@ M: long-long-type flatten-value-type ( type -- types )
: box-return* ( node -- )
return>> [ ] [ box-return ] if-void ;
-TUPLE: no-such-library name ;
-
-M: no-such-library summary
- drop "Library not found" ;
-
-M: no-such-library compiler-error-type
- drop +linkage+ ;
-
-: no-such-library ( name -- )
- \ no-such-library boa
- compiling-word get compiler-error ;
-
-TUPLE: no-such-symbol name ;
-
-M: no-such-symbol summary
- drop "Symbol not found" ;
-
-M: no-such-symbol compiler-error-type
- drop +linkage+ ;
-
-: no-such-symbol ( name -- )
- \ no-such-symbol boa
- compiling-word get compiler-error ;
-
: check-dlsym ( symbols dll -- )
dup dll-valid? [
dupd '[ _ dlsym ] any?
- [ drop ] [ no-such-symbol ] if
+ [ drop ] [ compiling-word get no-such-symbol ] if
] [
- dll-path no-such-library drop
+ dll-path compiling-word get no-such-library drop
] if ;
-: stdcall-mangle ( symbol node -- symbol )
- "@"
- swap parameters>> parameter-sizes drop
- number>string 3append ;
+: stdcall-mangle ( symbol params -- symbol )
+ parameters>> parameter-sizes drop number>string "@" glue ;
: alien-invoke-dlsym ( params -- symbols dll )
- dup function>> dup pick stdcall-mangle 2array
- swap library>> library dup [ dll>> ] when
- 2dup check-dlsym ;
+ [ [ function>> dup ] keep stdcall-mangle 2array ]
+ [ library>> library dup [ dll>> ] when ]
+ bi 2dup check-dlsym ;
M: ##alien-invoke generate-insn
params>>
diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor
index 3a047a8d39..99f258d93c 100755
--- a/basis/compiler/codegen/fixup/fixup.factor
+++ b/basis/compiler/codegen/fixup/fixup.factor
@@ -3,15 +3,13 @@
USING: arrays byte-arrays byte-vectors generic assocs hashtables
io.binary kernel kernel.private math namespaces make sequences
words quotations strings alien.accessors alien.strings layouts
-system combinators math.bitwise words.private math.order
+system combinators math.bitwise math.order
accessors growable cpu.architecture compiler.constants ;
IN: compiler.codegen.fixup
GENERIC: fixup* ( obj -- )
-: code-format ( -- n ) 22 getenv ;
-
-: compiled-offset ( -- n ) building get length code-format * ;
+: compiled-offset ( -- n ) building get length ;
SYMBOL: relocation-table
SYMBOL: label-table
@@ -25,7 +23,7 @@ TUPLE: label-fixup label class ;
M: label-fixup fixup*
dup class>> rc-absolute?
[ "Absolute labels not supported" throw ] when
- [ label>> ] [ class>> ] bi compiled-offset 4 - rot
+ [ class>> ] [ label>> ] bi compiled-offset 4 - swap
3array label-table get push ;
TUPLE: rel-fixup class type ;
@@ -58,6 +56,9 @@ SYMBOL: literal-table
: rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ;
+: rel-word-direct ( word class -- )
+ [ add-literal ] dip rt-xt-direct rel-fixup ;
+
: rel-primitive ( word class -- )
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
@@ -88,4 +89,4 @@ SYMBOL: literal-table
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
- ] { } make 4array ;
+ ] B{ } make 4array ;
diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor
index f19225a45c..306ab515a8 100644
--- a/basis/compiler/compiler-docs.factor
+++ b/basis/compiler/compiler-docs.factor
@@ -1,23 +1,43 @@
-USING: help.markup help.syntax words io parser
-assocs words.private sequences compiler.units quotations ;
+USING: assocs compiler.cfg.builder compiler.cfg.optimizer
+compiler.errors compiler.tree.builder compiler.tree.optimizer
+compiler.units help.markup help.syntax io parser quotations
+sequences words ;
IN: compiler
-HELP: enable-compiler
+HELP: enable-optimizer
{ $description "Enables the optimizing compiler." } ;
-HELP: disable-compiler
+HELP: disable-optimizer
{ $description "Disable the optimizing compiler." } ;
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically. This can be changed:"
-{ $subsection disable-compiler }
-{ $subsection enable-compiler }
+{ $subsection disable-optimizer }
+{ $subsection enable-optimizer }
"Removing a word's optimized definition:"
{ $subsection decompile }
"Compiling a single quotation:"
{ $subsection compile-call }
"Higher-level words can be found in " { $link "compilation-units" } "." ;
+ARTICLE: "compiler-impl" "Compiler implementation"
+"The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop."
+$nl
+"Words are added to the " { $link compile-queue } " variable as needed and compiled."
+{ $subsection compile-queue }
+"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
+$nl
+"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
+{ $list
+ { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring certain compile errors generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
+ { "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
+ { "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
+ { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." }
+}
+"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
+$nl
+"Calling " { $link modify-code-heap } " is handled not by the " { $vocab-link "compiler" } " vocabulary, but rather " { $vocab-link "compiler.units" } ". The optimizing compiler merely provides an implementation of the " { $link recompile } " generic word." ;
+
ARTICLE: "compiler" "Optimizing compiler"
"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
$nl
@@ -26,12 +46,13 @@ $nl
{ "The " { $emphasis "non-optimizing quotation compiler" } " compiles quotations to naive machine code very quickly. The non-optimizing quotation compiler is part of the VM." }
{ "The " { $emphasis "optimizing word compiler" } " compiles whole words at a time while performing extensive data and control flow analysis. This provides greater performance for generated code, but incurs a much longer compile time. The optimizing compiler is written in Factor." }
}
-"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
-$nl
"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
+$nl
+"Most code you write will run with the optimizing compiler. Sometimes, the non-optimizing compiler is used, for example for listener interactions, or for running the quotation passed to " { $link POSTPONE: call( } "."
{ $subsection "compiler-errors" }
{ $subsection "hints" }
-{ $subsection "compiler-usage" } ;
+{ $subsection "compiler-usage" }
+{ $subsection "compiler-impl" } ;
ABOUT: "compiler"
@@ -39,7 +60,7 @@ HELP: decompile
{ $values { "word" word } }
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
-HELP: (compile)
+HELP: compile-word
{ $values { "word" word } }
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 04c1a9c55f..e418f0ef60 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
-combinators deques search-deques macros io stack-checker
-stack-checker.state stack-checker.inlining combinators.short-circuit
+generic.single combinators deques search-deques macros io
+source-files.errors stack-checker stack-checker.state
+stack-checker.inlining stack-checker.errors combinators.short-circuit
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
compiler.cfg.linearization compiler.cfg.two-operand
@@ -14,7 +15,8 @@ IN: compiler
SYMBOL: compile-queue
SYMBOL: compiled
-: queue-compile? ( word -- ? )
+: compile? ( word -- ? )
+ #! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
[ compiled get key? ]
@@ -23,61 +25,123 @@ SYMBOL: compiled
} 1|| not ;
: queue-compile ( word -- )
- dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
+ dup compile? [ compile-queue get push-front ] [ drop ] if ;
-: maybe-compile ( word -- )
- dup optimized>> [ drop ] [ queue-compile ] if ;
+: recompile-callers? ( word -- ? )
+ changed-effects get key? ;
-SYMBOLS: +optimized+ +unoptimized+ ;
-
-: ripple-up ( words -- )
- dup "compiled-status" word-prop +unoptimized+ eq?
- [ usage [ word? ] filter ] [ compiled-usage keys ] if
- [ queue-compile ] each ;
-
-: ripple-up? ( status word -- ? )
- [
- [ nip changed-effects get key? ]
- [ "compiled-status" word-prop eq? not ] 2bi or
- ] keep "compiled-status" word-prop and ;
-
-: save-compiled-status ( word status -- )
- [ over ripple-up? [ ripple-up ] [ drop ] if ]
- [ "compiled-status" set-word-prop ]
- 2bi ;
+: recompile-callers ( words -- )
+ #! If a word's stack effect changed, recompile all words that
+ #! have compiled calls to it.
+ dup recompile-callers?
+ [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
: start ( word -- )
"trace-compilation" get [ dup name>> print flush ] when
H{ } clone dependencies set
H{ } clone generic-dependencies set
- f swap compiler-error ;
+ clear-compiler-error ;
+
+GENERIC: no-compile? ( word -- ? )
+
+M: word no-compile? "no-compile" word-prop ;
+
+M: method-body no-compile? "method-generic" word-prop no-compile? ;
+
+M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
: ignore-error? ( word error -- ? )
- [ [ inline? ] [ macro? ] bi or ]
- [ compiler-error-type +warning+ eq? ] bi* and ;
-
-: fail ( word error -- * )
- [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
+ #! Ignore some errors on inline combinators, macros, and special
+ #! words such as 'call'.
[
- drop
- [ compiled-unxref ]
- [ f swap compiled get set-at ]
- [ +unoptimized+ save-compiled-status ]
- tri
- ] 2bi
- return ;
+ {
+ [ macro? ]
+ [ inline? ]
+ [ no-compile? ]
+ [ "special" word-prop ]
+ } 1||
+ ] [
+ {
+ [ do-not-compile? ]
+ [ literal-expected? ]
+ } 1||
+ ] bi* and ;
+
+: finish ( word -- )
+ #! Recompile callers if the word's stack effect changed, then
+ #! save the word's dependencies so that if they change, the
+ #! word can get recompiled too.
+ [ recompile-callers ]
+ [ compiled-unxref ]
+ [
+ dup crossref? [
+ dependencies get
+ generic-dependencies get
+ compiled-xref
+ ] [ drop ] if
+ ] tri ;
+
+: deoptimize-with ( word def -- * )
+ #! If the word failed to infer, compile it with the
+ #! non-optimizing compiler.
+ swap [ finish ] [ compiled get set-at ] bi return ;
+
+: not-compiled-def ( word error -- def )
+ '[ _ _ not-compiled ] [ ] like ;
+
+: ignore-error ( word error -- * )
+ drop
+ [ clear-compiler-error ]
+ [ dup def>> deoptimize-with ]
+ bi ;
+
+: remember-error ( word error -- * )
+ [ swap <compiler-error> compiler-error ]
+ [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
+ 2bi ;
+
+: deoptimize ( word error -- * )
+ #! If the error is ignorable, compile the word with the
+ #! non-optimizing compiler, using its definition. Otherwise,
+ #! if the compiler error is not ignorable, use a dummy
+ #! definition from 'not-compiled-def' which throws an error.
+ {
+ { [ dup inference-error? not ] [ rethrow ] }
+ { [ 2dup ignore-error? ] [ ignore-error ] }
+ [ remember-error ]
+ } cond ;
+
+: optimize? ( word -- ? )
+ {
+ [ predicate-engine-word? ]
+ [ contains-breakpoints? ]
+ [ single-generic? ]
+ } 1|| not ;
: frontend ( word -- nodes )
- [ build-tree-from-word ] [ fail ] recover optimize-tree ;
+ #! 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 ;
+
+: compile-dependency ( word -- )
+ #! If a word calls an unoptimized word, try to compile the callee.
+ dup optimized? [ drop ] [ queue-compile ] if ;
! Only switch this off for debugging.
SYMBOL: compile-dependencies?
t compile-dependencies? set-global
+: compile-dependencies ( asm -- )
+ compile-dependencies? get
+ [ calls>> [ compile-dependency ] each ] [ drop ] if ;
+
: save-asm ( asm -- )
[ [ code>> ] [ label>> ] bi compiled get set-at ]
- [ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
+ [ compile-dependencies ]
bi ;
: backend ( nodes word -- )
@@ -91,19 +155,9 @@ t compile-dependencies? set-global
save-asm
] each ;
-: finish ( word -- )
- [ +optimized+ save-compiled-status ]
- [ compiled-unxref ]
- [
- dup crossref?
- [
- dependencies get
- generic-dependencies get
- compiled-xref
- ] [ drop ] if
- ] tri ;
-
-: (compile) ( word -- )
+: compile-word ( word -- )
+ #! We return early if the word has breakpoints or if it
+ #! failed to infer.
'[
_ {
[ start ]
@@ -114,30 +168,38 @@ t compile-dependencies? set-global
] with-return ;
: compile-loop ( deque -- )
- [ (compile) yield-hook get call( -- ) ] slurp-deque ;
+ [ compile-word yield-hook get call( -- ) ] slurp-deque ;
: decompile ( word -- )
- f 2array 1array modify-code-heap ;
+ dup def>> 2array 1array modify-code-heap ;
: compile-call ( quot -- )
[ dup infer define-temp ] with-compilation-unit execute ;
+\ compile-call t "no-compile" set-word-prop
+
SINGLETON: optimizing-compiler
M: optimizing-compiler recompile ( words -- alist )
[
<hashed-dlist> compile-queue set
H{ } clone compiled set
- [ queue-compile ] each
+ [
+ [ queue-compile ]
+ [ subwords [ compile-dependency ] each ] bi
+ ] each
compile-queue get compile-loop
compiled get >alist
] with-scope ;
-: enable-compiler ( -- )
+: with-optimizer ( quot -- )
+ [ optimizing-compiler compiler-impl ] dip with-variable ; inline
+
+: enable-optimizer ( -- )
optimizing-compiler compiler-impl set-global ;
-: disable-compiler ( -- )
+: disable-optimizer ( -- )
f compiler-impl set-global ;
: recompile-all ( -- )
- forget-errors all-words compile ;
+ all-words compile ;
diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor
index b3757bf008..2f0494b58a 100644
--- a/basis/compiler/constants/constants.factor
+++ b/basis/compiler/constants/constants.factor
@@ -1,6 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel layouts system strings ;
+USING: math kernel layouts system strings words quotations byte-arrays
+alien arrays ;
IN: compiler.constants
! These constants must match vm/memory.h
@@ -11,18 +12,17 @@ CONSTANT: deck-bits 18
! These constants must match vm/layouts.h
: header-offset ( -- n ) object tag-number neg ; inline
: float-offset ( -- n ) 8 float tag-number - ; inline
-: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
+: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
-: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
-: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
-: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
-: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
+: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
+: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
+: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
+: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
-: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
-: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
-: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
-: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
-: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
+: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
+: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
+: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
+: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
! Relocation classes
@@ -41,10 +41,12 @@ CONSTANT: rt-primitive 0
CONSTANT: rt-dlsym 1
CONSTANT: rt-dispatch 2
CONSTANT: rt-xt 3
-CONSTANT: rt-here 4
-CONSTANT: rt-this 5
-CONSTANT: rt-immediate 6
-CONSTANT: rt-stack-chain 7
+CONSTANT: rt-xt-direct 4
+CONSTANT: rt-here 5
+CONSTANT: rt-this 6
+CONSTANT: rt-immediate 7
+CONSTANT: rt-stack-chain 8
+CONSTANT: rt-untagged 9
: rc-absolute? ( n -- ? )
[ rc-absolute-ppc-2/2 = ]
diff --git a/basis/opengl/glu/authors.txt b/basis/compiler/errors/authors.txt
old mode 100644
new mode 100755
similarity index 100%
rename from basis/opengl/glu/authors.txt
rename to basis/compiler/errors/authors.txt
diff --git a/basis/compiler/errors/errors-docs.factor b/basis/compiler/errors/errors-docs.factor
new file mode 100644
index 0000000000..6dbe5193aa
--- /dev/null
+++ b/basis/compiler/errors/errors-docs.factor
@@ -0,0 +1,5 @@
+IN: compiler.errors
+USING: help.markup help.syntax vocabs.loader words io
+quotations words.symbol ;
+
+ABOUT: "compiler-errors"
diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor
new file mode 100644
index 0000000000..3881439fc0
--- /dev/null
+++ b/basis/compiler/errors/errors.factor
@@ -0,0 +1,72 @@
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors source-files.errors kernel namespaces assocs fry
+summary ;
+IN: compiler.errors
+
+SYMBOL: +compiler-error+
+SYMBOL: compiler-errors
+
+compiler-errors [ H{ } clone ] initialize
+
+TUPLE: compiler-error < source-file-error ;
+
+M: compiler-error error-type drop +compiler-error+ ;
+
+SYMBOL: +linkage-error+
+SYMBOL: linkage-errors
+
+linkage-errors [ H{ } clone ] initialize
+
+TUPLE: linkage-error < source-file-error ;
+
+M: linkage-error error-type drop +linkage-error+ ;
+
+: clear-compiler-error ( word -- )
+ compiler-errors linkage-errors
+ [ get-global delete-at ] bi-curry@ bi ;
+
+: compiler-error ( error -- )
+ dup asset>> compiler-errors get-global set-at ;
+
+T{ error-type
+ { type +compiler-error+ }
+ { word ":errors" }
+ { plural "compiler errors" }
+ { icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" }
+ { quot [ compiler-errors get values ] }
+ { forget-quot [ compiler-errors get delete-at ] }
+} define-error-type
+
+: <compiler-error> ( error word -- compiler-error )
+ \ compiler-error <definition-error> ;
+
+: <linkage-error> ( error word -- linkage-error )
+ \ linkage-error <definition-error> ;
+
+: linkage-error ( error word class -- )
+ '[ _ boa ] dip <linkage-error> dup asset>> linkage-errors get set-at ; inline
+
+T{ error-type
+ { type +linkage-error+ }
+ { word ":linkage" }
+ { plural "linkage errors" }
+ { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
+ { quot [ linkage-errors get values ] }
+ { forget-quot [ linkage-errors get delete-at ] }
+ { fatal? f }
+} define-error-type
+
+TUPLE: no-such-library name ;
+
+M: no-such-library summary drop "Library not found" ;
+
+: no-such-library ( name word -- ) \ no-such-library linkage-error ;
+
+TUPLE: no-such-symbol name ;
+
+M: no-such-symbol summary drop "Symbol not found" ;
+
+: no-such-symbol ( name word -- ) \ no-such-symbol linkage-error ;
+
+ERROR: not-compiled word error ;
\ No newline at end of file
diff --git a/core/compiler/errors/summary.txt b/basis/compiler/errors/summary.txt
similarity index 100%
rename from core/compiler/errors/summary.txt
rename to basis/compiler/errors/summary.txt
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index 4d7882ad08..42ed90d64a 100755
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors combinators
specialized-arrays.float alien.libraries io.pathnames
io.backend ;
-IN: compiler.tests
+IN: compiler.tests.alien
<<
: libfactor-ffi-tests-path ( -- string )
diff --git a/basis/compiler/tests/call-effect.factor b/basis/compiler/tests/call-effect.factor
new file mode 100644
index 0000000000..a9fd313d64
--- /dev/null
+++ b/basis/compiler/tests/call-effect.factor
@@ -0,0 +1,14 @@
+IN: compiler.tests.call-effect
+USING: tools.test combinators generic.single sequences kernel ;
+
+: execute-ic-test ( a b -- c ) execute( a -- c ) ;
+
+! VM type check error
+[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
+
+: call-test ( q -- ) call( -- ) ;
+
+[ ] [ [ ] call-test ] unit-test
+[ ] [ f [ drop ] curry call-test ] unit-test
+[ ] [ [ ] [ ] compose call-test ] unit-test
+[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
\ No newline at end of file
diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index 2e02e5476c..8fbe13ce51 100644
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private
slots.private sequences.private byte-arrays alien
alien.accessors layouts words definitions compiler.units io
combinators vectors grouping make ;
-IN: compiler.tests
+IN: compiler.tests.codegen
! Originally, this file did black box testing of templating
! optimization. We now have a different codegen, but the tests
@@ -26,7 +26,7 @@ IN: compiler.tests
[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
-[ { 1 2 3 } { 1 4 3 } 3 3 ]
+[ { 1 2 3 } { 1 4 3 } 2 2 ]
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
unit-test
@@ -37,7 +37,7 @@ unit-test
: foo ( -- ) ;
-[ 5 5 ]
+[ 3 3 ]
[ 1.2 [ tag [ foo ] keep ] compile-call ]
unit-test
@@ -211,7 +211,7 @@ TUPLE: my-tuple ;
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
-[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
+[ t ] [ \ dispatch-alignment-regression optimized? ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test
@@ -281,4 +281,4 @@ TUPLE: cucumber ;
M: cucumber equal? "The cucumber has no equal" throw ;
-[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
\ No newline at end of file
+[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor
index 2d1f15b9a8..32611ba87a 100644
--- a/basis/compiler/tests/curry.factor
+++ b/basis/compiler/tests/curry.factor
@@ -1,6 +1,6 @@
USING: tools.test quotations math kernel sequences
assocs namespaces make compiler.units compiler ;
-IN: compiler.tests
+IN: compiler.tests.curry
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor
index b439b5f6a4..7074b73845 100644
--- a/basis/compiler/tests/float.factor
+++ b/basis/compiler/tests/float.factor
@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.float
USING: compiler.units compiler kernel kernel.private memory math
math.private tools.test math.floats.private ;
@@ -9,7 +9,7 @@ math.private tools.test math.floats.private ;
[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
-[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
+[ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test
diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor
index d6868fd034..5050ce1950 100644
--- a/basis/compiler/tests/folding.factor
+++ b/basis/compiler/tests/folding.factor
@@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
-IN: compiler.tests
+IN: compiler.tests.folding
! Calls to generic words were not folded away.
@@ -12,7 +12,7 @@ IN: compiler.tests
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
@@ -20,7 +20,7 @@ IN: compiler.tests
USING: math arrays ;
IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ t ] [
diff --git a/basis/compiler/tests/generic.factor b/basis/compiler/tests/generic.factor
new file mode 100644
index 0000000000..6b0ef2d439
--- /dev/null
+++ b/basis/compiler/tests/generic.factor
@@ -0,0 +1,11 @@
+IN: compiler.tests.generic
+USING: tools.test math kernel compiler.units definitions ;
+
+GENERIC: bad ( -- )
+M: integer bad ;
+M: object bad ;
+
+[ 0 bad ] must-fail
+[ "" bad ] must-fail
+
+[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tests/insane.factor b/basis/compiler/tests/insane.factor
deleted file mode 100644
index aa79067252..0000000000
--- a/basis/compiler/tests/insane.factor
+++ /dev/null
@@ -1,5 +0,0 @@
-IN: compiler.tests
-USING: words kernel stack-checker alien.strings tools.test
-compiler.units ;
-
-[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test
diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor
index 93860db924..5ca0f3f109 100644
--- a/basis/compiler/tests/intrinsics.factor
+++ b/basis/compiler/tests/intrinsics.factor
@@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order
alien.accessors alien.c-types alien.syntax alien.strings
namespaces libc sequences.private io.encodings.ascii
classes compiler ;
-IN: compiler.tests
+IN: compiler.tests.intrinsics
! Make sure that intrinsic ops compile to correct code.
[ ] [ 1 [ drop ] compile-call ] unit-test
@@ -342,12 +342,12 @@ cell 8 = [
] unit-test
[ 1 2 ] [
- 1 2 [ <complex> ] compile-call
+ 1 2 [ complex boa ] compile-call
dup real-part swap imaginary-part
] unit-test
[ 1 2 ] [
- 1 2 [ <ratio> ] compile-call dup numerator swap denominator
+ 1 2 [ ratio boa ] compile-call dup numerator swap denominator
] unit-test
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor
index 3aed47ae7e..f19a950711 100644
--- a/basis/compiler/tests/optimizer.factor
+++ b/basis/compiler/tests/optimizer.factor
@@ -4,13 +4,13 @@ sbufs strings tools.test vectors words sequences.private
quotations classes classes.algebra classes.tuple.private
continuations growable namespaces hints alien.accessors
compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler ;
-IN: optimizer.tests
+compiler definitions ;
+IN: compiler.tests.optimizer
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
-[ t ] [ \ xyz optimized>> ] unit-test
+[ t ] [ M\ array xyz optimized? ] unit-test
! Test predicate inlining
: pred-test-1 ( a -- b c )
@@ -95,7 +95,7 @@ TUPLE: pred-test ;
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage optimized>> ] unit-test
+[ t ] [ \ breakage optimized? ] unit-test
[ breakage ] must-fail
! regression
@@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * )
! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ;
-[ t ] [ \ <tuple>-regression optimized>> ] unit-test
+[ t ] [ \ <tuple>-regression optimized? ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
@@ -229,7 +229,7 @@ USE: binary-search.private
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
-[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
+[ t ] [ \ node-successor-f-bug optimized? ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
@@ -243,7 +243,7 @@ USE: binary-search.private
] if
] if ;
-[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
+[ t ] [ \ lift-throw-tail-regression optimized? ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
@@ -261,7 +261,7 @@ USE: binary-search.private
: lift-loop-tail-test-2 ( -- a b c )
10 [ ] lift-loop-tail-test-1 1 2 3 ;
-\ lift-loop-tail-test-2 must-infer
+\ lift-loop-tail-test-2 def>> must-infer
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
@@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
-[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
+[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
DEFER: recursive-inline-hang-3
@@ -302,8 +302,8 @@ HINTS: recursive-inline-hang-3 array ;
: member-test ( obj -- ? ) { + - * / /i } member? ;
-\ member-test must-infer
-[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test
+\ member-test def>> must-infer
+[ ] [ \ member-test build-tree optimize-tree drop ] unit-test
[ t ] [ \ + member-test ] unit-test
[ f ] [ \ append member-test ] unit-test
@@ -325,7 +325,7 @@ PREDICATE: list < improper-list
dup "a" get { array-capacity } declare >=
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
-\ interval-inference-bug must-infer
+[ t ] [ \ interval-inference-bug optimized? ] unit-test
[ ] [ 1 "a" set 2 "b" set ] unit-test
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
@@ -384,3 +384,9 @@ DEFER: loop-bbb
1 >bignum 2 >bignum
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call
] unit-test
+
+: broken-declaration ( -- ) \ + declare ;
+
+[ f ] [ \ broken-declaration optimized? ] unit-test
+
+[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tests/peg-regression-2.factor b/basis/compiler/tests/peg-regression-2.factor
index 1efadba3aa..7929d9e6f6 100644
--- a/basis/compiler/tests/peg-regression-2.factor
+++ b/basis/compiler/tests/peg-regression-2.factor
@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.peg-regression-2
USING: peg.ebnf strings tools.test ;
GENERIC: <times> ( times -- term' )
@@ -12,4 +12,4 @@ Regexp = Times:t => [[ t <times> ]]
;EBNF
-[ "foo" ] [ "a" parse-regexp ] unit-test
\ No newline at end of file
+[ "foo" ] [ "a" parse-regexp ] unit-test
diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor
index 56a4021eed..95d454fed1 100644
--- a/basis/compiler/tests/peg-regression.factor
+++ b/basis/compiler/tests/peg-regression.factor
@@ -4,8 +4,8 @@
! optimization, which would batch generic word updates at the
! end of a compilation unit.
-USING: kernel accessors peg.ebnf ;
-IN: compiler.tests
+USING: kernel accessors peg.ebnf words ;
+IN: compiler.tests.peg-regression
TUPLE: pipeline-expr background ;
@@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
USE: tools.test
-[ t ] [ \ expr optimized>> ] unit-test
-[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
+[ t ] [ \ expr optimized? ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized? ] unit-test
diff --git a/basis/compiler/tests/pic-problem-1.factor b/basis/compiler/tests/pic-problem-1.factor
new file mode 100644
index 0000000000..4adf0b36b9
--- /dev/null
+++ b/basis/compiler/tests/pic-problem-1.factor
@@ -0,0 +1,14 @@
+IN: compiler.tests.pic-problem-1
+USING: kernel sequences prettyprint memory tools.test ;
+
+TUPLE: x ;
+
+M: x length drop 0 ;
+
+INSTANCE: x sequence
+
+<< gc >>
+
+CONSTANT: blah T{ x }
+
+[ T{ x } ] [ blah ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor
new file mode 100644
index 0000000000..3d7a05a74b
--- /dev/null
+++ b/basis/compiler/tests/redefine0.factor
@@ -0,0 +1,107 @@
+IN: compiler.tests.redefine0
+USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
+namespaces macros assocs ;
+
+! Test ripple-up behavior
+: test-1 ( -- a ) 3 ;
+: test-2 ( -- ) test-1 ;
+
+[ test-2 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test
+
+{ 0 0 } [ test-1 ] must-infer-as
+
+[ ] [ test-2 ] unit-test
+
+[ ] [
+ [
+ \ test-1 forget
+ \ test-2 forget
+ ] with-compilation-unit
+] unit-test
+
+: test-3 ( a -- ) drop ;
+: test-4 ( -- ) [ 1 2 3 ] test-3 ;
+
+[ ] [ test-4 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test
+
+[ test-4 ] [ not-compiled? ] must-fail-with
+
+[ ] [
+ [
+ \ test-3 forget
+ \ test-4 forget
+ ] with-compilation-unit
+] unit-test
+
+: test-5 ( a -- quot ) ;
+: test-6 ( a -- b ) test-5 ;
+
+[ 31337 ] [ 31337 test-6 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test
+
+[ 31337 test-6 ] [ not-compiled? ] must-fail-with
+
+[ ] [
+ [
+ \ test-5 forget
+ \ test-6 forget
+ ] with-compilation-unit
+] unit-test
+
+GENERIC: test-7 ( a -- b )
+
+M: integer test-7 + ;
+
+: test-8 ( a -- b ) 255 bitand test-7 ;
+
+[ 1 test-7 ] [ not-compiled? ] must-fail-with
+[ 1 test-8 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 USING: macros math kernel ; GENERIC: test-7 ( x y -- z ) : test-8 ( a b -- c ) 255 bitand test-7 ;" eval( -- ) ] unit-test
+
+[ 4 ] [ 1 3 test-7 ] unit-test
+[ 4 ] [ 1 259 test-8 ] unit-test
+
+[ ] [
+ [
+ \ test-7 forget
+ \ test-8 forget
+ ] with-compilation-unit
+] unit-test
+
+! Indirect dependency on an unoptimized word
+: test-9 ( -- ) ;
+<< SYMBOL: quot
+[ test-9 ] quot set-global >>
+MACRO: test-10 ( -- quot ) quot get ;
+: test-11 ( -- ) test-10 ;
+
+[ ] [ test-11 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) 1 ;" eval( -- ) ] unit-test
+
+! test-11 should get recompiled now
+
+[ test-11 ] [ not-compiled? ] must-fail-with
+
+[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- a ) 1 ;" eval( -- ) ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) ;" eval( -- ) ] unit-test
+
+[ ] [ test-11 ] unit-test
+
+quot global delete-at
+
+[ ] [
+ [
+ \ test-9 forget
+ \ test-10 forget
+ \ test-11 forget
+ \ quot forget
+ ] with-compilation-unit
+] unit-test
diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor
index 0875967bd2..6bb623cac4 100644
--- a/basis/compiler/tests/redefine1.factor
+++ b/basis/compiler/tests/redefine1.factor
@@ -1,7 +1,7 @@
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval strings ;
-IN: compiler.tests
+IN: compiler.tests.redefine1
GENERIC: method-redefine-generic-1 ( a -- b )
@@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 6 ] [ method-redefine-test-1 ] unit-test
-[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
+[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
@@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
[ 6 ] [ method-redefine-test-2 ] unit-test
-[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
+[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test
@@ -36,41 +36,3 @@ M: integer method-redefine-generic-2 3 + ;
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
] with-compilation-unit
] unit-test
-
-! Test ripple-up behavior
-: hey ( -- ) ;
-: there ( -- ) hey ;
-
-[ t ] [ \ hey optimized>> ] unit-test
-[ t ] [ \ there optimized>> ] unit-test
-[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ hey optimized>> ] unit-test
-[ f ] [ \ there optimized>> ] unit-test
-[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
-[ t ] [ \ there optimized>> ] unit-test
-
-: good ( -- ) ;
-: bad ( -- ) good ;
-: ugly ( -- ) bad ;
-
-[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly optimized>> ] unit-test
-
-[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
-
-[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
-
-[ f ] [ \ good optimized>> ] unit-test
-[ f ] [ \ bad optimized>> ] unit-test
-[ f ] [ \ ugly optimized>> ] unit-test
-
-[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
-
-[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
-
-[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly optimized>> ] unit-test
-
-[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor
index 8a6fb8a313..66edd75097 100644
--- a/basis/compiler/tests/redefine10.factor
+++ b/basis/compiler/tests/redefine10.factor
@@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine10
! Mixin redefinition did not recompile all necessary words.
@@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
@@ -21,7 +21,7 @@ IN: compiler.tests
USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor
index 18b1a3a430..dbec57e3d5 100644
--- a/basis/compiler/tests/redefine11.factor
+++ b/basis/compiler/tests/redefine11.factor
@@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel classes.mixin arrays ;
-IN: compiler.tests
+IN: compiler.tests.redefine11
! Mixin redefinition did not recompile all necessary words.
@@ -17,7 +17,7 @@ IN: compiler.tests
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
diff --git a/basis/compiler/tests/redefine12.factor b/basis/compiler/tests/redefine12.factor
index 87dc4596e9..ccf6c88e70 100644
--- a/basis/compiler/tests/redefine12.factor
+++ b/basis/compiler/tests/redefine12.factor
@@ -15,6 +15,6 @@ M: object g drop t ;
TUPLE: jeah ;
-[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
+[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test
[ f ] [ T{ jeah } h ] unit-test
diff --git a/basis/compiler/tests/redefine14.factor b/basis/compiler/tests/redefine14.factor
index 807f3ed2c7..a72db4833c 100644
--- a/basis/compiler/tests/redefine14.factor
+++ b/basis/compiler/tests/redefine14.factor
@@ -1,8 +1,8 @@
USING: compiler.units definitions tools.test sequences ;
IN: compiler.tests.redefine14
-! TUPLE: bad ;
-!
-! M: bad length 1 2 3 ;
-!
-! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
+TUPLE: bad ;
+
+M: bad length 1 2 3 ;
+
+[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test
diff --git a/basis/compiler/tests/redefine15.factor b/basis/compiler/tests/redefine15.factor
index 797460a411..33aa080bac 100644
--- a/basis/compiler/tests/redefine15.factor
+++ b/basis/compiler/tests/redefine15.factor
@@ -17,4 +17,4 @@ DEFER: word-1
[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
-[ 2 3 ] [ 0 word-4 ] unit-test
\ No newline at end of file
+[ 2 3 ] [ 0 word-4 ] unit-test
diff --git a/basis/compiler/tests/redefine16.factor b/basis/compiler/tests/redefine16.factor
new file mode 100644
index 0000000000..3bef30f9f1
--- /dev/null
+++ b/basis/compiler/tests/redefine16.factor
@@ -0,0 +1,11 @@
+IN: compiler.tests.redefine16
+USING: eval tools.test definitions words compiler.units
+quotations stack-checker ;
+
+[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
+[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
+
+[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
diff --git a/basis/compiler/tests/redefine17.factor b/basis/compiler/tests/redefine17.factor
new file mode 100644
index 0000000000..4ed3e36f4d
--- /dev/null
+++ b/basis/compiler/tests/redefine17.factor
@@ -0,0 +1,49 @@
+IN: compiler.tests.redefine17
+USING: tools.test classes.mixin compiler.units arrays kernel.private
+strings sequences vocabs definitions kernel ;
+
+<< "compiler.tests.redefine17" words forget-all >>
+
+GENERIC: bong ( a -- b )
+
+M: array bong ;
+
+M: string bong length ;
+
+MIXIN: mixin
+
+INSTANCE: array mixin
+
+: blah ( a -- b ) { mixin } declare bong ;
+
+[ { } ] [ { } blah ] unit-test
+
+[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 0 ] [ "" blah ] unit-test
+
+MIXIN: mixin1
+
+INSTANCE: string mixin1
+
+MIXIN: mixin2
+
+GENERIC: billy ( a -- b )
+
+M: mixin2 billy ;
+
+M: array billy drop "BILLY" ;
+
+INSTANCE: string mixin2
+
+: bully ( a -- b ) { mixin1 } declare billy ;
+
+[ "" ] [ "" bully ] unit-test
+
+[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ "BILLY" ] [ { } bully ] unit-test
diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor
index 5a28b28261..9112a1e1af 100644
--- a/basis/compiler/tests/redefine2.factor
+++ b/basis/compiler/tests/redefine2.factor
@@ -1,11 +1,11 @@
-IN: compiler.tests
+IN: compiler.tests.redefine2
USING: compiler compiler.units tools.test math parser kernel
sequences sequences.private classes.mixin generic definitions
arrays words assocs eval words.symbol ;
DEFER: redefine2-test
-[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
+[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test
diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor
index b25b5a1a5e..0a5eb84579 100644
--- a/basis/compiler/tests/redefine3.factor
+++ b/basis/compiler/tests/redefine3.factor
@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.redefine3
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
@@ -14,11 +14,11 @@ M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test optimized>> ] unit-test
+[ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
-[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test
+[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
@@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test optimized>> ] unit-test
+[ t ] [ \ sheeple-test optimized? ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor
index 2f21777801..2320f64af6 100644
--- a/basis/compiler/tests/redefine4.factor
+++ b/basis/compiler/tests/redefine4.factor
@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ;
: declaration-test-1 ( -- a ) 3 ; flushable
@@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
-[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
+[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor
index ac1619b857..7613987852 100644
--- a/basis/compiler/tests/redefine5.factor
+++ b/basis/compiler/tests/redefine5.factor
@@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine5
! Regression: if dispatch was eliminated but method was not inlined,
! compiled usage information was not recorded.
@@ -14,7 +14,7 @@ IN: compiler.tests
GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ;
: my-inline ( a -- b ) my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
@@ -23,7 +23,7 @@ IN: compiler.tests
IN: compiler.tests.redefine5
TUPLE: my-tuple ;
M: my-tuple my-generic drop 0 ;
- "> eval
+ "> eval( -- )
] unit-test
[ 0 ] [
diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor
index 73225c55b8..fdf3e7edbb 100644
--- a/basis/compiler/tests/redefine6.factor
+++ b/basis/compiler/tests/redefine6.factor
@@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine6
! Mixin redefinition did not recompile all necessary words.
@@ -14,7 +14,7 @@ IN: compiler.tests
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
@@ -24,7 +24,7 @@ IN: compiler.tests
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 1 ] [
diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor
index 164a2e3831..cfe29603f9 100644
--- a/basis/compiler/tests/redefine7.factor
+++ b/basis/compiler/tests/redefine7.factor
@@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine7
! Mixin redefinition did not recompile all necessary words.
@@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
@@ -21,7 +21,7 @@ IN: compiler.tests
USE: math
IN: compiler.tests.redefine7
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor
index c8b3377632..a79bfb5af5 100644
--- a/basis/compiler/tests/redefine8.factor
+++ b/basis/compiler/tests/redefine8.factor
@@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel ;
-IN: compiler.tests
+IN: compiler.tests.redefine8
! Mixin redefinition did not recompile all necessary words.
@@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
@@ -24,7 +24,7 @@ IN: compiler.tests
USE: math
IN: compiler.tests.redefine8
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor
index 7b0f8a2e9c..2598246472 100644
--- a/basis/compiler/tests/redefine9.factor
+++ b/basis/compiler/tests/redefine9.factor
@@ -1,6 +1,6 @@
USING: eval tools.test compiler.units vocabs multiline words
kernel generic.math ;
-IN: compiler.tests
+IN: compiler.tests.redefine9
! Mixin redefinition did not recompile all necessary words.
@@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
@@ -25,7 +25,7 @@ IN: compiler.tests
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[
diff --git a/basis/compiler/tests/reload.factor b/basis/compiler/tests/reload.factor
index b2b65b5868..62c7c31bc2 100644
--- a/basis/compiler/tests/reload.factor
+++ b/basis/compiler/tests/reload.factor
@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.reload
USE: vocabs.loader
! "parser" reload
diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor
index d53b864b06..da021412fe 100644
--- a/basis/compiler/tests/simple.factor
+++ b/basis/compiler/tests/simple.factor
@@ -1,9 +1,7 @@
USING: compiler compiler.units tools.test kernel kernel.private
sequences.private math.private math combinators strings alien
arrays memory vocabs parser eval ;
-IN: compiler.tests
-
-\ (compile) must-infer
+IN: compiler.tests.simple
! Test empty word
[ ] [ [ ] compile-call ] unit-test
@@ -62,8 +60,8 @@ IN: compiler.tests
! 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
@@ -237,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
- "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
+ "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
] unit-test
] times
diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor
index 4092352fd5..e518ff8df2 100644
--- a/basis/compiler/tests/spilling.factor
+++ b/basis/compiler/tests/spilling.factor
@@ -1,6 +1,6 @@
USING: math.private kernel combinators accessors arrays
-generalizations tools.test ;
-IN: compiler.tests
+generalizations tools.test words ;
+IN: compiler.tests.spilling
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
{
@@ -47,7 +47,7 @@ IN: compiler.tests
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
-[ t ] [ \ float-spill-bug optimized>> ] unit-test
+[ t ] [ \ float-spill-bug optimized? ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
@@ -132,7 +132,7 @@ IN: compiler.tests
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
-[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
+[ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@@ -159,7 +159,7 @@ IN: compiler.tests
16 narray
] if ;
-[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
+[ t ] [ \ resolve-spill-bug optimized? ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor
index b317ed3eb5..1cb11571ef 100755
--- a/basis/compiler/tests/stack-trace.factor
+++ b/basis/compiler/tests/stack-trace.factor
@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.stack-trace
USING: compiler tools.test namespaces sequences
kernel.private kernel math continuations continuations.private
words splitting grouping sorting accessors ;
diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor
index caa214b70c..fc249d99db 100644
--- a/basis/compiler/tests/tuples.factor
+++ b/basis/compiler/tests/tuples.factor
@@ -1,4 +1,4 @@
-IN: compiler.tests
+IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ;
TUPLE: color red green blue ;
diff --git a/basis/compiler/tree/builder/builder-docs.factor b/basis/compiler/tree/builder/builder-docs.factor
index 8cf3796f0a..b7ee51834b 100644
--- a/basis/compiler/tree/builder/builder-docs.factor
+++ b/basis/compiler/tree/builder/builder-docs.factor
@@ -3,12 +3,11 @@ compiler.tree stack-checker.errors ;
IN: compiler.tree.builder
HELP: build-tree
-{ $values { "quot" quotation } { "nodes" "a sequence of nodes" } }
+{ $values { "word/quot" { $or word quotation } } { "nodes" "a sequence of nodes" } }
{ $description "Attempts to construct tree SSA IR from a quotation." }
{ $notes "This is the first stage of the compiler." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
-HELP: build-tree-with
-{ $values { "in-stack" "a sequence of values" } { "quot" quotation } { "nodes" "a sequence of nodes" } { "out-stack" "a sequence of values" } }
-{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values, and outputting stack resulting at the end." }
-{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
+HELP: build-sub-tree
+{ $values { "#call" #call } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } }
+{ $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ;
diff --git a/basis/compiler/tree/builder/builder-tests.factor b/basis/compiler/tree/builder/builder-tests.factor
index 4982a3986c..f3a2b99db6 100755
--- a/basis/compiler/tree/builder/builder-tests.factor
+++ b/basis/compiler/tree/builder/builder-tests.factor
@@ -1,11 +1,27 @@
IN: compiler.tree.builder.tests
USING: compiler.tree.builder tools.test sequences kernel
-compiler.tree ;
-
-\ build-tree must-infer
-\ build-tree-with must-infer
-\ build-tree-from-word must-infer
+compiler.tree stack-checker stack-checker.errors ;
: inline-recursive ( -- ) inline-recursive ; inline recursive
-[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? ] unit-test
+[ t ] [ \ inline-recursive build-tree [ #recursive? ] any? ] unit-test
+
+: bad-recursion-1 ( a -- b )
+ dup [ drop bad-recursion-1 5 ] [ ] if ;
+
+[ \ bad-recursion-1 build-tree ] [ inference-error? ] must-fail-with
+
+FORGET: bad-recursion-1
+
+: bad-recursion-2 ( obj -- obj )
+ dup [ dup first swap second bad-recursion-2 ] [ ] if ;
+
+[ \ bad-recursion-2 build-tree ] [ inference-error? ] must-fail-with
+
+FORGET: bad-recursion-2
+
+: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
+
+[ \ bad-bin build-tree ] [ inference-error? ] must-fail-with
+
+FORGET: bad-bin
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 4cb7650b1d..37cc1f05da 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -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: fry accessors quotations kernel sequences namespaces
-assocs words arrays vectors hints combinators compiler.tree
+USING: fry locals accessors quotations kernel sequences namespaces
+assocs words arrays vectors hints combinators continuations
+effects compiler.tree
stack-checker
stack-checker.state
stack-checker.errors
@@ -10,49 +11,59 @@ stack-checker.backend
stack-checker.recursive-state ;
IN: compiler.tree.builder
-: with-tree-builder ( quot -- nodes )
- '[ V{ } clone stack-visitor set @ ]
- with-infer nip ; inline
+<PRIVATE
-: build-tree ( quot -- nodes )
- #! Not safe to call from inference transforms.
- [ f initial-recursive-state infer-quot ] with-tree-builder ;
+GENERIC: (build-tree) ( quot -- )
-: build-tree-with ( in-stack quot -- nodes out-stack )
- #! Not safe to call from inference transforms.
- [
- [ >vector \ meta-d set ]
- [ f initial-recursive-state infer-quot ] bi*
- ] with-tree-builder
- unclip-last in-d>> ;
-
-: build-sub-tree ( #call quot -- nodes )
- [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
- over ends-with-terminate?
- [ drop swap [ f swap #push ] map append ]
- [ rot #copy suffix ]
- if ;
-
-: (build-tree-from-word) ( word -- )
- dup initial-recursive-state recursive-state set
- dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
- [ 1quotation ] [ specialized-def ] if
- infer-quot-here ;
-
-: check-cannot-infer ( word -- )
- dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;
+M: callable (build-tree) infer-quot-here ;
: check-no-compile ( word -- )
- dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
+ dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
-: build-tree-from-word ( word -- nodes )
+: check-effect ( word effect -- )
+ swap required-stack-effect 2dup effect<=
+ [ 2drop ] [ effect-error ] if ;
+
+: inline-recursive? ( word -- ? )
+ [ "inline" word-prop ] [ "recursive" word-prop ] bi and ;
+
+: word-body ( word -- quot )
+ dup inline-recursive? [ 1quotation ] [ specialized-def ] if ;
+
+M: word (build-tree)
+ [ check-no-compile ]
+ [ word-body infer-quot-here ]
+ [ current-effect check-effect ] tri ;
+
+: build-tree-with ( in-stack word/quot -- nodes )
[
+ <recursive-state> recursive-state set
+ V{ } clone stack-visitor set
+ [ [ >vector \ meta-d set ] [ length d-in set ] bi ]
+ [ (build-tree) ]
+ bi*
+ ] with-infer nip ;
+
+PRIVATE>
+
+: build-tree ( word/quot -- nodes )
+ [ f ] dip build-tree-with ;
+
+:: build-sub-tree ( #call word/quot -- nodes/f )
+ #! We don't want methods on mixins to have a declaration for that mixin.
+ #! This slows down compiler.tree.propagation.inlining since then every
+ #! inlined usage of a method has an inline-dependency on the mixin, and
+ #! not the more specific type at the call site.
+ f specialize-method? [
[
+ #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
{
- [ check-cannot-infer ]
- [ check-no-compile ]
- [ (build-tree-from-word) ]
- [ finish-word ]
- } cleave
- ] maybe-cannot-infer
- ] with-tree-builder ;
+ { [ dup not ] [ ] }
+ { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] }
+ [ in-d #call out-d>> #copy suffix ]
+ } cond
+ ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
+ ] with-variable ;
+
+: contains-breakpoints? ( word -- ? )
+ def>> [ word? ] filter [ "break?" word-prop ] any? ;
diff --git a/basis/compiler/tree/checker/checker-tests.factor b/basis/compiler/tree/checker/checker-tests.factor
index 5a8706b900..d9591e7be2 100644
--- a/basis/compiler/tree/checker/checker-tests.factor
+++ b/basis/compiler/tree/checker/checker-tests.factor
@@ -1,4 +1,4 @@
IN: compiler.tree.checker.tests
USING: compiler.tree.checker tools.test ;
-\ check-nodes must-infer
+
diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor
index 7de092d84a..c596be263a 100755
--- a/basis/compiler/tree/cleanup/cleanup-tests.factor
+++ b/basis/compiler/tree/cleanup/cleanup-tests.factor
@@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ;
[ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2)
] if ; inline recursive
-: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline
+: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline
[ f ] [
[ { bignum } declare annotate-entry-test-2 ]
@@ -302,7 +302,7 @@ cell-bits 32 = [
] unit-test
[ t ] [
- [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+ [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )
@@ -519,4 +519,4 @@ cell-bits 32 = [
[ t ] [
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
-] unit-test
\ No newline at end of file
+] unit-test
diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor
index 7c28866e94..ed4df91eec 100644
--- a/basis/compiler/tree/dead-code/dead-code-tests.factor
+++ b/basis/compiler/tree/dead-code/dead-code-tests.factor
@@ -9,8 +9,6 @@ accessors combinators io prettyprint words sequences.deep
sequences.private arrays classes kernel.private ;
IN: compiler.tree.dead-code.tests
-\ remove-dead-code must-infer
-
: count-live-values ( quot -- n )
build-tree
analyze-recursive
diff --git a/basis/compiler/tree/debugger/debugger-tests.factor b/basis/compiler/tree/debugger/debugger-tests.factor
index 9b4a6da12a..9bacd51be1 100644
--- a/basis/compiler/tree/debugger/debugger-tests.factor
+++ b/basis/compiler/tree/debugger/debugger-tests.factor
@@ -1,8 +1,5 @@
IN: compiler.tree.debugger.tests
USING: compiler.tree.debugger tools.test sorting sequences io math.order ;
-\ optimized. must-infer
-\ optimizer-report. must-infer
-
[ [ <=> ] sort ] optimized.
[ <reversed> [ print ] each ] optimizer-report.
\ No newline at end of file
diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor
index 430424291e..60cab92843 100644
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@@ -130,8 +130,6 @@ M: node node>quot drop ;
GENERIC: optimized. ( quot/word -- )
-M: method-spec optimized. first2 method optimized. ;
-
M: word optimized. specialized-def optimized. ;
M: callable optimized. build-tree optimize-tree nodes>quot . ;
@@ -144,8 +142,7 @@ SYMBOL: node-count
: make-report ( word/quot -- assoc )
[
- dup word? [ build-tree-from-word ] [ build-tree ] if
- optimize-tree
+ build-tree optimize-tree
H{ } clone words-called set
H{ } clone generics-called set
@@ -156,7 +153,7 @@ SYMBOL: node-count
[ 1+ ] dip
dup #call? [
word>> {
- { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] }
+ { [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
{ [ dup method-body? ] [ methods-called ] }
[ words-called ]
diff --git a/basis/compiler/tree/def-use/def-use-tests.factor b/basis/compiler/tree/def-use/def-use-tests.factor
index d970e04afd..227a1f1dd7 100644
--- a/basis/compiler/tree/def-use/def-use-tests.factor
+++ b/basis/compiler/tree/def-use/def-use-tests.factor
@@ -7,8 +7,6 @@ compiler.tree.def-use arrays kernel.private sorting math.order
binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests
-\ compute-def-use must-infer
-
[ t ] [
[ 1 2 3 ] build-tree compute-def-use drop
def-use get {
diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor
index 333b3fa636..ed253ad89b 100644
--- a/basis/compiler/tree/escape-analysis/check/check.factor
+++ b/basis/compiler/tree/escape-analysis/check/check.factor
@@ -12,7 +12,6 @@ M: #push run-escape-analysis*
M: #call run-escape-analysis*
{
- { [ dup word>> \ <complex> eq? ] [ t ] }
{ [ dup immutable-tuple-boa? ] [ t ] }
[ f ]
} cond nip ;
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 9a226b954f..5f89372ebe 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -11,15 +11,13 @@ compiler.tree.propagation.info stack-checker.errors
compiler.tree.checker
kernel.private ;
-\ escape-analysis must-infer
-
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )
out-d>> first escaping-allocation? [ 1+ ] unless ;
M: #call count-unboxed-allocations*
- dup [ immutable-tuple-boa? ] [ word>> \ <complex> eq? ] bi or
+ dup immutable-tuple-boa?
[ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations*
@@ -293,7 +291,7 @@ C: <ro-box> ro-box
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
-[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
+[ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor
index fe1e60dbc2..729d6a0490 100644
--- a/basis/compiler/tree/escape-analysis/simple/simple.factor
+++ b/basis/compiler/tree/escape-analysis/simple/simple.factor
@@ -47,9 +47,6 @@ M: #push escape-analysis*
[ record-unknown-allocation ]
if ;
-: record-complex-allocation ( #call -- )
- [ in-d>> ] [ out-d>> first ] bi record-allocation ;
-
: slot-offset ( #call -- n/f )
dup in-d>>
[ first node-value-info class>> ]
@@ -71,7 +68,6 @@ M: #push escape-analysis*
M: #call escape-analysis*
dup word>> {
{ \ <tuple-boa> [ record-tuple-allocation ] }
- { \ <complex> [ record-complex-allocation ] }
{ \ slot [ record-slot-call ] }
[ drop record-unknown-allocation ]
} case ;
diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor
index 5ac3c57abe..3b4574effe 100644
--- a/basis/compiler/tree/normalization/normalization-tests.factor
+++ b/basis/compiler/tree/normalization/normalization-tests.factor
@@ -6,9 +6,6 @@ compiler.tree.normalization.renaming
compiler.tree compiler.tree.checker
sequences accessors tools.test kernel math ;
-\ count-introductions must-infer
-\ normalize must-infer
-
[ 3 ] [ [ 3drop 1 2 3 ] build-tree count-introductions ] unit-test
[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree count-introductions ] unit-test
@@ -17,13 +14,13 @@ sequences accessors tools.test kernel math ;
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
-: foo ( -- ) swap ; inline recursive
+: foo ( quot: ( -- ) -- ) call ; inline recursive
: recursive-inputs ( nodes -- n )
[ #recursive? ] find nip child>> first in-d>> length ;
-[ 0 2 ] [
- [ foo ] build-tree
+[ 1 3 ] [
+ [ [ swap ] foo ] build-tree
[ recursive-inputs ]
[ analyze-recursive normalize recursive-inputs ] bi
] unit-test
@@ -34,18 +31,18 @@ sequences accessors tools.test kernel math ;
[ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test
DEFER: bbb
-: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
-: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive
+: aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive
+: bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive
[ ] [ [ bbb ] test-normalization ] unit-test
-: ccc ( -- ) ccc drop 1 ; inline recursive
+: ccc ( obj -- 1 ) ccc drop 1 ; inline recursive
[ ] [ [ ccc ] test-normalization ] unit-test
DEFER: eee
-: ddd ( -- ) eee ; inline recursive
-: eee ( -- ) swap ddd ; inline recursive
+: ddd ( a b -- a b ) eee ; inline recursive
+: eee ( a b -- a b ) swap ddd ; inline recursive
[ ] [ [ eee ] test-normalization ] unit-test
diff --git a/basis/compiler/tree/optimizer/optimizer-tests.factor b/basis/compiler/tree/optimizer/optimizer-tests.factor
index 1075e441e7..5d05947b8a 100644
--- a/basis/compiler/tree/optimizer/optimizer-tests.factor
+++ b/basis/compiler/tree/optimizer/optimizer-tests.factor
@@ -1,4 +1,4 @@
USING: compiler.tree.optimizer tools.test ;
IN: compiler.tree.optimizer.tests
-\ optimize-tree must-infer
+
diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor
index 54c6c2c117..fe3c7acb92 100644
--- a/basis/compiler/tree/optimizer/optimizer.factor
+++ b/basis/compiler/tree/optimizer/optimizer.factor
@@ -18,6 +18,12 @@ IN: compiler.tree.optimizer
SYMBOL: check-optimizer?
+: ?check ( nodes -- nodes' )
+ check-optimizer? get [
+ compute-def-use
+ dup check-nodes
+ ] when ;
+
: optimize-tree ( nodes -- nodes' )
analyze-recursive
normalize
@@ -30,10 +36,7 @@ SYMBOL: check-optimizer?
apply-identities
compute-def-use
remove-dead-code
- check-optimizer? get [
- compute-def-use
- dup check-nodes
- ] when
+ ?check
compute-def-use
optimize-modular-arithmetic
finalize ;
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index c56db570b2..4d4b22218d 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -59,29 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval }
: <value-info> ( -- info ) \ value-info new ;
-: read-only-slots ( values class -- slots )
- all-slots
- [ read-only>> [ drop f ] unless ] 2map
- f prefix ;
-
DEFER: <literal-info>
+: tuple-slot-infos ( tuple -- slots )
+ [ tuple-slots ] [ class all-slots ] bi
+ [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
+ f prefix ;
+
: init-literal-info ( info -- info )
dup literal>> class >>class
dup literal>> dup real? [ [a,a] >>interval ] [
[ [-inf,inf] >>interval ] dip
- {
- { [ dup complex? ] [
- [ real-part <literal-info> ]
- [ imaginary-part <literal-info> ] bi
- 2array >>slots
- ] }
- { [ dup tuple? ] [
- [ tuple-slots [ <literal-info> ] map ] [ class ] bi
- read-only-slots >>slots
- ] }
- [ drop ]
- } cond
+ dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
] if ; inline
: init-value-info ( info -- info )
@@ -238,7 +227,7 @@ DEFER: (value-info-union)
: value-infos-union ( infos -- info )
[ null-info ]
- [ unclip-slice [ value-info-union ] reduce ] if-empty ;
+ [ [ ] [ value-info-union ] map-reduce ] if-empty ;
: literals<= ( info1 info2 -- ? )
{
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index f18cfcd3a3..2a7d431314 100755
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -1,9 +1,10 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays sequences math math.order
-math.partial-dispatch generic generic.standard generic.math
+math.partial-dispatch generic generic.standard generic.single generic.math
classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations classes fry combinators.smart
+words namespaces continuations classes fry combinators.smart hints
+locals
compiler.tree
compiler.tree.builder
compiler.tree.recursive
@@ -27,24 +28,34 @@ SYMBOL: node-count
SYMBOL: inlining-count
! Splicing nodes
-GENERIC: splicing-nodes ( #call word/quot/f -- nodes )
-
-M: word splicing-nodes
+: splicing-call ( #call word -- nodes )
[ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ;
-M: callable splicing-nodes
- build-sub-tree analyze-recursive normalize ;
+: splicing-body ( #call quot/word -- nodes/f )
+ build-sub-tree dup [ analyze-recursive normalize ] when ;
! Dispatch elimination
+: undo-inlining ( #call -- ? )
+ f >>method f >>body f >>class drop f ;
+
+: propagate-body ( #call -- ? )
+ body>> (propagate) t ;
+
+GENERIC: splicing-nodes ( #call word/quot -- nodes/f )
+
+M: word splicing-nodes splicing-call ;
+
+M: callable splicing-nodes splicing-body ;
+
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
[ >>class ] dip
- over method>> over = [ drop ] [
- 2dup splicing-nodes
- [ >>method ] [ >>body ] bi*
+ over method>> over = [ drop propagate-body ] [
+ 2dup splicing-nodes dup [
+ [ >>method ] [ >>body ] bi* propagate-body
+ ] [ 2drop undo-inlining ] if
] if
- body>> (propagate) t
- ] [ 2drop f >>method f >>body f >>class drop f ] if ;
+ ] [ 2drop undo-inlining ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
dup "methods" word-prop assoc-empty? [ 2drop f f ] [
@@ -136,19 +147,21 @@ DEFER: (flat-length)
[
[ classes-known? 2 0 ? ]
[
- {
- [ body-length-bias ]
- [ "default" word-prop -4 0 ? ]
- [ "specializer" word-prop 1 0 ? ]
- [ method-body? 1 0 ? ]
- } cleave
+ [ body-length-bias ]
+ [ "specializer" word-prop 1 0 ? ]
+ [ method-body? 1 0 ? ]
+ tri
node-count-bias
loop-nesting get 0 or 2 *
] bi*
] sum-outputs ;
: should-inline? ( #call word -- ? )
- dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
+ {
+ { [ dup contains-breakpoints? ] [ 2drop f ] }
+ { [ dup "inline" word-prop ] [ 2drop t ] }
+ [ inlining-rank 5 >= ]
+ } cond ;
SYMBOL: history
@@ -157,19 +170,17 @@ SYMBOL: history
[ history [ swap suffix ] change ]
bi ;
-: inline-word-def ( #call word quot -- ? )
- over history get memq? [ 3drop f ] [
- [
- [ remember-inlining ] dip
- [ drop ] [ splicing-nodes ] 2bi
- [ >>body drop ] [ count-nodes ] [ (propagate) ] tri
- ] with-scope node-count +@
- t
+:: inline-word ( #call word -- ? )
+ word history get memq? [ f ] [
+ #call word splicing-body [
+ [
+ word remember-inlining
+ [ ] [ count-nodes ] [ (propagate) ] tri
+ ] with-scope
+ [ #call (>>body) ] [ node-count +@ ] bi* t
+ ] [ f ] if*
] if ;
-: inline-word ( #call word -- ? )
- dup def>> inline-word-def ;
-
: inline-method-body ( #call word -- ? )
2dup should-inline? [ inline-word ] [ 2drop f ] if ;
@@ -177,7 +188,7 @@ SYMBOL: history
{ curry compose } memq? ;
: never-inline-word? ( word -- ? )
- [ deferred? ] [ { call execute } memq? ] bi or ;
+ [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
@@ -187,10 +198,6 @@ SYMBOL: history
call( #call -- word/quot/f )
object swap eliminate-dispatch ;
-: inline-instance-check ( #call word -- ? )
- over in-d>> second value-info literal>> dup class?
- [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
-
: (do-inlining) ( #call word -- ? )
#! If the generic was defined in an outer compilation unit,
#! then it doesn't have a definition yet; the definition
@@ -202,7 +209,6 @@ SYMBOL: history
#! discouraged, but it should still work.)
{
{ [ dup never-inline-word? ] [ 2drop f ] }
- { [ dup \ instance? eq? ] [ inline-instance-check ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 1b5d383353..b91a1157f7 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -341,6 +341,11 @@ generic-comparison-ops [
] [ 2drop object-info ] if
] "outputs" set-word-prop
+\ instance? [
+ in-d>> second value-info literal>> dup class?
+ [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
+] "custom-inlining" set-word-prop
+
\ equal? [
! If first input has a known type and second input is an
! object, we convert this to [ swap equal? ].
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 5dd647ae89..eba41dbfdf 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -9,11 +9,9 @@ compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm
-math.intervals ;
+math.intervals quotations ;
IN: compiler.tree.propagation.tests
-\ propagate must-infer
-
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
@@ -359,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
] unit-test
[ V{ complex } ] [
- [ <complex> ] final-classes
+ [ complex boa ] final-classes
] unit-test
[ V{ complex } ] [
@@ -377,7 +375,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
[ V{ complex } ] [
[
{ float float object } declare
- [ "Oops" throw ] [ <complex> ] if
+ [ "Oops" throw ] [ complex boa ] if
] final-classes
] unit-test
@@ -592,7 +590,7 @@ MIXIN: empty-mixin
[ V{ float } ] [
[
- [ { float float } declare <complex> ]
+ [ { float float } declare complex boa ]
[ 2drop C{ 0.0 0.0 } ]
if real-part
] final-classes
@@ -680,11 +678,16 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
: (littledan-3-test) ( x -- )
length 1+ f <array> (littledan-3-test) ; inline recursive
-: littledan-3-test ( x -- )
+: littledan-3-test ( -- )
0 f <array> (littledan-3-test) ; inline
[ ] [ [ littledan-3-test ] final-classes drop ] unit-test
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
-[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
\ No newline at end of file
+[ V{ 1 } ] [ [ { } length 1+ f <array> length ] final-literals ] unit-test
+
+! Mutable tuples with circularity should not cause problems
+TUPLE: circle me ;
+
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor
index 1bcd36f6b0..b8d1760a0b 100644
--- a/basis/compiler/tree/propagation/recursive/recursive.factor
+++ b/basis/compiler/tree/propagation/recursive/recursive.factor
@@ -28,8 +28,8 @@ IN: compiler.tree.propagation.recursive
{
{ [ 2dup interval-subset? ] [ empty-interval ] }
{ [ over empty-interval eq? ] [ empty-interval ] }
- { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
- { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
+ { [ 2dup interval>= t eq? ] [ 1/0. [a,a] ] }
+ { [ 2dup interval<= t eq? ] [ -1/0. [a,a] ] }
[ [-inf,inf] ]
} cond interval-union nip ;
diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index 9937c6b9c4..5837d59ef9 100644
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -109,7 +109,7 @@ M: #declare propagate-before
: output-value-infos ( #call word -- infos )
{
- { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
+ { [ dup \ <tuple-boa> eq? ] [ drop propagate-<tuple-boa> ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup predicate? ] [ propagate-predicate ] }
{ [ dup "outputs" word-prop ] [ call-outputs-quot ] }
diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor
index 8192b1c520..86114772f7 100644
--- a/basis/compiler/tree/propagation/slots/slots.factor
+++ b/basis/compiler/tree/propagation/slots/slots.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry assocs arrays byte-arrays strings accessors sequences
kernel slots classes.algebra classes.tuple classes.tuple.private
@@ -8,9 +8,6 @@ IN: compiler.tree.propagation.slots
! Propagation of immutable slots and array lengths
-! Revisit this code when delegation is removed and when complex
-! numbers become tuples.
-
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( word -- ? )
@@ -29,33 +26,26 @@ UNION: fixed-length-sequence array byte-array string ;
[ constructor-output-class <class-info> ]
bi* value-info-intersect 1array ;
-: tuple-constructor? ( word -- ? )
- { <tuple-boa> <complex> } memq? ;
-
: fold-<tuple-boa> ( values class -- info )
[ [ literal>> ] map ] dip prefix >tuple
<literal-info> ;
+: read-only-slots ( values class -- slots )
+ all-slots
+ [ read-only>> [ value-info ] [ drop f ] if ] 2map
+ f prefix ;
+
: (propagate-tuple-constructor) ( values class -- info )
- [ [ value-info ] map ] dip [ read-only-slots ] keep
+ [ read-only-slots ] keep
over rest-slice [ dup [ literal?>> ] when ] all? [
[ rest-slice ] dip fold-<tuple-boa>
] [
<tuple-info>
] if ;
-: propagate-<tuple-boa> ( #call -- info )
+: propagate-<tuple-boa> ( #call -- infos )
in-d>> unclip-last
- value-info literal>> first (propagate-tuple-constructor) ;
-
-: propagate-<complex> ( #call -- info )
- in-d>> [ value-info ] map complex <tuple-info> ;
-
-: propagate-tuple-constructor ( #call word -- infos )
- {
- { \ <tuple-boa> [ propagate-<tuple-boa> ] }
- { \ <complex> [ propagate-<complex> ] }
- } case 1array ;
+ value-info literal>> first (propagate-tuple-constructor) 1array ;
: read-only-slot? ( n class -- ? )
all-slots [ offset>> = ] with find nip
diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor
index d548d58bc6..80edae076f 100644
--- a/basis/compiler/tree/recursive/recursive-tests.factor
+++ b/basis/compiler/tree/recursive/recursive-tests.factor
@@ -10,8 +10,6 @@ compiler.tree.combinators ;
[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test
[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
-\ analyze-recursive must-infer
-
: label-is-loop? ( nodes word -- ? )
[
{
@@ -21,8 +19,6 @@ compiler.tree.combinators ;
} 2&&
] curry contains-node? ;
-\ label-is-loop? must-infer
-
: label-is-not-loop? ( nodes word -- ? )
[
{
@@ -32,8 +28,6 @@ compiler.tree.combinators ;
} 2&&
] curry contains-node? ;
-\ label-is-not-loop? must-infer
-
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
@@ -57,7 +51,7 @@ compiler.tree.combinators ;
\ (each-integer) label-is-loop?
] unit-test
-: loop-test-2 ( a -- )
+: loop-test-2 ( a b -- a' )
dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive
[ t ] [
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index 81ba01f1e2..70670648b1 100644
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -8,8 +8,6 @@ compiler.tree.def-use kernel accessors sequences math
math.private sorting math.order binary-search sequences.private
slots.private ;
-\ unbox-tuples must-infer
-
: test-unboxing ( quot -- )
build-tree
analyze-recursive
@@ -34,7 +32,6 @@ TUPLE: empty-tuple ;
[ dup [ drop f ] [ "A" throw ] if ]
[ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ]
[ [ ] [ ] curry curry call ]
- [ <complex> <complex> dup 1 slot drop 2 slot drop ]
[ 1 cons boa over [ "A" throw ] when car>> ]
[ [ <=> ] sort ]
[ [ <=> ] with search ]
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 1e00efa835..107ea59902 100755
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes )
: unbox-<tuple-boa> ( #call -- nodes )
dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
-: unbox-<complex> ( #call -- nodes )
- dup unbox-output? [ drop { } ] when ;
-
: (flatten-values) ( values accum -- )
dup '[
dup unboxed-allocation
@@ -70,7 +67,6 @@ M: #push unbox-tuples* ( #push -- nodes )
M: #call unbox-tuples*
dup word>> {
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
- { \ <complex> [ unbox-<complex> ] }
{ \ slot [ unbox-slot-access ] }
[ drop ]
} case ;
diff --git a/basis/concurrency/conditions/conditions.factor b/basis/concurrency/conditions/conditions.factor
index 11e624110c..ad00bbdfa9 100644
--- a/basis/concurrency/conditions/conditions.factor
+++ b/basis/concurrency/conditions/conditions.factor
@@ -20,10 +20,12 @@ IN: concurrency.conditions
]
] dip later ;
+ERROR: wait-timeout ;
+
: wait ( queue timeout status -- )
over [
[ queue-timeout [ drop ] ] dip suspend
- [ "Timeout" throw ] [ cancel-alarm ] if
+ [ wait-timeout ] [ cancel-alarm ] if
] [
[ drop '[ _ push-front ] ] dip suspend drop
] if ;
diff --git a/basis/concurrency/exchangers/exchangers-tests.factor b/basis/concurrency/exchangers/exchangers-tests.factor
index 569b1a72c2..3b5b014fe3 100644
--- a/basis/concurrency/exchangers/exchangers-tests.factor
+++ b/basis/concurrency/exchangers/exchangers-tests.factor
@@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers
concurrency.count-downs concurrency.promises locals kernel
threads ;
-:: exchanger-test ( -- )
+:: exchanger-test ( -- string )
[let |
ex [ <exchanger> ]
c [ 2 <count-down> ]
diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor
index a666293316..05ff74b03f 100644
--- a/basis/concurrency/flags/flags-tests.factor
+++ b/basis/concurrency/flags/flags-tests.factor
@@ -11,7 +11,7 @@ kernel threads locals accessors calendar ;
[ f ] [ flag-test-1 ] unit-test
-:: flag-test-2 ( -- )
+:: flag-test-2 ( -- ? )
[let | f [ <flag> ] |
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop
f lower-flag
diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor
index 64971eeb77..81e54f1807 100644
--- a/basis/concurrency/mailboxes/mailboxes-tests.factor
+++ b/basis/concurrency/mailboxes/mailboxes-tests.factor
@@ -1,6 +1,6 @@
IN: concurrency.mailboxes.tests
-USING: concurrency.mailboxes concurrency.count-downs vectors
-sequences threads tools.test math kernel strings namespaces
+USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions
+vectors sequences threads tools.test math kernel strings namespaces
continuations calendar destructors ;
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as
@@ -75,3 +75,15 @@ continuations calendar destructors ;
[ ] [ "d" get 5 seconds await-timeout ] unit-test
[ ] [ "m" get dispose ] unit-test
+
+[ { "foo" "bar" } ] [
+ <mailbox>
+ "foo" over mailbox-put
+ "bar" over mailbox-put
+ mailbox-get-all
+] unit-test
+
+[
+ <mailbox> 1 seconds mailbox-get-timeout
+] [ wait-timeout? ] must-fail-with
+
\ No newline at end of file
diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor
index f6aec94b41..200adb14ae 100755
--- a/basis/concurrency/mailboxes/mailboxes.factor
+++ b/basis/concurrency/mailboxes/mailboxes.factor
@@ -49,7 +49,7 @@ M: mailbox dispose* threads>> notify-all ;
: mailbox-get-all-timeout ( mailbox timeout -- array )
block-if-empty
- [ dup mailbox-empty? ]
+ [ dup mailbox-empty? not ]
[ dup data>> pop-back ]
produce nip ;
diff --git a/basis/concurrency/promises/promises-docs.factor b/basis/concurrency/promises/promises-docs.factor
index 8e160842a9..69f12d8739 100644
--- a/basis/concurrency/promises/promises-docs.factor
+++ b/basis/concurrency/promises/promises-docs.factor
@@ -7,6 +7,10 @@ IN: concurrency.promises
HELP: promise
{ $class-description "The class of write-once promises." } ;
+HELP: <promise>
+{ $values { "promise" promise } }
+{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;
+
HELP: promise-fulfilled?
{ $values { "promise" promise } { "?" "a boolean" } }
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;
diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor
index 46f6639ab8..1956cd9c20 100644
--- a/basis/core-foundation/fsevents/fsevents.factor
+++ b/basis/core-foundation/fsevents/fsevents.factor
@@ -151,8 +151,8 @@ SYMBOL: event-stream-callbacks
\ event-stream-counter counter ;
[
- event-stream-callbacks global
- [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-at
+ event-stream-callbacks
+ [ [ drop expired? not ] assoc-filter H{ } assoc-like ] change-global
] "core-foundation" add-init-hook
: add-event-source-callback ( quot -- id )
diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor
index f35a5cfca8..09db4cb050 100644
--- a/basis/cpu/ppc/assembler/assembler-tests.factor
+++ b/basis/cpu/ppc/assembler/assembler-tests.factor
@@ -114,5 +114,3 @@ make vocabs sequences ;
{ HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler
{ HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler
{ HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler
-
-"cpu.ppc.assembler" words [ must-infer ] each
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index ec7bf8f341..7278fd2092 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -2,15 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.ppc.assembler compiler.codegen.fixup compiler.units
-compiler.constants math math.private layouts words words.private
+compiler.constants math math.private layouts words
vocabs slots.private locals.backend ;
IN: bootstrap.ppc
4 \ cell set
big-endian on
-4 jit-code-format set
-
CONSTANT: ds-reg 29
CONSTANT: rs-reg 30
@@ -23,7 +21,7 @@ CONSTANT: rs-reg 30
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
[
- 0 6 LOAD32
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
11 6 profile-count-offset LWZ
11 11 1 tag-fixnum ADDI
11 6 profile-count-offset STW
@@ -31,65 +29,50 @@ CONSTANT: rs-reg 30
11 11 compiled-header-size ADDI
11 MTCTR
BCTR
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define
+] jit-profiling jit-define
[
- 0 6 LOAD32
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 MFLR
1 1 stack-frame SUBI
6 1 xt-save STW
stack-frame 6 LI
6 1 next-save STW
0 1 lr-save stack-frame + STW
-] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define
+] jit-prolog jit-define
[
- 0 6 LOAD32
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
6 ds-reg 4 STWU
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define
+] jit-push-immediate jit-define
[
- 0 6 LOAD32
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
7 6 0 LWZ
1 7 0 STW
-] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define
+] jit-save-stack jit-define
[
- 0 6 LOAD32
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
6 MTCTR
BCTR
-] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define
+] jit-primitive jit-define
-[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define
+[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
-[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define
+[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
0 3 \ f tag-number CMPI
2 BEQ
- 0 B
-] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define
+ 0 B rc-relative-ppc-3 rt-xt jit-rel
+] jit-if-1 jit-define
[
- 0 B
-] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define
-
-: jit-jump-quot ( -- )
- 4 3 quot-xt-offset LWZ
- 4 MTCTR
- BCTR ;
-
-[
- 0 3 LOAD32
- 6 ds-reg 0 LWZ
- 6 6 1 SRAWI
- 3 3 6 ADD
- 3 3 array-start-offset LWZ
- ds-reg dup 4 SUBI
- jit-jump-quot
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define
+ 0 B rc-relative-ppc-3 rt-xt jit-rel
+] jit-if-2 jit-define
: jit->r ( -- )
4 ds-reg 0 LWZ
@@ -139,29 +122,29 @@ CONSTANT: rs-reg 30
[
jit->r
- 0 BL
+ 0 BL rc-relative-ppc-3 rt-xt jit-rel
jit-r>
-] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define
+] jit-dip jit-define
[
jit-2>r
- 0 BL
+ 0 BL rc-relative-ppc-3 rt-xt jit-rel
jit-2r>
-] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define
+] jit-2dip jit-define
[
jit-3>r
- 0 BL
+ 0 BL rc-relative-ppc-3 rt-xt jit-rel
jit-3r>
-] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define
+] jit-3dip jit-define
[
0 1 lr-save stack-frame + LWZ
1 1 stack-frame ADDI
0 MTLR
-] f f f jit-epilog jit-define
+] jit-epilog jit-define
-[ BLR ] f f f jit-return jit-define
+[ BLR ] jit-return jit-define
! Sub-primitives
@@ -169,8 +152,10 @@ CONSTANT: rs-reg 30
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
- jit-jump-quot
-] f f f \ (call) define-sub-primitive
+ 4 3 quot-xt-offset LWZ
+ 4 MTCTR
+ BCTR
+] \ (call) define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -178,7 +163,7 @@ CONSTANT: rs-reg 30
4 3 word-xt-offset LWZ
4 MTCTR
BCTR
-] f f f \ (execute) define-sub-primitive
+] \ (execute) define-sub-primitive
! Objects
[
@@ -186,7 +171,7 @@ CONSTANT: rs-reg 30
3 3 tag-mask get ANDI
3 3 tag-bits get SLWI
3 ds-reg 0 STW
-] f f f \ tag define-sub-primitive
+] \ tag define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -195,25 +180,25 @@ CONSTANT: rs-reg 30
4 4 0 0 31 tag-bits get - RLWINM
4 3 3 LWZX
3 ds-reg 0 STW
-] f f f \ slot define-sub-primitive
+] \ slot define-sub-primitive
! Shufflers
[
ds-reg dup 4 SUBI
-] f f f \ drop define-sub-primitive
+] \ drop define-sub-primitive
[
ds-reg dup 8 SUBI
-] f f f \ 2drop define-sub-primitive
+] \ 2drop define-sub-primitive
[
ds-reg dup 12 SUBI
-] f f f \ 3drop define-sub-primitive
+] \ 3drop define-sub-primitive
[
3 ds-reg 0 LWZ
3 ds-reg 4 STWU
-] f f f \ dup define-sub-primitive
+] \ dup define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -221,7 +206,7 @@ CONSTANT: rs-reg 30
ds-reg dup 8 ADDI
3 ds-reg 0 STW
4 ds-reg -4 STW
-] f f f \ 2dup define-sub-primitive
+] \ 2dup define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -231,36 +216,36 @@ CONSTANT: rs-reg 30
3 ds-reg 0 STW
4 ds-reg -4 STW
5 ds-reg -8 STW
-] f f f \ 3dup define-sub-primitive
+] \ 3dup define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
3 ds-reg 0 STW
-] f f f \ nip define-sub-primitive
+] \ nip define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg dup 8 SUBI
3 ds-reg 0 STW
-] f f f \ 2nip define-sub-primitive
+] \ 2nip define-sub-primitive
[
3 ds-reg -4 LWZ
3 ds-reg 4 STWU
-] f f f \ over define-sub-primitive
+] \ over define-sub-primitive
[
3 ds-reg -8 LWZ
3 ds-reg 4 STWU
-] f f f \ pick define-sub-primitive
+] \ pick define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
4 ds-reg 0 STW
3 ds-reg 4 STWU
-] f f f \ dupd define-sub-primitive
+] \ dupd define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -268,21 +253,21 @@ CONSTANT: rs-reg 30
3 ds-reg 4 STWU
4 ds-reg -4 STW
3 ds-reg -8 STW
-] f f f \ tuck define-sub-primitive
+] \ tuck define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
3 ds-reg -4 STW
4 ds-reg 0 STW
-] f f f \ swap define-sub-primitive
+] \ swap define-sub-primitive
[
3 ds-reg -4 LWZ
4 ds-reg -8 LWZ
3 ds-reg -8 STW
4 ds-reg -4 STW
-] f f f \ swapd define-sub-primitive
+] \ swapd define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -291,7 +276,7 @@ CONSTANT: rs-reg 30
4 ds-reg -8 STW
3 ds-reg -4 STW
5 ds-reg 0 STW
-] f f f \ rot define-sub-primitive
+] \ rot define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -300,23 +285,22 @@ CONSTANT: rs-reg 30
3 ds-reg -8 STW
5 ds-reg -4 STW
4 ds-reg 0 STW
-] f f f \ -rot define-sub-primitive
+] \ -rot define-sub-primitive
-[ jit->r ] f f f \ load-local define-sub-primitive
+[ jit->r ] \ load-local define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
- 0 3 LOAD32
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
4 ds-reg 0 LWZ
5 ds-reg -4 LWZU
5 0 4 CMP
- 2 swap execute ! magic number
+ 2 swap execute( offset -- ) ! magic number
\ f tag-number 3 LI
3 ds-reg 0 STW ;
: define-jit-compare ( insn word -- )
- [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip
- define-sub-primitive ;
+ [ [ jit-compare ] curry ] dip define-sub-primitive ;
\ BEQ \ eq? define-jit-compare
\ BGE \ fixnum>= define-jit-compare
@@ -336,17 +320,17 @@ CONSTANT: rs-reg 30
2 BNE
1 tag-fixnum 4 LI
4 ds-reg 0 STW
-] f f f \ both-fixnums? define-sub-primitive
+] \ both-fixnums? define-sub-primitive
: jit-math ( insn -- )
3 ds-reg 0 LWZ
4 ds-reg -4 LWZU
- [ 5 3 4 ] dip execute
+ [ 5 3 4 ] dip execute( dst src1 src2 -- )
5 ds-reg 0 STW ;
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
-[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive
+[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -354,20 +338,20 @@ CONSTANT: rs-reg 30
4 4 tag-bits get SRAWI
5 3 4 MULLW
5 ds-reg 0 STW
-] f f f \ fixnum*fast define-sub-primitive
+] \ fixnum*fast define-sub-primitive
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
[
3 ds-reg 0 LWZ
3 3 NOT
3 3 tag-mask get XORI
3 ds-reg 0 STW
-] f f f \ fixnum-bitnot define-sub-primitive
+] \ fixnum-bitnot define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -382,7 +366,7 @@ CONSTANT: rs-reg 30
2 BGT
5 7 MR
5 ds-reg 0 STW
-] f f f \ fixnum-shift-fast define-sub-primitive
+] \ fixnum-shift-fast define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -392,7 +376,7 @@ CONSTANT: rs-reg 30
6 5 3 MULLW
7 6 4 SUBF
7 ds-reg 0 STW
-] f f f \ fixnum-mod define-sub-primitive
+] \ fixnum-mod define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -401,7 +385,7 @@ CONSTANT: rs-reg 30
5 4 3 DIVW
5 5 tag-bits get SLWI
5 ds-reg 0 STW
-] f f f \ fixnum/i-fast define-sub-primitive
+] \ fixnum/i-fast define-sub-primitive
[
3 ds-reg 0 LWZ
@@ -412,20 +396,20 @@ CONSTANT: rs-reg 30
5 5 tag-bits get SLWI
5 ds-reg -4 STW
7 ds-reg 0 STW
-] f f f \ fixnum/mod-fast define-sub-primitive
+] \ fixnum/mod-fast define-sub-primitive
[
3 ds-reg 0 LWZ
3 3 1 SRAWI
rs-reg 3 3 LWZX
3 ds-reg 0 STW
-] f f f \ get-local define-sub-primitive
+] \ get-local define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
3 3 1 SRAWI
rs-reg 3 rs-reg SUBF
-] f f f \ drop-locals define-sub-primitive
+] \ drop-locals define-sub-primitive
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index b280afc01e..10cd9c8657 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -309,7 +309,7 @@ FUNCTION: bool check_sse2 ( ) ;
check_sse2 ;
"-no-sse2" (command-line) member? [
- optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable
+ [ { check_sse2 } compile ] with-optimizer
"Checking if your CPU supports SSE2..." print flush
sse2? [
diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor
index 5d88f699b8..be21344815 100644
--- a/basis/cpu/x86/32/bootstrap.factor
+++ b/basis/cpu/x86/32/bootstrap.factor
@@ -22,13 +22,15 @@ IN: bootstrap.x86
: rex-length ( -- n ) 0 ;
[
- temp0 0 [] MOV ! load stack_chain
- temp0 [] stack-reg MOV ! save stack pointer
-] rc-absolute-cell rt-stack-chain 2 jit-save-stack jit-define
+ ! load stack_chain
+ temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
+ ! save stack pointer
+ temp0 [] stack-reg MOV
+] jit-save-stack jit-define
[
- (JMP) drop
-] rc-relative rt-primitive 1 jit-primitive jit-define
+ (JMP) drop rc-relative rt-primitive jit-rel
+] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
call
diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor
index ddf5791009..8d1ed086e7 100644
--- a/basis/cpu/x86/64/bootstrap.factor
+++ b/basis/cpu/x86/64/bootstrap.factor
@@ -20,15 +20,19 @@ IN: bootstrap.x86
: rex-length ( -- n ) 1 ;
[
- temp0 0 MOV ! load stack_chain
+ ! load stack_chain
+ temp0 0 MOV rc-absolute-cell rt-stack-chain jit-rel
temp0 temp0 [] MOV
- temp0 [] stack-reg MOV ! save stack pointer
-] rc-absolute-cell rt-stack-chain 1 rex-length + jit-save-stack jit-define
+ ! save stack pointer
+ temp0 [] stack-reg MOV
+] jit-save-stack jit-define
[
- temp1 0 MOV ! load XT
- temp1 JMP ! go
-] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
+ ! load XT
+ temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
+ ! go
+ temp1 JMP
+] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
call
diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor
index 49b0961819..203edf956e 100644
--- a/basis/cpu/x86/assembler/assembler-tests.factor
+++ b/basis/cpu/x86/assembler/assembler-tests.factor
@@ -62,3 +62,5 @@ IN: cpu.x86.assembler.tests
[ { HEX: 48 HEX: d3 HEX: e1 } ] [ [ RCX CL SHL ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e8 } ] [ [ RAX CL SHR ] { } make ] unit-test
[ { HEX: 48 HEX: d3 HEX: e9 } ] [ [ RCX CL SHR ] { } make ] unit-test
+
+[ { HEX: f7 HEX: c1 HEX: d2 HEX: 04 HEX: 00 HEX: 00 } ] [ [ ECX 1234 TEST ] { } make ] unit-test
diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor
index 3a98d47416..5560d17a1e 100644
--- a/basis/cpu/x86/assembler/assembler.factor
+++ b/basis/cpu/x86/assembler/assembler.factor
@@ -316,15 +316,16 @@ M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
M: f CALL (CALL) 2drop ;
-M: callable CALL (CALL) rel-word ;
+M: callable CALL (CALL) rel-word-direct ;
M: label CALL (CALL) label-fixup ;
M: operand CALL { BIN: 010 t HEX: ff } 1-operand ;
GENERIC# JUMPcc 1 ( addr opcode -- )
-: (JUMPcc) ( n -- rel-class ) extended-opcode, 0 4, rc-relative ;
-M: f JUMPcc nip (JUMPcc) drop ;
-M: callable JUMPcc (JUMPcc) rel-word ;
-M: label JUMPcc (JUMPcc) label-fixup ;
+: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
+M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
+M: integer JUMPcc (JUMPcc) drop ;
+M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
+M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;
@@ -382,6 +383,10 @@ GENERIC: CMP ( dst src -- )
M: immediate CMP swap { BIN: 111 t HEX: 80 } immediate-1/4 ;
M: operand CMP OCT: 070 2-operand ;
+GENERIC: TEST ( dst src -- )
+M: immediate TEST swap { BIN: 0 t HEX: f7 } immediate-4 ;
+M: operand TEST OCT: 204 2-operand ;
+
: XCHG ( dst src -- ) OCT: 207 2-operand ;
: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index f5829d76ea..4fe5e5cd33 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -1,18 +1,16 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel kernel.private namespaces
system cpu.x86.assembler layouts compiler.units math
math.private compiler.constants vocabs slots.private words
-words.private locals.backend ;
+locals.backend make sequences combinators arrays ;
IN: bootstrap.x86
big-endian off
-1 jit-code-format set
-
[
! Load word
- temp0 0 MOV
+ temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! Bump profiling counter
temp0 profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
@@ -21,35 +19,35 @@ big-endian off
temp0 compiled-header-size ADD
! Jump to XT
temp0 JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-profiling jit-define
+] jit-profiling jit-define
[
! load XT
- temp0 0 MOV
+ temp0 0 MOV rc-absolute-cell rt-this jit-rel
! save stack frame size
stack-frame-size PUSH
! push XT
temp0 PUSH
! alignment
stack-reg stack-frame-size 3 bootstrap-cells - SUB
-] rc-absolute-cell rt-this 1 rex-length + jit-prolog jit-define
+] jit-prolog jit-define
[
! load literal
- temp0 0 MOV
+ temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
! increment datastack pointer
ds-reg bootstrap-cell ADD
! store literal on datastack
ds-reg [] temp0 MOV
-] rc-absolute-cell rt-immediate 1 rex-length + jit-push-immediate jit-define
+] jit-push-immediate jit-define
[
- f JMP
-] rc-relative rt-xt 1 jit-word-jump jit-define
+ f JMP rc-relative rt-xt jit-rel
+] jit-word-jump jit-define
[
- f CALL
-] rc-relative rt-xt 1 jit-word-call jit-define
+ f CALL rc-relative rt-xt-direct jit-rel
+] jit-word-call jit-define
[
! load boolean
@@ -59,31 +57,13 @@ big-endian off
! compare boolean with f
temp0 \ f tag-number CMP
! jump to true branch if not equal
- f JNE
-] rc-relative rt-xt 10 rex-length 3 * + jit-if-1 jit-define
+ f JNE rc-relative rt-xt jit-rel
+] jit-if-1 jit-define
[
! jump to false branch if equal
- f JMP
-] rc-relative rt-xt 1 jit-if-2 jit-define
-
-[
- ! load dispatch table
- temp1 0 MOV
- ! load index
- temp0 ds-reg [] MOV
- ! turn it into an array offset
- fixnum>slot@
- ! pop index
- ds-reg bootstrap-cell SUB
- ! compute quotation location
- temp0 temp1 ADD
- ! load quotation
- arg temp0 array-start-offset [+] MOV
- ! execute branch. the quot must be in arg, since it might
- ! not be compiled yet
- arg quot-xt-offset [+] JMP
-] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
+ f JMP rc-relative rt-xt jit-rel
+] jit-if-2 jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
@@ -135,30 +115,133 @@ big-endian off
[
jit->r
- f CALL
+ f CALL rc-relative rt-xt jit-rel
jit-r>
-] rc-relative rt-xt 11 rex-length 4 * + jit-dip jit-define
+] jit-dip jit-define
[
jit-2>r
- f CALL
+ f CALL rc-relative rt-xt jit-rel
jit-2r>
-] rc-relative rt-xt 17 rex-length 6 * + jit-2dip jit-define
+] jit-2dip jit-define
[
jit-3>r
- f CALL
+ f CALL rc-relative rt-xt jit-rel
jit-3r>
-] rc-relative rt-xt 23 rex-length 8 * + jit-3dip jit-define
+] jit-3dip jit-define
+
+: prepare-(execute) ( -- operand )
+ ! load from stack
+ temp0 ds-reg [] MOV
+ ! pop stack
+ ds-reg bootstrap-cell SUB
+ ! execute word
+ temp0 word-xt-offset [+] ;
+
+[ prepare-(execute) JMP ] jit-execute-jump jit-define
+
+[ prepare-(execute) CALL ] jit-execute-call jit-define
[
! unwind stack frame
stack-reg stack-frame-size bootstrap-cell - ADD
-] f f f jit-epilog jit-define
+] jit-epilog jit-define
-[ 0 RET ] f f f jit-return jit-define
+[ 0 RET ] jit-return jit-define
-! Sub-primitives
+! ! ! Polymorphic inline caches
+
+! temp0 contains the object being dispatched on
+! temp1 contains its class
+
+! Load a value from a stack position
+[
+ temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel
+] pic-load jit-define
+
+! Tag
+: load-tag ( -- )
+ temp1 tag-mask get AND
+ temp1 tag-bits get SHL ;
+
+[ load-tag ] pic-tag jit-define
+
+! The 'make' trick lets us compute the jump distance for the
+! conditional branches there
+
+! Hi-tag
+[
+ temp0 temp1 MOV
+ load-tag
+ temp1 object tag-number tag-fixnum CMP
+ [ temp1 temp0 object tag-number neg [+] MOV ] { } make
+ [ length JNE ] [ % ] bi
+] pic-hi-tag jit-define
+
+! Tuple
+[
+ temp0 temp1 MOV
+ load-tag
+ temp1 tuple tag-number tag-fixnum CMP
+ [ temp1 temp0 tuple tag-number neg bootstrap-cell + [+] MOV ] { } make
+ [ length JNE ] [ % ] bi
+] pic-tuple jit-define
+
+! Hi-tag and tuple
+[
+ temp0 temp1 MOV
+ load-tag
+ ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
+ temp1 BIN: 110 tag-fixnum CMP
+ [
+ ! Untag temp0
+ temp0 tag-mask get bitnot AND
+ ! Set temp1 to 0 for objects, and 8 for tuples
+ temp1 1 tag-fixnum AND
+ bootstrap-cell 4 = [ temp1 1 SHR ] when
+ ! Load header cell or tuple layout cell
+ temp1 temp0 temp1 [+] MOV
+ ] [ ] make [ length JL ] [ % ] bi
+] pic-hi-tag-tuple jit-define
+
+[
+ temp1 HEX: ffffffff CMP rc-absolute rt-immediate jit-rel
+] pic-check-tag jit-define
+
+[
+ temp2 HEX: ffffffff MOV rc-absolute-cell rt-immediate jit-rel
+ temp1 temp2 CMP
+] pic-check jit-define
+
+[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
+
+! ! ! Megamorphic caches
+
+[
+ ! cache = ...
+ temp0 0 MOV rc-absolute-cell rt-immediate jit-rel
+ ! key = class
+ temp2 temp1 MOV
+ bootstrap-cell 8 = [ temp2 1 SHL ] when
+ ! key &= cache.length - 1
+ temp2 mega-cache-size get 1- bootstrap-cell * AND
+ ! cache += array-start-offset
+ temp0 array-start-offset ADD
+ ! cache += key
+ temp0 temp2 ADD
+ ! if(get(cache) == class)
+ temp0 [] temp1 CMP
+ ! ... goto get(cache + bootstrap-cell)
+ [
+ temp0 temp0 bootstrap-cell [+] MOV
+ temp0 word-xt-offset [+] JMP
+ ] [ ] make
+ [ length JNE ] [ % ] bi
+ ! fall-through on miss
+] mega-lookup jit-define
+
+! ! ! Sub-primitives
! Quotations and words
[
@@ -168,16 +251,7 @@ big-endian off
ds-reg bootstrap-cell SUB
! call quotation
arg quot-xt-offset [+] JMP
-] f f f \ (call) define-sub-primitive
-
-[
- ! load from stack
- temp0 ds-reg [] MOV
- ! pop stack
- ds-reg bootstrap-cell SUB
- ! execute word
- temp0 word-xt-offset [+] JMP
-] f f f \ (execute) define-sub-primitive
+] \ (call) define-sub-primitive
! Objects
[
@@ -189,7 +263,7 @@ big-endian off
temp0 tag-bits get SHL
! push to stack
ds-reg [] temp0 MOV
-] f f f \ tag define-sub-primitive
+] \ tag define-sub-primitive
[
! load slot number
@@ -207,26 +281,26 @@ big-endian off
temp0 temp1 temp0 [+] MOV
! push to stack
ds-reg [] temp0 MOV
-] f f f \ slot define-sub-primitive
+] \ slot define-sub-primitive
! Shufflers
[
ds-reg bootstrap-cell SUB
-] f f f \ drop define-sub-primitive
+] \ drop define-sub-primitive
[
ds-reg 2 bootstrap-cells SUB
-] f f f \ 2drop define-sub-primitive
+] \ 2drop define-sub-primitive
[
ds-reg 3 bootstrap-cells SUB
-] f f f \ 3drop define-sub-primitive
+] \ 3drop define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ dup define-sub-primitive
+] \ dup define-sub-primitive
[
temp0 ds-reg [] MOV
@@ -234,7 +308,7 @@ big-endian off
ds-reg 2 bootstrap-cells ADD
ds-reg [] temp0 MOV
ds-reg bootstrap-cell neg [+] temp1 MOV
-] f f f \ 2dup define-sub-primitive
+] \ 2dup define-sub-primitive
[
temp0 ds-reg [] MOV
@@ -244,31 +318,31 @@ big-endian off
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp3 MOV
-] f f f \ 3dup define-sub-primitive
+] \ 3dup define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
ds-reg [] temp0 MOV
-] f f f \ nip define-sub-primitive
+] \ nip define-sub-primitive
[
temp0 ds-reg [] MOV
ds-reg 2 bootstrap-cells SUB
ds-reg [] temp0 MOV
-] f f f \ 2nip define-sub-primitive
+] \ 2nip define-sub-primitive
[
temp0 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ over define-sub-primitive
+] \ over define-sub-primitive
[
temp0 ds-reg -2 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ pick define-sub-primitive
+] \ pick define-sub-primitive
[
temp0 ds-reg [] MOV
@@ -276,7 +350,7 @@ big-endian off
ds-reg [] temp1 MOV
ds-reg bootstrap-cell ADD
ds-reg [] temp0 MOV
-] f f f \ dupd define-sub-primitive
+] \ dupd define-sub-primitive
[
temp0 ds-reg [] MOV
@@ -285,21 +359,21 @@ big-endian off
ds-reg [] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
-] f f f \ tuck define-sub-primitive
+] \ tuck define-sub-primitive
[
temp0 ds-reg [] MOV
temp1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] temp0 MOV
ds-reg [] temp1 MOV
-] f f f \ swap define-sub-primitive
+] \ swap define-sub-primitive
[
temp0 ds-reg -1 bootstrap-cells [+] MOV
temp1 ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp1 MOV
-] f f f \ swapd define-sub-primitive
+] \ swapd define-sub-primitive
[
temp0 ds-reg [] MOV
@@ -308,7 +382,7 @@ big-endian off
ds-reg -2 bootstrap-cells [+] temp1 MOV
ds-reg -1 bootstrap-cells [+] temp0 MOV
ds-reg [] temp3 MOV
-] f f f \ rot define-sub-primitive
+] \ rot define-sub-primitive
[
temp0 ds-reg [] MOV
@@ -317,14 +391,14 @@ big-endian off
ds-reg -2 bootstrap-cells [+] temp0 MOV
ds-reg -1 bootstrap-cells [+] temp3 MOV
ds-reg [] temp1 MOV
-] f f f \ -rot define-sub-primitive
+] \ -rot define-sub-primitive
-[ jit->r ] f f f \ load-local define-sub-primitive
+[ jit->r ] \ load-local define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
! load t
- temp3 0 MOV
+ temp3 0 MOV rc-absolute-cell rt-immediate jit-rel
! load f
temp1 \ f tag-number MOV
! load first value
@@ -334,13 +408,12 @@ big-endian off
! compare with second value
ds-reg [] temp0 CMP
! move t if true
- [ temp1 temp3 ] dip execute
+ [ temp1 temp3 ] dip execute( dst src -- )
! store
ds-reg [] temp1 MOV ;
: define-jit-compare ( insn word -- )
- [ [ jit-compare ] curry rc-absolute-cell rt-immediate 1 rex-length + ] dip
- define-sub-primitive ;
+ [ [ jit-compare ] curry ] dip define-sub-primitive ;
\ CMOVE \ eq? define-jit-compare
\ CMOVGE \ fixnum>= define-jit-compare
@@ -355,11 +428,11 @@ big-endian off
! pop stack
ds-reg bootstrap-cell SUB
! compute result
- [ ds-reg [] temp0 ] dip execute ;
+ [ ds-reg [] temp0 ] dip execute( dst src -- ) ;
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive
-[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
+[ \ SUB jit-math ] \ fixnum-fast define-sub-primitive
[
! load second input
@@ -374,20 +447,20 @@ big-endian off
temp0 temp1 IMUL2
! push result
ds-reg [] temp1 MOV
-] f f f \ fixnum*fast define-sub-primitive
+] \ fixnum*fast define-sub-primitive
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive
[
! complement
ds-reg [] NOT
! clear tag bits
ds-reg [] tag-mask get XOR
-] f f f \ fixnum-bitnot define-sub-primitive
+] \ fixnum-bitnot define-sub-primitive
[
! load shift count
@@ -411,7 +484,7 @@ big-endian off
temp1 temp3 CMOVGE
! push to stack
ds-reg [] temp1 MOV
-] f f f \ fixnum-shift-fast define-sub-primitive
+] \ fixnum-shift-fast define-sub-primitive
: jit-fixnum-/mod ( -- )
! load second parameter
@@ -431,7 +504,7 @@ big-endian off
ds-reg bootstrap-cell SUB
! push to stack
ds-reg [] mod-arg MOV
-] f f f \ fixnum-mod define-sub-primitive
+] \ fixnum-mod define-sub-primitive
[
jit-fixnum-/mod
@@ -441,7 +514,7 @@ big-endian off
div-arg tag-bits get SHL
! push to stack
ds-reg [] div-arg MOV
-] f f f \ fixnum/i-fast define-sub-primitive
+] \ fixnum/i-fast define-sub-primitive
[
jit-fixnum-/mod
@@ -450,7 +523,7 @@ big-endian off
! push to stack
ds-reg [] mod-arg MOV
ds-reg bootstrap-cell neg [+] div-arg MOV
-] f f f \ fixnum/mod-fast define-sub-primitive
+] \ fixnum/mod-fast define-sub-primitive
[
temp0 ds-reg [] MOV
@@ -461,7 +534,7 @@ big-endian off
temp1 1 tag-fixnum MOV
temp0 temp1 CMOVE
ds-reg [] temp0 MOV
-] f f f \ both-fixnums? define-sub-primitive
+] \ both-fixnums? define-sub-primitive
[
! load local number
@@ -472,7 +545,7 @@ big-endian off
temp0 rs-reg temp0 [+] MOV
! push to stack
ds-reg [] temp0 MOV
-] f f f \ get-local define-sub-primitive
+] \ get-local define-sub-primitive
[
! load local count
@@ -483,6 +556,6 @@ big-endian off
fixnum>slot@
! decrement retain stack pointer
rs-reg temp0 SUB
-] f f f \ drop-locals define-sub-primitive
+] \ drop-locals define-sub-primitive
[ "bootstrap.x86" forget-vocab ] with-compilation-unit
diff --git a/basis/db/errors/sqlite/sqlite.factor b/basis/db/errors/sqlite/sqlite.factor
index c247a36257..c73409b850 100644
--- a/basis/db/errors/sqlite/sqlite.factor
+++ b/basis/db/errors/sqlite/sqlite.factor
@@ -4,7 +4,8 @@ USING: accessors combinators db kernel sequences peg.ebnf
strings db.errors ;
IN: db.errors.sqlite
-ERROR: unparsed-sqlite-error error ;
+TUPLE: unparsed-sqlite-error error ;
+C: <unparsed-sqlite-error> unparsed-sqlite-error
SINGLETONS: table-exists table-missing ;
@@ -22,4 +23,6 @@ SqliteError =
=> [[ table >string message sqlite-table-error ]]
| "no such table: " .+:table
=> [[ table >string <sql-table-missing> ]]
+ | .*:error
+ => [[ error >string <unparsed-sqlite-error> ]]
;EBNF
diff --git a/basis/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor
index 7ff2a33d92..334ff9e11a 100644
--- a/basis/db/pools/pools-tests.factor
+++ b/basis/db/pools/pools-tests.factor
@@ -2,8 +2,6 @@ IN: db.pools.tests
USING: db.pools tools.test continuations io.files io.files.temp
io.directories namespaces accessors kernel math destructors ;
-\ <db-pool> must-infer
-
{ 1 0 } [ [ ] with-db-pool ] must-infer-as
{ 1 0 } [ [ ] with-pooled-db ] must-infer-as
diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor
index 2730340bfc..c4aa47d383 100755
--- a/basis/db/queries/queries.factor
+++ b/basis/db/queries/queries.factor
@@ -4,7 +4,7 @@ USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types classes words shuffle arrays
destructors continuations db.tuples.private prettyprint
-db.private ;
+db.private byte-arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
@@ -115,6 +115,9 @@ M: sequence where ( spec obj -- )
[ " or " 0% ] [ dupd where ] interleave drop
] in-parens ;
+M: byte-array where ( spec obj -- )
+ over column-name>> 0% " = " 0% bind# ;
+
M: NULL where ( spec obj -- )
drop column-name>> 0% " is NULL" 0% ;
diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor
index fcc5abf1cf..56bac7efcd 100644
--- a/basis/db/tester/tester.factor
+++ b/basis/db/tester/tester.factor
@@ -3,7 +3,7 @@
USING: concurrency.combinators db.pools db.sqlite db.tuples
db.types kernel math random threads tools.test db sequences
io prettyprint db.postgresql db.sqlite accessors io.files.temp
-namespaces fry system ;
+namespaces fry system math.parser ;
IN: db.tester
: postgresql-test-db ( -- postgresql-db )
@@ -56,6 +56,10 @@ test-2 "TEST2" {
{ "z" "Z" { VARCHAR 256 } +not-null+ }
} define-persistent
+: test-1-tuple ( -- tuple )
+ f 100 random 100 random 100 random [ number>string ] tri@
+ test-1 boa ;
+
: db-tester ( test-db -- )
[
[
@@ -67,8 +71,7 @@ test-2 "TEST2" {
drop
10 [
dup [
- f 100 random 100 random 100 random test-1 boa
- insert-tuple yield
+ test-1-tuple insert-tuple yield
] with-db
] times
] with parallel-each
@@ -84,8 +87,7 @@ test-2 "TEST2" {
<db-pool> [
10 [
10 [
- f 100 random 100 random 100 random test-1 boa
- insert-tuple yield
+ test-1-tuple insert-tuple yield
] times
] parallel-each
] with-pooled-db
diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor
index 50d7f044d1..afdee3e89f 100644
--- a/basis/db/tuples/tuples-tests.factor
+++ b/basis/db/tuples/tuples-tests.factor
@@ -411,7 +411,7 @@ TUPLE: exam id name score ;
T{ exam f 4 "Cartman" 41 }
}
] [
- T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
+ T{ exam f T{ interval f { 2 t } { 1/0. f } } } select-tuples
] unit-test
[
@@ -419,7 +419,7 @@ TUPLE: exam id name score ;
T{ exam f 1 "Kyle" 100 }
}
] [
- T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
+ T{ exam f T{ interval f { -1/0. t } { 2 f } } } select-tuples
] unit-test
[
@@ -430,7 +430,7 @@ TUPLE: exam id name score ;
T{ exam f 4 "Cartman" 41 }
}
] [
- T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
+ T{ exam f T{ interval f { -1/0. t } { 1/0. f } } } select-tuples
] unit-test
[
@@ -592,17 +592,6 @@ string-encoding-test "STRING_ENCODING_TEST" {
[ test-string-encoding ] test-sqlite
[ test-string-encoding ] test-postgresql
-! Don't comment these out. These words must infer
-\ bind-tuple must-infer
-\ insert-tuple must-infer
-\ update-tuple must-infer
-\ delete-tuples must-infer
-\ select-tuple must-infer
-\ define-persistent must-infer
-\ ensure-table must-infer
-\ create-table must-infer
-\ drop-table must-infer
-
: test-queries ( -- )
[ ] [ exam ensure-table ] unit-test
[ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
@@ -634,3 +623,22 @@ compound-foo "COMPOUND_FOO"
[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql
+
+
+TUPLE: example id data ;
+
+example "EXAMPLE"
+{
+ { "id" "ID" +db-assigned-id+ }
+ { "data" "DATA" BLOB }
+} define-persistent
+
+: test-blob-select ( -- )
+ example ensure-table
+ [ ] [ example new B{ 1 2 3 4 5 } >>data insert-tuple ] unit-test
+ [
+ T{ example { id 1 } { data B{ 1 2 3 4 5 } } }
+ ] [ example new B{ 1 2 3 4 5 } >>data select-tuple ] unit-test ;
+
+[ test-blob-select ] test-sqlite
+[ test-blob-select ] test-postgresql
diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor
index ff5869efab..ff9986432c 100644
--- a/basis/debugger/debugger-docs.factor
+++ b/basis/debugger/debugger-docs.factor
@@ -1,6 +1,6 @@
USING: alien arrays generic generic.math help.markup help.syntax
kernel math memory strings sbufs vectors io io.files classes
-help generic.standard continuations io.files.private listener
+help generic.single continuations io.files.private listener
alien.libraries ;
IN: debugger
diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor
index afa4aa1c28..08f84d9335 100644
--- a/basis/debugger/debugger-tests.factor
+++ b/basis/debugger/debugger-tests.factor
@@ -2,3 +2,6 @@ IN: debugger.tests
USING: debugger kernel continuations tools.test ;
[ ] [ [ drop ] [ error. ] recover ] unit-test
+
+[ f ] [ { } vm-error? ] unit-test
+[ f ] [ { "A" "B" } vm-error? ] unit-test
\ No newline at end of file
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index efd35ab280..bb0268f048 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -1,21 +1,22 @@
! 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 vocabs init kernel.private io.encodings
-accessors math.order destructors source-files parser
-classes.tuple.parser effects.parser lexer compiler.errors
-generic.parser strings.parser vocabs.loader vocabs.parser ;
+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
GENERIC: error. ( error -- )
GENERIC: error-help ( error -- topic )
M: object error. . ;
+
M: object error-help drop f ;
M: tuple error-help class ;
@@ -76,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
@@ -87,8 +88,7 @@ M: string error. print ;
: divide-by-zero-error. ( obj -- )
"Division by zero" print drop ;
-: signal-error. ( obj -- )
- "Operating system signal " write third . ;
+HOOK: signal-error. os ( obj -- )
: array-size-error. ( obj -- )
"Invalid array size: " write dup third .
@@ -98,9 +98,7 @@ M: string error. print ;
"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 ;
@@ -126,14 +124,14 @@ M: string error. print ;
: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
-PREDICATE: kernel-error < array
+PREDICATE: vm-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
[ second 0 15 between? ]
} cond ;
-: kernel-errors ( error -- n errors )
+: vm-errors ( error -- n errors )
second {
{ 0 [ expired-error. ] }
{ 1 [ io-error. ] }
@@ -153,9 +151,11 @@ PREDICATE: kernel-error < array
{ 15 [ memory-error. ] }
} ; inline
-M: kernel-error error. dup kernel-errors case ;
+M: vm-error summary drop "VM error" ;
-M: kernel-error error-help kernel-errors at first ;
+M: vm-error error. dup vm-errors case ;
+
+M: vm-error error-help vm-errors at first ;
M: no-method summary
drop "No suitable method" ;
@@ -213,14 +213,13 @@ M: condition error-help error>> error-help ;
M: assert summary drop "Assertion failed" ;
-M: assert error.
- "Assertion failed" print
+M: assert-sequence summary drop "Assertion failed" ;
+
+M: assert-sequence error.
standard-table-style [
- 15 length-limit set
- 5 line-limit set
- [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
- [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
- ] tabular-output nl ;
+ [ "=== Expected:" print expected>> stack. ]
+ [ "=== Got:" print got>> stack. ] bi
+ ] tabular-output ;
M: immutable summary drop "Sequence is immutable" ;
@@ -268,20 +267,6 @@ M: duplicate-slot-names summary
M: invalid-slot-name summary
drop "Invalid slot name" ;
-: file. ( file -- ) path>> <pathname> . ;
-
-M: source-file-error error.
- [ file>> file. ] [ error>> error. ] bi ;
-
-M: source-file-error summary
- error>> summary ;
-
-M: source-file-error compute-restarts
- error>> compute-restarts ;
-
-M: source-file-error error-help
- error>> error-help ;
-
M: not-in-a-method-error summary
drop "call-next-method can only be called in a method definition" ;
@@ -309,12 +294,6 @@ M: lexer-error compute-restarts
M: lexer-error error-help
error>> error-help ;
-M: object compiler-error. ( error word -- )
- nl
- "While compiling " write pprint ": " print
- nl
- print-error ;
-
M: bad-effect summary
drop "Bad stack effect declaration" ;
@@ -326,4 +305,9 @@ M: check-mixin-class summary drop "Not a mixin class" ;
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
-M: wrong-values summary drop "Quotation called with wrong stack effect" ;
\ No newline at end of file
+M: wrong-values summary drop "Quotation called with wrong stack effect" ;
+
+{
+ { [ os windows? ] [ "debugger.windows" require ] }
+ { [ os unix? ] [ "debugger.unix" require ] }
+} cond
\ No newline at end of file
diff --git a/basis/debugger/unix/authors.txt b/basis/debugger/unix/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/debugger/unix/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/debugger/unix/unix.factor b/basis/debugger/unix/unix.factor
new file mode 100644
index 0000000000..212908b2fd
--- /dev/null
+++ b/basis/debugger/unix/unix.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: debugger io kernel math prettyprint sequences system ;
+IN: debugger.unix
+
+CONSTANT: signal-names
+{
+ "SIGHUP" "SIGINT" "SIGQUIT" "SIGILL" "SIGTRAP" "SIGABRT"
+ "SIGEMT" "SIGFPE" "SIGKILL" "SIGBUS" "SIGSEGV" "SIGSYS"
+ "SIGPIPE" "SIGALRM" "SIGTERM" "SIGURG" "SIGSTOP" "SIGTSIP"
+ "SIGCONT" "SIGCHLD" "SIGTTIN" "SIGTTOU" "SIGIO" "SIGXCPU"
+ "SIGXFSZ" "SIGVTALRM" "SIGPROF" "SIGWINCH" "SIGINFO"
+ "SIGUSR1" "SIGUSR2"
+}
+
+: signal-name ( n -- str/f ) 1- signal-names ?nth ;
+
+: signal-name. ( n -- )
+ signal-name [ " (" ")" surround write ] when* ;
+
+M: unix signal-error. ( obj -- )
+ "Unix signal #" write
+ third [ pprint ] [ signal-name. ] bi nl ;
diff --git a/basis/debugger/windows/authors.txt b/basis/debugger/windows/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/debugger/windows/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/debugger/windows/windows.factor b/basis/debugger/windows/windows.factor
new file mode 100644
index 0000000000..1f4b8fb0ac
--- /dev/null
+++ b/basis/debugger/windows/windows.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: debugger io prettyprint sequences system ;
+IN: debugger.windows
+
+M: windows signal-error. "Windows exception #" write third .h ;
\ No newline at end of file
diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor
index 42b727852e..42e770aa75 100644
--- a/basis/delegate/delegate-docs.factor
+++ b/basis/delegate/delegate-docs.factor
@@ -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
diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor
index cf822b40a3..9f9aca8702 100644
--- a/basis/delegate/delegate-tests.factor
+++ b/basis/delegate/delegate-tests.factor
@@ -1,6 +1,6 @@
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
-accessors eval multiline generic.standard delegate.protocols
+accessors eval multiline generic.single delegate.protocols
delegate.private assocs see ;
IN: delegate.tests
@@ -35,7 +35,7 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
-[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
+[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test
[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
@@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ;
[ 0 ] [ 1 <hey> three ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
-[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
[ f ] [ hey \ two method ] unit-test
[ f ] [ hey \ four method ] unit-test
-[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ 0 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test
[ 0 ] [ 1 <hey> four ] unit-test
-[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test
+[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ -1 ] [ 1 <hey> two ] unit-test
[ -1 ] [ 1 <hey> three ] unit-test
[ -1 ] [ 1 <hey> four ] unit-test
-[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
+[ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
[ f ] [ hey \ one method ] unit-test
TUPLE: slot-protocol-test-1 a b ;
@@ -196,4 +196,4 @@ DEFER: seq-delegate
seq-delegate
sequence-protocol \ protocol-consult word-prop
key?
-] unit-test
\ No newline at end of file
+] unit-test
diff --git a/basis/delegate/protocols/protocols.factor b/basis/delegate/protocols/protocols.factor
index f568a3e388..40054bc4b0 100644
--- a/basis/delegate/protocols/protocols.factor
+++ b/basis/delegate/protocols/protocols.factor
@@ -1,7 +1,6 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: delegate sequences.private sequences assocs
-io definitions kernel continuations ;
+USING: delegate sequences.private sequences assocs io ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
@@ -19,7 +18,3 @@ stream-read-until ;
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-nl ;
-
-PROTOCOL: definition-protocol
-where set-where forget uses
-synopsis* definer definition ;
diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor
index f485f1bec1..0776f8f158 100644
--- a/basis/documents/elements/elements.factor
+++ b/basis/documents/elements/elements.factor
@@ -79,6 +79,13 @@ M: one-word-elt next-elt
drop
[ f next-word ] modify-col ;
+SINGLETON: word-start-elt
+
+M: word-start-elt prev-elt
+ drop one-word-elt prev-elt ;
+
+M: word-start-elt next-elt 2drop ;
+
SINGLETON: word-elt
M: word-elt prev-elt
diff --git a/basis/editors/editors-docs.factor b/basis/editors/editors-docs.factor
index 0f50e40eb4..30611ca699 100644
--- a/basis/editors/editors-docs.factor
+++ b/basis/editors/editors-docs.factor
@@ -1,4 +1,5 @@
-USING: help.markup help.syntax parser source-files vocabs.loader ;
+USING: help.markup help.syntax parser source-files
+source-files.errors vocabs.loader ;
IN: editors
ARTICLE: "editor" "Editor integration"
@@ -13,6 +14,9 @@ ARTICLE: "editor" "Editor integration"
ABOUT: "editor"
+HELP: edit-hook
+{ $var-description "A quotation with stack effect " { $snippet "( file line -- )" } ". If not set, the " { $link edit } " word throws a condition with restarts for loading one of the sub-vocabularies of the " { $vocab-link "editors" } " vocabulary." } ;
+
HELP: edit
{ $values { "defspec" "a definition specifier" } }
{ $description "Opens the source file containing the definition using the current " { $link edit-hook } ". See " { $link "editor" } "." }
@@ -22,7 +26,7 @@ HELP: edit
"A word's documentation:"
{ $code "\\ foo >link edit" }
"A method definition:"
- { $code "{ editor draw-gadget* } edit" }
+ { $code "M\\ fixnum + edit" }
"A help article:"
{ $code "\"handbook\" >link edit" }
} ;
diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor
index 0003b508fb..d5b4b909e3 100644
--- a/basis/editors/editors.factor
+++ b/basis/editors/editors.factor
@@ -2,9 +2,9 @@
! 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 assocs
-vocabs vocabs.loader splitting accessors debugger prettyprint
-help.topics ;
+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 ;
@@ -57,7 +57,7 @@ M: lexer-error error-line
[ error>> error-line ] [ line>> ] bi or ;
M: source-file-error error-file
- [ error>> error-file ] [ file>> path>> ] bi or ;
+ [ error>> error-file ] [ file>> ] bi or ;
M: source-file-error error-line
error>> error-line ;
@@ -81,6 +81,9 @@ M: object error-line
: :edit ( -- )
error get (:edit) ;
+: edit-error ( error -- )
+ [ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
+
: edit-each ( seq -- )
[
[ "Editing " write . ]
diff --git a/basis/editors/emacs/authors.txt b/basis/editors/emacs/authors.txt
index 6cfd5da273..07c1c4a765 100644
--- a/basis/editors/emacs/authors.txt
+++ b/basis/editors/emacs/authors.txt
@@ -1 +1,2 @@
Eduardo Cavazos
+Doug Coleman
diff --git a/basis/editors/emacs/emacs-docs.factor b/basis/editors/emacs/emacs-docs.factor
index f55068e143..adf6d8a7b7 100644
--- a/basis/editors/emacs/emacs-docs.factor
+++ b/basis/editors/emacs/emacs-docs.factor
@@ -2,10 +2,23 @@ USING: help help.syntax help.markup ;
IN: editors.emacs
ARTICLE: "editors.emacs" "Integration with Emacs"
-"Put this in your " { $snippet ".emacs" } " file:"
+"Full Emacs integration with Factor requires the use of two executable files -- " { $snippet "emacs" } " and " { $snippet "emacsclient" } ", which act as a client/server pair. To start the server, run the " { $snippet "emacs" } " binary and run " { $snippet "M-x server-start" } " or start " { $snippet "emacs" } " with the following line in your " { $snippet ".emacs" } " file:"
{ $code "(server-start)" }
+"On Windows, if you install Emacs to " { $snippet "Program Files" } " or " { $snippet "Program Files(x86)" } ", Factor will automatically detect the path to " { $snippet "emacsclient.exe" } ". On Unix systems, make sure that " { $snippet "emacsclient" } " is in your path. To set the path manually, use the following snippet:"
+{ $code "USE: edtiors.emacs"
+ "\"/my/crazy/bin/emacsclient\" emacsclient-path set-global"
+}
+
"If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:"
{ $code "(setq server-window 'switch-to-buffer-other-frame)" }
-{ $see-also "editor" } ;
-ABOUT: "editors.emacs"
\ No newline at end of file
+"To quickly scaffold a " { $snippet ".emacs" } " file, run the following code:"
+{ $code "USE: tools.scaffold"
+ "scaffold-emacs"
+}
+
+{ $see-also "editor" }
+
+;
+
+ABOUT: "editors.emacs"
diff --git a/basis/editors/emacs/emacs.factor b/basis/editors/emacs/emacs.factor
index 366bc53104..31fcaf114e 100644
--- a/basis/editors/emacs/emacs.factor
+++ b/basis/editors/emacs/emacs.factor
@@ -11,7 +11,10 @@ M: object default-emacsclient ( -- path ) "emacsclient" ;
: emacsclient ( file line -- )
[
- { [ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
+ {
+ [ emacsclient-path get-global ]
+ [ default-emacsclient dup emacsclient-path set-global ]
+ } 0|| ,
"--no-wait" ,
number>string "+" prepend ,
,
diff --git a/basis/editors/emacs/windows/authors.txt b/basis/editors/emacs/windows/authors.txt
index 7c1b2f2279..1901f27a24 100755
--- a/basis/editors/emacs/windows/authors.txt
+++ b/basis/editors/emacs/windows/authors.txt
@@ -1 +1 @@
-Doug Coleman
+Slava Pestov
diff --git a/basis/alien/strings/windows/tags.txt b/basis/editors/emacs/windows/tags.txt
similarity index 100%
rename from basis/alien/strings/windows/tags.txt
rename to basis/editors/emacs/windows/tags.txt
diff --git a/basis/images/normalization/authors.txt b/basis/editors/gedit/authors.txt
similarity index 100%
rename from basis/images/normalization/authors.txt
rename to basis/editors/gedit/authors.txt
diff --git a/basis/editors/gedit/gedit.factor b/basis/editors/gedit/gedit.factor
new file mode 100644
index 0000000000..97ea0e1cb3
--- /dev/null
+++ b/basis/editors/gedit/gedit.factor
@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: editors io.launcher kernel make math.parser namespaces
+sequences ;
+IN: editors.gedit
+
+: gedit-path ( -- path )
+ \ gedit-path get-global [
+ "gedit"
+ ] unless* ;
+
+: gedit ( file line -- )
+ [
+ gedit-path , number>string "+" prepend , ,
+ ] { } make run-detached drop ;
+
+[ gedit ] edit-hook set-global
diff --git a/basis/editors/gedit/summary.txt b/basis/editors/gedit/summary.txt
new file mode 100644
index 0000000000..ebb7189c9f
--- /dev/null
+++ b/basis/editors/gedit/summary.txt
@@ -0,0 +1 @@
+gedit integration
diff --git a/unmaintained/openal/macosx/tags.txt b/basis/editors/gedit/tags.txt
similarity index 100%
rename from unmaintained/openal/macosx/tags.txt
rename to basis/editors/gedit/tags.txt
diff --git a/basis/eval/eval-docs.factor b/basis/eval/eval-docs.factor
index b53c3bae6b..b30c6d9cb9 100644
--- a/basis/eval/eval-docs.factor
+++ b/basis/eval/eval-docs.factor
@@ -1,18 +1,23 @@
IN: eval
-USING: help.markup help.syntax strings io ;
+USING: help.markup help.syntax strings io effects ;
HELP: eval
-{ $values { "str" string } }
-{ $description "Parses Factor source code from a string, and calls the resulting quotation." }
+{ $values { "str" string } { "effect" effect } }
+{ $description "Parses Factor source code from a string, and calls the resulting quotation, which must have the given stack effect." }
+{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
+
+HELP: eval(
+{ $syntax "eval( inputs -- outputs )" }
+{ $description "Parses Factor source code from the string at the top of the stack, and calls the resulting quotation, which must have the given stack effect." }
{ $errors "Throws an error if the input is malformed, or if the evaluation itself throws an error." } ;
HELP: eval>string
{ $values { "str" string } { "output" string } }
-{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
+{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string. The code in the string must not take or leave any values on the stack." } ;
ARTICLE: "eval" "Evaluating strings at runtime"
"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
-{ $subsection eval }
+{ $subsection POSTPONE: eval( }
{ $subsection eval>string } ;
ABOUT: "eval"
diff --git a/basis/eval/eval-tests.factor b/basis/eval/eval-tests.factor
index 675921944a..d27e661193 100644
--- a/basis/eval/eval-tests.factor
+++ b/basis/eval/eval-tests.factor
@@ -1,4 +1,6 @@
IN: eval.tests
USING: eval tools.test ;
+[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
+[ "USE: math 2 2 +" eval( -- ) ] must-fail
[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test
diff --git a/basis/eval/eval.factor b/basis/eval/eval.factor
index 3672337a58..4c5b9e8cf9 100644
--- a/basis/eval/eval.factor
+++ b/basis/eval/eval.factor
@@ -1,23 +1,25 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: splitting parser compiler.units kernel namespaces
-debugger io.streams.string fry ;
+debugger io.streams.string fry combinators effects.parser ;
IN: eval
: parse-string ( str -- quot )
[ string-lines parse-lines ] with-compilation-unit ;
-: (eval) ( str -- )
- parse-string call ;
+: (eval) ( str effect -- )
+ [ parse-string ] dip call-effect ; inline
-: eval ( str -- )
- [ (eval) ] with-file-vocabs ;
+: eval ( str effect -- )
+ [ (eval) ] with-file-vocabs ; inline
+
+SYNTAX: eval( \ eval parse-call( ;
: (eval>string) ( str -- output )
[
"quiet" on
parser-notes off
- '[ _ (eval) ] try
+ '[ _ (( -- )) (eval) ] try
] with-string-writer ;
: eval>string ( str -- output )
diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor
index ac0b0850b4..5a517e4ac4 100644
--- a/basis/formatting/formatting.factor
+++ b/basis/formatting/formatting.factor
@@ -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 ] ;
-
-
diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor
index d240e6f233..88ecae66ad 100644
--- a/basis/fry/fry-tests.factor
+++ b/basis/fry/fry-tests.factor
@@ -56,7 +56,7 @@ sequences eval accessors ;
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
-[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ]
+[ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor
index 14877110d3..9d51ba259e 100644
--- a/basis/ftp/client/client.factor
+++ b/basis/ftp/client/client.factor
@@ -66,7 +66,7 @@ ERROR: ftp-error got expected ;
: list ( url -- ftp-response )
utf8 open-passive-client
ftp-list
- lines
+ stream-lines
<ftp-response> swap >>strings
read-response 226 ftp-assert
parse-list ;
diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor
index b4417532b4..03bd21e58c 100644
--- a/basis/functors/functors-tests.factor
+++ b/basis/functors/functors-tests.factor
@@ -43,8 +43,6 @@ WHERE
>>
-\ sqsq must-infer
-
[ 16 ] [ 2 sqsq ] unit-test
<<
@@ -65,7 +63,44 @@ WHERE
[ 4 ] [ 1 3 blah ] unit-test
-GENERIC: some-generic ( a -- b )
+<<
+
+FUNCTOR: symbol-test ( W -- )
+
+W DEFINES ${W}
+
+WHERE
+
+SYMBOL: W
+
+;FUNCTOR
+
+"blorgh" symbol-test
+
+>>
+
+[ blorgh ] [ blorgh ] unit-test
+
+<<
+
+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?
[ [ ] ] [
@@ -73,17 +108,21 @@ 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
] unit-test
: 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
] unit-test ;
+ [ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test
test-redefinition
@@ -91,13 +130,16 @@ 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
;FUNCTOR
@@ -107,4 +149,5 @@ M: W-tuple W-generic ;
"> <string-reader> "functors-test" parse-stream
] unit-test
-test-redefinition
\ No newline at end of file
+test-redefinition
+
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index 309154fb49..edd4932c66 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -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 ;
+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,10 @@ 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 ;
GENERIC: >fake-quotations ( quot -- fake )
@@ -29,17 +33,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ;
M: object >fake-quotations ;
-GENERIC: fake-quotations> ( fake -- quot )
+GENERIC: (fake-quotations>) ( fake -- )
-M: fake-quotation fake-quotations>
- seq>> [ fake-quotations> ] [ ] map-as ;
+: fake-quotations> ( fake -- quot )
+ [ (fake-quotations>) ] [ ] make ;
-M: array fake-quotations> [ fake-quotations> ] map ;
+M: fake-quotation (fake-quotations>)
+ [ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
-M: object fake-quotations> ;
+M: array (fake-quotations>)
+ [ [ (fake-quotations>) ] each ] { } make , ;
+
+M: fake-call-next-method (fake-quotations>)
+ drop method-body get literalize , \ (call-next-method) , ;
+
+M: object (fake-quotations>) , ;
: parse-definition* ( accum -- accum )
- parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
+ parse-definition >fake-quotations parsed
+ [ fake-quotations> first ] over push-all ;
: parse-declared* ( accum -- accum )
complete-effect
@@ -64,7 +76,7 @@ SYNTAX: `TUPLE:
SYNTAX: `M:
scan-param parsed
scan-param parsed
- \ create-method-in parsed
+ [ create-method-in dup method-body set ] over push-all
parse-definition*
\ define* parsed ;
@@ -80,6 +92,10 @@ SYNTAX: `:
parse-declared*
\ define-declared* parsed ;
+SYNTAX: `SYMBOL:
+ scan-param parsed
+ \ define-symbol parsed ;
+
SYNTAX: `SYNTAX:
scan-param parsed
parse-definition*
@@ -90,8 +106,15 @@ 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 ;
+
: (INTERPOLATE) ( accum quot -- accum )
[ scan interpolate-locals ] dip
'[ _ with-string-writer @ ] parsed ;
@@ -114,9 +137,12 @@ DEFER: ;FUNCTOR delimiter
{ "M:" POSTPONE: `M: }
{ "C:" POSTPONE: `C: }
{ ":" POSTPONE: `: }
+ { "GENERIC:" POSTPONE: `GENERIC: }
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
+ { "SYMBOL:" POSTPONE: `SYMBOL: }
{ "inline" POSTPONE: `inline }
+ { "call-next-method" POSTPONE: `call-next-method }
} ;
: push-functor-words ( -- )
diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor
index a582755dc4..c7893117d1 100644
--- a/basis/furnace/actions/actions.factor
+++ b/basis/furnace/actions/actions.factor
@@ -9,6 +9,7 @@ http.server.responses
furnace.utilities
furnace.redirection
furnace.conversations
+furnace.chloe-tags
html.forms
html.components
html.components
diff --git a/basis/furnace/auth/auth-tests.factor b/basis/furnace/auth/auth-tests.factor
index 220a8cd04c..54c32e7b4a 100644
--- a/basis/furnace/auth/auth-tests.factor
+++ b/basis/furnace/auth/auth-tests.factor
@@ -1,6 +1,3 @@
USING: furnace.auth tools.test ;
IN: furnace.auth.tests
-\ logged-in-username must-infer
-\ <protected> must-infer
-\ new-realm must-infer
diff --git a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor
index d0fdf22c27..996047e83d 100644
--- a/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor
+++ b/basis/furnace/auth/features/edit-profile/edit-profile-tests.factor
@@ -1,4 +1,4 @@
IN: furnace.auth.features.edit-profile.tests
USING: tools.test furnace.auth.features.edit-profile ;
-\ allow-edit-profile must-infer
+
diff --git a/basis/furnace/auth/features/recover-password/recover-password-tests.factor b/basis/furnace/auth/features/recover-password/recover-password-tests.factor
index b589c52624..313b8ef397 100644
--- a/basis/furnace/auth/features/recover-password/recover-password-tests.factor
+++ b/basis/furnace/auth/features/recover-password/recover-password-tests.factor
@@ -1,4 +1,4 @@
IN: furnace.auth.features.recover-password
USING: tools.test furnace.auth.features.recover-password ;
-\ allow-password-recovery must-infer
+
diff --git a/basis/furnace/auth/features/registration/registration-tests.factor b/basis/furnace/auth/features/registration/registration-tests.factor
index e770f35586..42acda416c 100644
--- a/basis/furnace/auth/features/registration/registration-tests.factor
+++ b/basis/furnace/auth/features/registration/registration-tests.factor
@@ -1,4 +1,4 @@
IN: furnace.auth.features.registration.tests
USING: tools.test furnace.auth.features.registration ;
-\ allow-registration must-infer
+
diff --git a/basis/furnace/auth/login/login-tests.factor b/basis/furnace/auth/login/login-tests.factor
index 64f7bd3b96..aabd0c5c30 100644
--- a/basis/furnace/auth/login/login-tests.factor
+++ b/basis/furnace/auth/login/login-tests.factor
@@ -1,4 +1,4 @@
IN: furnace.auth.login.tests
USING: tools.test furnace.auth.login ;
-\ <login-realm> must-infer
+
diff --git a/basis/furnace/cache/cache.factor b/basis/furnace/cache/cache.factor
index a5308c171e..fe2840c9eb 100644
--- a/basis/furnace/cache/cache.factor
+++ b/basis/furnace/cache/cache.factor
@@ -22,7 +22,7 @@ server-state f
: expire-state ( class -- )
new
- -1.0/0.0 millis [a,b] >>expires
+ -1/0. millis [a,b] >>expires
delete-tuples ;
TUPLE: server-state-manager < filter-responder timeout ;
diff --git a/basis/furnace/db/db-tests.factor b/basis/furnace/db/db-tests.factor
index 34357ae701..15698d8e9b 100644
--- a/basis/furnace/db/db-tests.factor
+++ b/basis/furnace/db/db-tests.factor
@@ -1,4 +1,4 @@
IN: furnace.db.tests
USING: tools.test furnace.db ;
-\ <db-persistence> must-infer
+
diff --git a/basis/furnace/furnace.factor b/basis/furnace/furnace.factor
index adafb21524..37b2f40e82 100644
--- a/basis/furnace/furnace.factor
+++ b/basis/furnace/furnace.factor
@@ -17,7 +17,6 @@ USE: vocabs.loader
"furnace.auth.providers.db" require
"furnace.auth.providers.null" require
"furnace.boilerplate" require
-"furnace.chloe-tags" require
"furnace.conversations" require
"furnace.db" require
"furnace.json" require
diff --git a/basis/furnace/redirection/redirection.factor b/basis/furnace/redirection/redirection.factor
index 01297288dc..ff81d73f7f 100644
--- a/basis/furnace/redirection/redirection.factor
+++ b/basis/furnace/redirection/redirection.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators namespaces fry urls http
-http.server http.server.redirection http.server.responses
+USING: kernel accessors combinators namespaces fry urls urls.secure
+http http.server http.server.redirection http.server.responses
http.server.remapping http.server.filters furnace.utilities ;
IN: furnace.redirection
diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor
index b325c778cf..99855c76fa 100644
--- a/basis/furnace/sessions/sessions-tests.factor
+++ b/basis/furnace/sessions/sessions-tests.factor
@@ -22,7 +22,7 @@ M: foo call-responder*
"x" [ 1+ ] schange
"x" sget number>string "text/html" <content> ;
-: url-responder-mock-test ( -- )
+: url-responder-mock-test ( -- string )
[
<request>
"GET" >>method
@@ -34,7 +34,7 @@ M: foo call-responder*
[ write-response-body drop ] with-string-writer
] with-destructors ;
-: sessions-mock-test ( -- )
+: sessions-mock-test ( -- string )
[
<request>
"GET" >>method
diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor
index 2088e468c6..3671511194 100644
--- a/basis/generalizations/generalizations-docs.factor
+++ b/basis/generalizations/generalizations-docs.factor
@@ -272,8 +272,8 @@ HELP: nweave
HELP: n*quot
{ $values
- { "n" integer } { "seq" sequence }
- { "seq'" sequence }
+ { "n" integer } { "quot" quotation }
+ { "quot'" quotation }
}
{ $examples
{ $example "USING: generalizations prettyprint math ;"
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index 0aa042d4f2..139b7a528a 100644
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -7,7 +7,7 @@ IN: generalizations
<<
-: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
+: n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
: repeat ( n obj quot -- ) swapd times ; inline
@@ -26,11 +26,14 @@ MACRO: narray ( n -- )
MACRO: nsum ( n -- )
1- [ + ] n*quot ;
+MACRO: firstn-unsafe ( n -- )
+ [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
+
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
- [ [ '[ [ _ ] dip nth-unsafe ] ] map ]
- [ 1- '[ [ _ ] dip bounds-check 2drop ] ]
- bi prefix '[ _ cleave ]
+ [ 1- swap bounds-check 2drop ]
+ [ firstn-unsafe ]
+ bi-curry '[ _ _ bi ]
] if ;
MACRO: npick ( n -- )
@@ -94,4 +97,4 @@ MACRO: nweave ( n -- )
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
-: nappend ( n -- seq ) narray concat ; inline
\ No newline at end of file
+: nappend ( n -- seq ) narray concat ; inline
diff --git a/basis/hash2/hash2-tests.factor b/basis/hash2/hash2-tests.factor
index 6f97c7c3d5..682680bc50 100644
--- a/basis/hash2/hash2-tests.factor
+++ b/basis/hash2/hash2-tests.factor
@@ -4,11 +4,11 @@ IN: hash2.tests
[ t ] [ 1 2 { 1 2 } 2= ] unit-test
[ f ] [ 1 3 { 1 2 } 2= ] unit-test
-: sample-hash ( -- )
+: sample-hash ( -- hash )
5 <hash2>
- dup 2 3 "foo" roll set-hash2
- dup 4 2 "bar" roll set-hash2
- dup 4 7 "other" roll set-hash2 ;
+ [ [ 2 3 "foo" ] dip set-hash2 ] keep
+ [ [ 4 2 "bar" ] dip set-hash2 ] keep
+ [ [ 4 7 "other" ] dip set-hash2 ] keep ;
[ "foo" ] [ 2 3 sample-hash hash2 ] unit-test
[ "bar" ] [ 4 2 sample-hash hash2 ] unit-test
diff --git a/basis/hash2/hash2.factor b/basis/hash2/hash2.factor
index ffe6926130..aadc0d45a2 100644
--- a/basis/hash2/hash2.factor
+++ b/basis/hash2/hash2.factor
@@ -1,4 +1,6 @@
-USING: kernel sequences arrays math vectors ;
+! Copyright (C) 2007 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences arrays math vectors locals ;
IN: hash2
! Little ad-hoc datastructure used to map two numbers
@@ -22,8 +24,8 @@ IN: hash2
: assoc2 ( a b alist -- value )
(assoc2) dup [ third ] when ; inline
-: set-assoc2 ( value a b alist -- alist )
- [ rot 3array ] dip ?push ; inline
+:: set-assoc2 ( value a b alist -- alist )
+ { a b value } alist ?push ; inline
: hash2@ ( a b hash2 -- a b bucket hash2 )
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
@@ -31,8 +33,8 @@ IN: hash2
: hash2 ( a b hash2 -- value/f )
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
-: set-hash2 ( a b value hash2 -- )
- [ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
+:: set-hash2 ( a b value hash2 -- )
+ value a b hash2 hash2@ [ set-assoc2 ] change-nth ;
: alist>hash2 ( alist size -- hash2 )
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline
diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor
index 7e780cbe5e..b476107562 100644
--- a/basis/heaps/heaps-tests.factor
+++ b/basis/heaps/heaps-tests.factor
@@ -54,7 +54,7 @@ IN: heaps.tests
: sort-entries ( entries -- entries' )
[ [ key>> ] compare ] sort ;
-: delete-test ( n -- ? )
+: delete-test ( n -- obj1 obj2 )
[
random-alist
<min-heap> [ heap-push-all ] keep
diff --git a/basis/help/apropos/apropos.factor b/basis/help/apropos/apropos.factor
index b241db4c0e..63cbcb3f1e 100644
--- a/basis/help/apropos/apropos.factor
+++ b/basis/help/apropos/apropos.factor
@@ -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
diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor
index 2cc19f87dd..59486a9c35 100644
--- a/basis/help/cookbook/cookbook.factor
+++ b/basis/help/cookbook/cookbook.factor
@@ -12,7 +12,7 @@ $nl
$nl
"Factor evaluates code left to right, and stores intermediate values on a " { $emphasis "stack" } ". If you think of the stack as a pile of papers, then " { $emphasis "pushing" } " a value on the stack corresponds to placing a piece of paper at the top of the pile, while " { $emphasis "popping" } " a value corresponds to removing the topmost piece."
$nl
-"All words except those which only push literals on the stack must have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effect-declaration" } "."
+"All words have a " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that a word takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effect declarations can be viewed by browsing source code, or using tools such as " { $link see } "; they are also checked by the compiler. See " { $link "effects" } "."
$nl
"Coming back to the example in the beginning of this article, the following series of steps occurs as the code is evaluated:"
{ $table
@@ -56,25 +56,16 @@ $nl
"5 0 - ! Computes 5-0"
"5 0 swap - ! Computes 0-5"
}
-"Also, in the above example a stack effect declaration is written between " { $snippet "(" } " and " { $snippet ")" } " with a mnemonic description of what the word does to the stack. See " { $link "effect-declaration" } " for details."
+"Also, in the above example a stack effect declaration is written between " { $snippet "(" } " and " { $snippet ")" } " with a mnemonic description of what the word does to the stack. See " { $link "effects" } " for details."
{ $curious
- "This syntax will be familiar to anybody who has used Forth before. However the behavior is slightly different. In most Forth systems, the below code prints 2, because the definition of " { $snippet "b" } " still refers to the previous definition of " { $snippet "a" } ":"
- { $code
- ": a 1 ;"
- ": b ( -- x ) a 1 + ;"
- ": a 2 ;"
- "b ."
- }
- "In Factor, this example will print 3 since word redefinition is explicitly supported."
- $nl
- "Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "."
+ "This syntax will be familiar to anybody who has used Forth before. However, unlike Forth, some additional static checks are performed. See " { $link "definition-checking" } " and " { $link "inference" } "."
}
{ $references
{ "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." }
"shuffle-words"
"words"
"generic"
- "tools"
+ "handbook-tools-reference"
} ;
ARTICLE: "cookbook-combinators" "Control flow cookbook"
@@ -117,7 +108,7 @@ $nl
}
{ $references
{ "Since quotations are objects, they can be constructed and taken apart at will. You can write code that writes code. Arrays are just one of the various types of sequences, and the sequence operations such as " { $link each } " and " { $link map } " operate on all types of sequences. There are many more sequence iteration operations than the ones above, too." }
- "dataflow"
+ "combinators"
"sequences"
} ;
@@ -175,53 +166,11 @@ $nl
"parser"
} ;
-ARTICLE: "cookbook-io" "Input and output cookbook"
-"Ask the user for their age, and print it back:"
-{ $code
- "USING: io math.parser ;"
- ": ask-age ( -- ) \"How old are you?\" print ;"
- ": read-age ( -- n ) readln string>number ;"
- ": print-age ( n -- )"
- " \"You are \" write"
- " number>string write"
- " \" years old.\" print ;"
- ": example ( -- ) ask-age read-age print-age ;"
- "example"
-}
-"Print the lines of a file in sorted order:"
-{ $code
- "USING: io io.encodings.utf8 io.files sequences sorting ;"
- "\"lines.txt\" utf8 file-lines natural-sort [ print ] each"
-}
-"Read 1024 bytes from a file:"
-{ $code
- "USING: io io.encodings.binary io.files ;"
- "\"data.bin\" binary [ 1024 read ] with-file-reader"
-}
-"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
-{ $code
- "USING: accessors grouping io.files io.mmap.char kernel sequences ;"
- "\"mydata.dat\" ["
- " 4 <sliced-groups> [ reverse-here ] change-each"
- "] with-mapped-char-file"
-}
-"Send some bytes to a remote host:"
-{ $code
- "USING: io io.encodings.ascii io.sockets strings ;"
- "\"myhost\" 1033 <inet> ascii"
- "[ B{ 12 17 102 } write ] with-client"
-}
-{ $references
- { }
- "number-strings"
- "io"
-} ;
-
ARTICLE: "cookbook-application" "Application cookbook"
"Vocabularies can define a main entry point:"
{ $code "IN: game-of-life"
"..."
-": play-life ... ;"
+": play-life ( -- ) ... ;"
""
"MAIN: play-life"
}
@@ -318,7 +267,6 @@ $nl
{ "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." }
{ "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." }
"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
- { "Learn to use the " { $link "inference" } " tool." }
{ "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
"Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution."
{ "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
@@ -332,6 +280,7 @@ $nl
"Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code."
$nl
"Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ;
+
ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
"Factor is a very clean and consistent language. However, it has some limitations and leaky abstractions you should keep in mind, as well as behaviors which differ from other languages you may be used to."
{ $list
@@ -341,13 +290,6 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
{ "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
- { "Performance-sensitive code should have a static stack effect so that it can be compiled by the optimizing word compiler, which generates more efficient code than the non-optimizing quotation compiler. See " { $link "inference" } " and " { $link "compiler" } "."
- $nl
- "This means that methods defined on performance sensitive, frequently-called core generic words such as " { $link nth } " should have static stack effects which are consistent with each other, since a generic word will only have a static stack effect if all methods do."
- $nl
- "Unit tests for the " { $vocab-link "stack-checker" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
- { $code "\"stack-checker\" test" }
- "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
@@ -372,7 +314,6 @@ ARTICLE: "cookbook" "Factor cookbook"
{ $subsection "cookbook-combinators" }
{ $subsection "cookbook-variables" }
{ $subsection "cookbook-vocabs" }
-{ $subsection "cookbook-io" }
{ $subsection "cookbook-application" }
{ $subsection "cookbook-scripts" }
{ $subsection "cookbook-philosophy" }
diff --git a/basis/help/crossref/crossref-docs.factor b/basis/help/crossref/crossref-docs.factor
index ae227fde89..7f243ec764 100644
--- a/basis/help/crossref/crossref-docs.factor
+++ b/basis/help/crossref/crossref-docs.factor
@@ -17,8 +17,3 @@ HELP: xref-article
{ $values { "topic" "an article name or a word" } }
{ $description "Sets the " { $link article-parent } " of each child of this article." }
$low-level-note ;
-
-HELP: unxref-article
-{ $values { "topic" "an article name or a word" } }
-{ $description "Clears the " { $link article-parent } " of each child of this article." }
-$low-level-note ;
diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor
index 2e01330d73..95d4612cbe 100644
--- a/basis/help/crossref/crossref-tests.factor
+++ b/basis/help/crossref/crossref-tests.factor
@@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
io.streams.string continuations debugger compiler.units eval ;
[ ] [
- "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval
+ "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
] unit-test
[ $subsection ] [
@@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
] unit-test
[ ] [
- "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval
+ "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- )
] unit-test
[ ] [
diff --git a/basis/help/crossref/crossref.factor b/basis/help/crossref/crossref.factor
index b791a4b124..46f9561605 100644
--- a/basis/help/crossref/crossref.factor
+++ b/basis/help/crossref/crossref.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs math fry
io kernel namespaces prettyprint prettyprint.sections
@@ -12,9 +12,6 @@ IN: help.crossref
: article-children ( topic -- seq )
{ $subsection } article-links ;
-M: link uses
- { $subsection $link $see-also } article-links ;
-
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
@@ -22,10 +19,7 @@ M: link uses
article-children [ set-article-parent ] with each ;
: xref-article ( topic -- )
- dup >link xref dup set-article-parents ;
-
-: unxref-article ( topic -- )
- >link unxref ;
+ dup set-article-parents ;
: prev/next ( obj seq n -- obj' )
[ [ index dup ] keep ] dip swap
diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor
index 7bb66eca02..c3365fe53f 100644
--- a/basis/help/definitions/definitions-tests.factor
+++ b/basis/help/definitions/definitions-tests.factor
@@ -32,7 +32,7 @@ IN: help.definitions.tests
"hello" "help.definitions.tests" lookup "help" word-prop
] unit-test
- [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test
+ [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval( -- ) ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor
index ed2a14a2f2..b83fb22ccf 100644
--- a/basis/help/handbook/handbook.factor
+++ b/basis/help/handbook/handbook.factor
@@ -5,7 +5,7 @@ math system strings sbufs vectors byte-arrays quotations
io.streams.byte-array classes.builtin parser lexer
classes.predicate classes.union classes.intersection
classes.singleton classes.tuple help.vocabs math.parser
-accessors ;
+accessors definitions sets ;
IN: help.handbook
ARTICLE: "conventions" "Conventions"
@@ -13,13 +13,13 @@ ARTICLE: "conventions" "Conventions"
{ $heading "Documentation conventions" }
"Factor documentation consists of two distinct bodies of text. There is a hierarchy of articles, much like this one, and there is word documentation. Help articles reference word documentation, and vice versa, but not every documented word is referenced from some help article."
$nl
-"Every article has links to parent articles at the top. These can be persued if the article is too specific."
+"Every article has links to parent articles at the top. Explore these if the article you are reading is too specific."
$nl
"Some generic words have " { $strong "Description" } " headings, and others have " { $strong "Contract" } " headings. A distinction is made between words which are not intended to be extended with user-defined methods, and those that are."
{ $heading "Vocabulary naming conventions" }
"A vocabulary name ending in " { $snippet ".private" } " contains words which are either implementation detail, unsafe, or both. For example, the " { $snippet "sequence.private" } " vocabulary contains words which access sequence elements without bounds checking (" { $link "sequences-unsafe" } ")."
$nl
-"You should should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
+"You should avoid using internal words from the Factor library unless absolutely necessary. Similarly, your own code can place words in internal vocabularies if you do not want other people to use them unless they have a good reason."
{ $heading "Word naming conventions" }
"These conventions are not hard and fast, but are usually a good first step in understanding a word's behavior:"
{ $table
@@ -39,7 +39,7 @@ $nl
{ { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } }
}
{ $heading "Stack effect conventions" }
-"Stack effect conventions are documented in " { $link "effect-declaration" } "."
+"Stack effect conventions are documented in " { $link "effects" } "."
{ $heading "Glossary of terms" }
"Common terminology and abbreviations used throughout Factor and its documentation:"
{ $table
@@ -49,13 +49,15 @@ $nl
{ "associative mapping" { "an object whose class implements the " { $link "assocs-protocol" } } }
{ "boolean" { { $link t } " or " { $link f } } }
{ "class" { "a set of objects identified by a " { $emphasis "class word" } " together with a discriminating predicate. See " { $link "classes" } } }
- { "definition specifier" { "a " { $link word } ", " { $link method-spec } ", " { $link link } ", vocabulary specifier, or any other object whose class implements the " { $link "definition-protocol" } } }
+ { "combinator" { "a word taking a quotation or another word as input; a higher-order function. See " { $link "combinators" } } }
+ { "definition specifier" { "an instance of " { $link definition } " which implements the " { $link "definition-protocol" } } }
{ "generalized boolean" { "an object interpreted as a boolean; a value of " { $link f } " denotes false and anything else denotes true" } }
{ "generic word" { "a word whose behavior depends can be specialized on the class of one of its inputs. See " { $link "generic" } } }
{ "method" { "a specialized behavior of a generic word on a class. See " { $link "generic" } } }
{ "object" { "any datum which can be identified" } }
{ "ordering specifier" { "see " { $link "order-specifiers" } } }
{ "pathname string" { "an OS-specific pathname which identifies a file" } }
+ { "quotation" { "an anonymous function; an instance of the " { $link quotation } " class. More generally, instances of the " { $link callable } " class can be used in many places documented to expect quotations" } }
{ "sequence" { "a sequence; see " { $link "sequence-protocol" } } }
{ "slot" { "a component of an object which can store a value" } }
{ "stack effect" { "a pictorial representation of a word's inputs and outputs, for example " { $snippet "+ ( x y -- z )" } ". See " { $link "effects" } } }
@@ -70,7 +72,7 @@ ARTICLE: "tail-call-opt" "Tail-call optimization"
$nl
"Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ;
-ARTICLE: "evaluator" "Evaluation semantics"
+ARTICLE: "evaluator" "Stack machine model"
{ $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:"
{ $list
{ "a " { $link word } " - the word's definition quotation is called. See " { $link "words" } }
@@ -84,12 +86,13 @@ ARTICLE: "objects" "Objects"
"An " { $emphasis "object" } " is any datum which may be identified. All values are objects in Factor. Each object carries type information, and types are checked at runtime; Factor is dynamically typed."
{ $subsection "equality" }
{ $subsection "math.order" }
-{ $subsection "destructors" }
{ $subsection "classes" }
{ $subsection "tuples" }
{ $subsection "generic" }
-{ $subsection "slots" }
-{ $subsection "mirrors" } ;
+"Advanced features:"
+{ $subsection "delegate" }
+{ $subsection "mirrors" }
+{ $subsection "slots" } ;
ARTICLE: "numbers" "Numbers"
{ $subsection "arithmetic" }
@@ -118,9 +121,9 @@ ARTICLE: "collections" "Collections"
"Fixed-length sequences:"
{ $subsection "arrays" }
{ $subsection "quotations" }
-"Fixed-length specialized sequences:"
{ $subsection "strings" }
{ $subsection "byte-arrays" }
+{ $subsection "specialized-arrays" }
"Resizable sequences:"
{ $subsection "vectors" }
{ $subsection "byte-vectors" }
@@ -128,7 +131,8 @@ ARTICLE: "collections" "Collections"
{ $subsection "growable" }
{ $heading "Associative mappings" }
{ $subsection "assocs" }
-{ $subsection "namespaces" }
+{ $subsection "linked-assocs" }
+{ $subsection "biassocs" }
{ $subsection "refs" }
"Implementations:"
{ $subsection "hashtables" }
@@ -140,26 +144,29 @@ ARTICLE: "collections" "Collections"
{ $subsection "dlists" }
{ $subsection "search-deques" }
{ $heading "Other collections" }
-{ $subsection "boxes" }
+{ $subsection "lists" }
+{ $subsection "disjoint-sets" }
+{ $subsection "interval-maps" }
{ $subsection "heaps" }
+{ $subsection "boxes" }
{ $subsection "graphs" }
{ $subsection "buffers" }
"There are also many other vocabularies tagged " { $link T{ vocab-tag { name "collections" } } } " in the library." ;
-USING: io.encodings.utf8 io.encodings.utf16 io.encodings.binary io.encodings.ascii io.files ;
+USING: io.encodings.utf8 io.encodings.binary io.files ;
ARTICLE: "encodings-introduction" "An introduction to encodings"
"In order to express text in terms of binary, some sort of encoding has to be used. In a modern context, this is understood as a two-way mapping between Unicode code points (characters) and some amount of binary. Since English isn't the only language in the world, ASCII is not sufficient as a mapping from binary to Unicode; it can't even express em-dashes or curly quotes. Unicode was designed as a universal character set that could potentially represent everything." $nl
"Not all encodings can represent all Unicode code points, but Unicode can represent basically everything that exists in modern encodings. Some encodings are language-specific, and some can represent everything in Unicode. Though the world is moving toward Unicode and UTF-8, the reality today is that there are several encodings which must be taken into account." $nl
-"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } ", " { $link ascii } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl
+"Factor uses a system of encoding descriptors to denote encodings. Encoding descriptors are objects which describe encodings. Examples are " { $link utf8 } " and " { $link binary } ". Encoding descriptors can be passed around independently. Each encoding descriptor has some method for constructing an encoded or decoded stream, and the resulting stream has an encoding descriptor stored which has methods for reading or writing characters." $nl
"Constructors for streams which deal with bytes usually take an encoding as an explicit parameter. For example, to open a text file for reading whose contents are in UTF-8, use the following"
{ $code "\"file.txt\" utf8 <file-reader>" }
"If there is an error in the encoded stream, a replacement character (0xFFFD) will be inserted. To throw an exception upon error, use a strict encoding as follows"
{ $code "\"file.txt\" utf8 strict <file-reader>" }
"In a similar way, encodings can be specified when opening a file for writing."
-{ $code "\"file.txt\" ascii <file-writer>" }
+{ $code "USE: io.encodings.ascii" "\"file.txt\" ascii <file-writer>" }
"An encoding is also needed for some words that don't return streams, such as " { $link file-contents } ", for example"
-{ $code "\"file.txt\" utf16 file-contents" }
+{ $code "USE: io.encodings.utf16" "\"file.txt\" utf16 file-contents" }
"Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text."
$nl
"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ;
@@ -190,29 +197,6 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.ports" }
{ $see-also "destructors" } ;
-ARTICLE: "tools" "Developer tools"
-{ $subsection "tools.vocabs" }
-"Exploratory tools:"
-{ $subsection "see" }
-{ $subsection "editor" }
-{ $subsection "listener" }
-{ $subsection "tools.crossref" }
-{ $subsection "inspector" }
-{ $subsection "tools.completion" }
-{ $subsection "summary" }
-"Debugging tools:"
-{ $subsection "tools.annotations" }
-{ $subsection "tools.test" }
-{ $subsection "tools.threads" }
-"Performance tools:"
-{ $subsection "tools.memory" }
-{ $subsection "profiling" }
-{ $subsection "timing" }
-{ $subsection "tools.disassembler" }
-"Deployment tools:"
-{ $subsection "tools.deploy" }
-{ $see-also "ui-tools" } ;
-
ARTICLE: "article-index" "Article index"
{ $index [ articles get keys ] } ;
@@ -239,52 +223,101 @@ ARTICLE: "class-index" "Class index"
{ $heading "Predicate classes" }
{ $index [ classes [ predicate-class? ] filter ] } ;
-ARTICLE: "program-org" "Program organization"
-{ $subsection "definitions" }
-{ $subsection "vocabularies" }
-{ $subsection "parser" }
-{ $subsection "vocabs.loader" }
-{ $subsection "source-files" } ;
-
USING: help.cookbook help.tutorial ;
-ARTICLE: "handbook-language-reference" "Language reference"
+ARTICLE: "handbook-language-reference" "The language"
+{ $heading "Fundamentals" }
{ $subsection "conventions" }
{ $subsection "syntax" }
-{ $subsection "dataflow" }
-{ $subsection "objects" }
-{ $subsection "program-org" }
+{ $heading "The stack" }
+{ $subsection "evaluator" }
+{ $subsection "effects" }
+{ $subsection "inference" }
+{ $heading "Basic data types" }
+{ $subsection "booleans" }
{ $subsection "numbers" }
{ $subsection "collections" }
-{ $subsection "io" }
+{ $heading "Evaluation" }
+{ $subsection "words" }
+{ $subsection "shuffle-words" }
+{ $subsection "combinators" }
+{ $subsection "threads" }
+{ $heading "Named values" }
+{ $subsection "locals" }
+{ $subsection "namespaces" }
+{ $subsection "namespaces-global" }
+{ $subsection "values" }
+{ $heading "Abstractions" }
+{ $subsection "errors" }
+{ $subsection "objects" }
+{ $subsection "destructors" }
+{ $subsection "continuations" }
+{ $subsection "memoize" }
+{ $subsection "parsing-words" }
+{ $subsection "macros" }
+{ $subsection "fry" }
+{ $heading "Program organization" }
+{ $subsection "vocabs.loader" }
"Vocabularies tagged " { $link T{ vocab-tag { name "extensions" } } } " implement various additional language abstractions." ;
-ARTICLE: "handbook-environment-reference" "Environment reference"
-{ $subsection "prettyprint" }
-{ $subsection "tools" }
+ARTICLE: "handbook-system-reference" "The implementation"
+{ $heading "Parse time and compile time" }
+{ $subsection "parser" }
+{ $subsection "definitions" }
+{ $subsection "vocabularies" }
+{ $subsection "source-files" }
+{ $subsection "compiler" }
+{ $subsection "tools.errors" }
+{ $heading "Virtual machine" }
+{ $subsection "images" }
{ $subsection "cli" }
{ $subsection "rc-files" }
-{ $subsection "help" }
-{ $subsection "inference" }
-{ $subsection "compiler" }
-{ $subsection "system" }
-{ $subsection "images" }
-{ $subsection "alien" }
{ $subsection "init" }
-{ $subsection "layouts" }
-{ $see-also "program-org" } ;
+{ $subsection "system" }
+{ $subsection "layouts" } ;
-ARTICLE: "handbook-library-reference" "Library reference"
-"This index only includes articles from loaded vocabularies. To explore more vocabularies, see " { $link "vocab-index" } "."
-{ $index [ "handbook" orphan-articles remove ] } ;
+ARTICLE: "handbook-tools-reference" "Developer tools"
+"The below tools are text-based. " { $link "ui-tools" } " are documented separately."
+{ $heading "Workflow" }
+{ $subsection "listener" }
+{ $subsection "editor" }
+{ $subsection "vocabs.refresh" }
+{ $subsection "tools.test" }
+{ $subsection "help" }
+{ $heading "Debugging" }
+{ $subsection "prettyprint" }
+{ $subsection "inspector" }
+{ $subsection "tools.annotations" }
+{ $subsection "tools.inference" }
+{ $heading "Browsing" }
+{ $subsection "see" }
+{ $subsection "tools.crossref" }
+{ $subsection "vocabs.hierarchy" }
+{ $heading "Performance" }
+{ $subsection "timing" }
+{ $subsection "profiling" }
+{ $subsection "tools.memory" }
+{ $subsection "tools.threads" }
+{ $subsection "tools.disassembler" }
+{ $heading "Deployment" }
+{ $subsection "tools.deploy" } ;
+
+ARTICLE: "handbook-library-reference" "Libraries"
+"This index lists articles from loaded vocabularies which are not subsections of any other article. To explore more vocabularies, see " { $link "vocab-index" } "."
+{ $index [ orphan-articles { "help.home" "handbook" } diff ] } ;
ARTICLE: "handbook" "Factor handbook"
"Learn the language:"
{ $subsection "cookbook" }
{ $subsection "first-program" }
+"Reference material:"
{ $subsection "handbook-language-reference" }
-{ $subsection "handbook-environment-reference" }
+{ $subsection "io" }
{ $subsection "ui" }
+{ $subsection "handbook-system-reference" }
+{ $subsection "handbook-tools-reference" }
+{ $subsection "ui-tools" }
+{ $subsection "alien" }
{ $subsection "handbook-library-reference" }
"Explore loaded libraries:"
{ $subsection "article-index" }
diff --git a/basis/help/help.factor b/basis/help/help.factor
index d20e06b6c6..6e09e298f4 100644
--- a/basis/help/help.factor
+++ b/basis/help/help.factor
@@ -54,7 +54,7 @@ M: word article-title
dup [ parsing-word? ] [ symbol? ] bi or [
name>>
] [
- [ name>> ]
+ [ unparse ]
[ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
append
] if ;
@@ -156,10 +156,7 @@ help-hook [ [ print-topic ] ] initialize
error get (:help) ;
: remove-article ( name -- )
- dup articles get key? [
- dup unxref-article
- dup articles get delete-at
- ] when drop ;
+ articles get delete-at ;
: add-article ( article name -- )
[ remove-article ] keep
@@ -167,7 +164,6 @@ help-hook [ [ print-topic ] ] initialize
xref-article ;
: remove-word-help ( word -- )
- dup word-help [ dup unxref-article ] when
f "help" set-word-prop ;
: set-word-help ( content word -- )
diff --git a/basis/help/home/home-docs.factor b/basis/help/home/home-docs.factor
index 6608a6e9c0..b40d162670 100644
--- a/basis/help/home/home-docs.factor
+++ b/basis/help/home/home-docs.factor
@@ -8,7 +8,7 @@ ARTICLE: "help.home" "Factor documentation"
{ $link "handbook" }
{ $link "vocab-index" }
{ $link "ui-tools" }
- { $link "handbook-library-reference" }
+ { $link "ui-listener" }
}
{ $heading "Recently visited" }
{ $table
diff --git a/basis/help/home/home.factor b/basis/help/home/home.factor
index f32c0db30d..9cb3c6f1bb 100644
--- a/basis/help/home/home.factor
+++ b/basis/help/home/home.factor
@@ -21,7 +21,7 @@ M: apropos add-recent-where recent-searches ;
M: object add-recent-where f ;
: $recent ( element -- )
- first get [ nl ] [ 1array $pretty-link ] interleave ;
+ first get reverse [ nl ] [ 1array $pretty-link ] interleave ;
: $recent-searches ( element -- )
drop recent-searches get [ <$link> ] map $list ;
diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
index d880af5b55..348fcbbbfb 100644
--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@@ -3,25 +3,27 @@
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.loader serialize fry memoize unicode.case math.order
-sorting debugger html xml.syntax xml.writer ;
+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
: escape-char ( ch -- )
- dup H{
- { CHAR: " "__quo__" }
- { CHAR: * "__star__" }
- { CHAR: : "__colon__" }
- { CHAR: < "__lt__" }
- { CHAR: > "__gt__" }
- { CHAR: ? "__que__" }
- { CHAR: \\ "__back__" }
- { CHAR: | "__pipe__" }
- { CHAR: / "__slash__" }
- { CHAR: , "__comma__" }
- { CHAR: @ "__at__" }
- } at [ % ] [ , ] ?if ;
+ dup ascii? [
+ dup H{
+ { CHAR: " "__quo__" }
+ { CHAR: * "__star__" }
+ { CHAR: : "__colon__" }
+ { CHAR: < "__lt__" }
+ { CHAR: > "__gt__" }
+ { CHAR: ? "__que__" }
+ { CHAR: \\ "__back__" }
+ { CHAR: | "__pipe__" }
+ { CHAR: / "__slash__" }
+ { CHAR: , "__comma__" }
+ { CHAR: @ "__at__" }
+ } at [ % ] [ , ] ?if
+ ] [ number>string "__" "__" surround % ] if ;
: escape-filename ( string -- filename )
[ [ escape-char ] each ] "" make ;
diff --git a/basis/help/lint/checks/authors.txt b/basis/help/lint/checks/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/help/lint/checks/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/help/lint/checks/checks.factor b/basis/help/lint/checks/checks.factor
new file mode 100644
index 0000000000..4a15f864a6
--- /dev/null
+++ b/basis/help/lint/checks/checks.factor
@@ -0,0 +1,176 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes combinators
+combinators.short-circuit definitions effects eval fry grouping
+help help.markup help.topics io.streams.string kernel macros
+namespaces sequences sequences.deep sets sorting splitting
+strings unicode.categories values vocabs vocabs.loader words
+words.symbol summary debugger io ;
+IN: help.lint.checks
+
+ERROR: simple-lint-error message ;
+
+M: simple-lint-error summary message>> ;
+
+M: simple-lint-error error. summary print ;
+
+SYMBOL: vocabs-quot
+SYMBOL: all-vocabs
+SYMBOL: vocab-articles
+
+: check-example ( element -- )
+ '[
+ _ rest [
+ but-last "\n" join
+ [ (eval>string) ] call( code -- output )
+ "\n" ?tail drop
+ ] keep
+ peek assert=
+ ] vocabs-quot get call( quot -- ) ;
+
+: check-examples ( element -- )
+ \ $example swap elements [ check-example ] each ;
+
+: extract-values ( element -- seq )
+ \ $values swap elements dup empty? [
+ first rest [ first ] map prune natural-sort
+ ] unless ;
+
+: effect-values ( word -- seq )
+ stack-effect
+ [ in>> ] [ out>> ] bi append
+ [ dup pair? [ first ] when effect>string ] map
+ prune natural-sort ;
+
+: contains-funky-elements? ( element -- ? )
+ {
+ $shuffle
+ $values-x/y
+ $predicate
+ $class-description
+ $error-description
+ } swap '[ _ elements empty? not ] any? ;
+
+: don't-check-word? ( word -- ? )
+ {
+ [ macro? ]
+ [ symbol? ]
+ [ value-word? ]
+ [ parsing-word? ]
+ [ "declared-effect" word-prop not ]
+ } 1|| ;
+
+: check-values ( word element -- )
+ {
+ [
+ [ don't-check-word? ]
+ [ contains-funky-elements? ]
+ bi* or
+ ] [
+ [ effect-values ]
+ [ extract-values ]
+ bi* sequence=
+ ]
+ } 2|| [ "$values don't match stack effect" simple-lint-error ] unless ;
+
+: check-nulls ( element -- )
+ \ $values swap elements
+ null swap deep-member?
+ [ "$values should not contain null" simple-lint-error ] when ;
+
+: check-see-also ( element -- )
+ \ $see-also swap elements [
+ rest dup prune [ length ] bi@ assert=
+ ] each ;
+
+: vocab-exists? ( name -- ? )
+ [ vocab ] [ all-vocabs get member? ] bi or ;
+
+: check-modules ( element -- )
+ \ $vocab-link swap elements [
+ second
+ vocab-exists? [
+ "$vocab-link to non-existent vocabulary"
+ simple-lint-error
+ ] unless
+ ] each ;
+
+: check-rendering ( element -- )
+ [ print-content ] with-string-writer drop ;
+
+: check-strings ( str -- )
+ [
+ "\n\t" intersects? [
+ "Paragraph text should not contain \\n or \\t"
+ simple-lint-error
+ ] when
+ ] [
+ " " swap subseq? [
+ "Paragraph text should not contain double spaces"
+ simple-lint-error
+ ] when
+ ] bi ;
+
+: check-whitespace ( str1 str2 -- )
+ [ " " tail? ] [ " " head? ] bi* or
+ [ "Missing whitespace between strings" simple-lint-error ] unless ;
+
+: check-bogus-nl ( element -- )
+ { { $nl } { { $nl } } } [ head? ] with any? [
+ "Simple element should not begin with a paragraph break"
+ simple-lint-error
+ ] when ;
+
+: check-class-description ( word element -- )
+ [ class? not ]
+ [ { $class-description } swap elements empty? not ] bi* and
+ [ "A word that is not a class has a $class-description" simple-lint-error ] when ;
+
+: check-article-title ( article -- )
+ article-title first LETTER?
+ [ "Article title must begin with a capital letter" simple-lint-error ] unless ;
+
+: check-elements ( element -- )
+ {
+ [ check-bogus-nl ]
+ [ [ string? ] filter [ check-strings ] each ]
+ [ [ simple-element? ] filter [ check-elements ] each ]
+ [ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
+ } cleave ;
+
+: check-descriptions ( element -- )
+ { $description $class-description $var-description }
+ swap '[
+ _ elements [
+ rest { { } { "" } } member?
+ [ "Empty description" throw ] when
+ ] each
+ ] each ;
+
+: check-markup ( element -- )
+ {
+ [ check-elements ]
+ [ check-rendering ]
+ [ check-examples ]
+ [ check-modules ]
+ [ check-descriptions ]
+ } cleave ;
+
+: files>vocabs ( -- assoc )
+ vocabs
+ [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
+ [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
+ bi assoc-union ;
+
+: group-articles ( -- assoc )
+ articles get keys
+ files>vocabs
+ H{ } clone [
+ '[
+ dup >link where dup
+ [ first _ at _ push-at ] [ 2drop ] if
+ ] each
+ ] keep ;
+
+: all-word-help ( words -- seq )
+ [ word-help ] filter ;
diff --git a/basis/help/lint/lint-docs.factor b/basis/help/lint/lint-docs.factor
index 0c0fcf92d2..ed74748356 100644
--- a/basis/help/lint/lint-docs.factor
+++ b/basis/help/lint/lint-docs.factor
@@ -14,6 +14,10 @@ $nl
"To run help lint, use one of the following two words:"
{ $subsection help-lint }
{ $subsection help-lint-all }
+"Once a help lint run completes, failures can be listed:"
+{ $subsection :lint-failures }
+"Help lint failures are also shown in the " { $link "ui.tools.error-list" } "."
+$nl
"Help lint performs the following checks:"
{ $list
"ensures examples run and produce stated output"
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 7ec8c59ba6..f25d5f0f93 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -1,161 +1,53 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors sequences parser kernel help help.markup
-help.topics words strings classes tools.vocabs namespaces make
-io io.streams.string prettyprint definitions arrays vectors
-combinators combinators.short-circuit splitting debugger
-hashtables sorting effects vocabs vocabs.loader assocs editors
-continuations classes.predicate macros math sets eval
-vocabs.parser words.symbol values grouping unicode.categories
-sequences.deep ;
+USING: assocs continuations fry help help.lint.checks
+help.topics io kernel namespaces parser sequences
+source-files.errors vocabs.hierarchy vocabs words classes
+locals tools.errors ;
+FROM: help.lint.checks => all-vocabs ;
IN: help.lint
-SYMBOL: vocabs-quot
+SYMBOL: lint-failures
-: check-example ( element -- )
- '[
- _ rest [
- but-last "\n" join
- [ (eval>string) ] call( code -- output )
- "\n" ?tail drop
- ] keep
- peek assert=
- ] vocabs-quot get call( quot -- ) ;
+lint-failures [ H{ } clone ] initialize
-: check-examples ( element -- )
- \ $example swap elements [ check-example ] each ;
+TUPLE: help-lint-error < source-file-error ;
-: extract-values ( element -- seq )
- \ $values swap elements dup empty? [
- first rest [ first ] map prune natural-sort
- ] unless ;
+SYMBOL: +help-lint-failure+
-: effect-values ( word -- seq )
- stack-effect
- [ in>> ] [ out>> ] bi append
- [ dup pair? [ first ] when effect>string ] map
- prune natural-sort ;
+T{ error-type
+ { type +help-lint-failure+ }
+ { word ":lint-failures" }
+ { plural "help lint failures" }
+ { icon "vocab:ui/tools/error-list/icons/help-lint-error.tiff" }
+ { quot [ lint-failures get values ] }
+ { forget-quot [ lint-failures get delete-at ] }
+} define-error-type
-: contains-funky-elements? ( element -- ? )
- {
- $shuffle
- $values-x/y
- $predicate
- $class-description
- $error-description
- } swap '[ _ elements empty? not ] any? ;
+M: help-lint-error error-type drop +help-lint-failure+ ;
-: don't-check-word? ( word -- ? )
- {
- [ macro? ]
- [ symbol? ]
- [ value-word? ]
- [ parsing-word? ]
- [ "declared-effect" word-prop not ]
- } 1|| ;
+<PRIVATE
-: check-values ( word element -- )
- {
- [
- [ don't-check-word? ]
- [ contains-funky-elements? ]
- bi* or
- ] [
- [ effect-values ]
- [ extract-values ]
- bi* sequence=
- ]
- } 2|| [ "$values don't match stack effect" throw ] unless ;
+: <help-lint-error> ( error topic -- help-lint-error )
+ \ help-lint-error <definition-error> ;
-: check-nulls ( element -- )
- \ $values swap elements
- null swap deep-member?
- [ "$values should not contain null" throw ] when ;
+PRIVATE>
-: check-see-also ( element -- )
- \ $see-also swap elements [
- rest dup prune [ length ] bi@ assert=
- ] each ;
+: help-lint-error ( error topic -- )
+ lint-failures get pick
+ [ [ [ <help-lint-error> ] keep ] dip set-at ] [ delete-at drop ] if
+ notify-error-observers ;
-: vocab-exists? ( name -- ? )
- [ vocab ] [ "all-vocabs" get member? ] bi or ;
+<PRIVATE
-: check-modules ( element -- )
- \ $vocab-link swap elements [
- second
- vocab-exists? [ "$vocab-link to non-existent vocabulary" throw ] unless
- ] each ;
-
-: check-rendering ( element -- )
- [ print-content ] with-string-writer drop ;
-
-: check-strings ( str -- )
- [
- "\n\t" intersects?
- [ "Paragraph text should not contain \\n or \\t" throw ] when
- ] [
- " " swap subseq?
- [ "Paragraph text should not contain double spaces" throw ] when
- ] bi ;
-
-: check-whitespace ( str1 str2 -- )
- [ " " tail? ] [ " " head? ] bi* or
- [ "Missing whitespace between strings" throw ] unless ;
-
-: check-bogus-nl ( element -- )
- { { $nl } { { $nl } } } [ head? ] with any?
- [ "Simple element should not begin with a paragraph break" throw ] when ;
-
-: check-elements ( element -- )
- {
- [ check-bogus-nl ]
- [ [ string? ] filter [ check-strings ] each ]
- [ [ simple-element? ] filter [ check-elements ] each ]
- [ 2 <clumps> [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
- } cleave ;
-
-: check-descriptions ( element -- )
- { $description $class-description $var-description }
- swap '[
- _ elements [
- rest { { } { "" } } member?
- [ "Empty description" throw ] when
- ] each
- ] each ;
-
-: check-markup ( element -- )
- {
- [ check-elements ]
- [ check-rendering ]
- [ check-examples ]
- [ check-modules ]
- [ check-descriptions ]
- } cleave ;
-
-: check-class-description ( word element -- )
- [ class? not ]
- [ { $class-description } swap elements empty? not ] bi* and
- [ "A word that is not a class has a $class-description" throw ] when ;
-
-: all-word-help ( words -- seq )
- [ word-help ] filter ;
-
-TUPLE: help-error error topic ;
-
-C: <help-error> help-error
-
-M: help-error error.
- [ "In " write topic>> pprint nl ]
- [ error>> error. ]
- bi ;
-
-: check-something ( obj quot -- )
- flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
+:: check-something ( topic quot -- )
+ [ quot call( -- ) f ] [ ] recover
+ topic help-lint-error ; inline
: check-word ( word -- )
[ with-file-vocabs ] vocabs-quot set
dup word-help [
- dup '[
+ [ >link ] keep '[
_ dup word-help
[ check-values ]
[ check-class-description ]
@@ -165,69 +57,38 @@ M: help-error error.
: check-words ( words -- ) [ check-word ] each ;
-: check-article-title ( article -- )
- article-title first LETTER?
- [ "Article title must begin with a capital letter" throw ] unless ;
-
: check-article ( article -- )
[ with-interactive-vocabs ] vocabs-quot set
- dup '[
+ >link dup '[
_
[ check-article-title ]
[ article-content check-markup ] bi
] check-something ;
-: files>vocabs ( -- assoc )
- vocabs
- [ [ [ vocab-docs-path ] keep ] H{ } map>assoc ]
- [ [ [ vocab-source-path ] keep ] H{ } map>assoc ]
- bi assoc-union ;
-
-: group-articles ( -- assoc )
- articles get keys
- files>vocabs
- H{ } clone [
- '[
- dup >link where dup
- [ first _ at _ push-at ] [ 2drop ] if
- ] each
- ] keep ;
-
: check-about ( vocab -- )
dup '[ _ vocab-help [ article drop ] when* ] check-something ;
-: check-vocab ( vocab -- seq )
+: check-vocab ( vocab -- )
"Checking " write dup write "..." print
- [
- [ check-about ]
- [ words [ check-word ] each ]
- [ "vocab-articles" get at [ check-article ] each ]
- tri
- ] { } make ;
+ [ vocab check-about ]
+ [ words [ check-word ] each ]
+ [ vocab-articles get at [ check-article ] each ]
+ tri ;
-: run-help-lint ( prefix -- alist )
+PRIVATE>
+
+: help-lint ( prefix -- )
[
- all-vocabs-seq [ vocab-name ] map "all-vocabs" set
- group-articles "vocab-articles" set
+ all-vocabs-seq [ vocab-name ] map all-vocabs set
+ group-articles vocab-articles set
child-vocabs
- [ dup check-vocab ] { } map>assoc
- [ nip empty? not ] assoc-filter
+ [ check-vocab ] each
] with-scope ;
-: typos. ( assoc -- )
- [
- "==== ALL CHECKS PASSED" print
- ] [
- [
- swap vocab-heading.
- [ print-error nl ] each
- ] assoc-each
- ] if-empty ;
-
-: help-lint ( prefix -- ) run-help-lint typos. ;
-
: help-lint-all ( -- ) "" help-lint ;
+: :lint-failures ( -- ) lint-failures get errors. ;
+
: unlinked-words ( words -- seq )
all-word-help [ article-parent not ] filter ;
@@ -235,6 +96,6 @@ M: help-error error.
all-words
[ word-help not ] filter
[ article-parent ] filter
- [ "predicating" word-prop not ] filter ;
+ [ predicate? not ] filter ;
MAIN: help-lint
diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor
index 9b928f3691..93bed37a55 100644
--- a/basis/help/markup/markup-tests.factor
+++ b/basis/help/markup/markup-tests.factor
@@ -5,7 +5,7 @@ IN: help.markup.tests
TUPLE: blahblah quux ;
-[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
+[ "int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ quux>> print-topic ] unit-test
[ ] [ \ >>quux print-topic ] unit-test
@@ -26,5 +26,3 @@ TUPLE: blahblah quux ;
[ "a string, a fixnum, or an integer" ]
[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test
-\ print-element must-infer
-\ print-topic must-infer
\ No newline at end of file
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index 8b5edf38c1..04b6d90883 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -138,7 +138,7 @@ ALIAS: $slot $snippet
! Images
: $image ( element -- )
- [ [ "" ] dip first image associate format ] ($span) ;
+ [ first write-image ] ($span) ;
: <$image> ( path -- element )
1array \ $image prefix ;
@@ -251,7 +251,7 @@ M: word ($instance)
dup name>> a/an write bl ($link) ;
M: string ($instance)
- dup a/an write bl $snippet ;
+ write ;
M: f ($instance)
drop { f } $link ;
diff --git a/basis/help/syntax/syntax-tests.factor b/basis/help/syntax/syntax-tests.factor
index e7438edd4d..7618e9cdeb 100644
--- a/basis/help/syntax/syntax-tests.factor
+++ b/basis/help/syntax/syntax-tests.factor
@@ -4,12 +4,12 @@ IN: help.syntax.tests
[
[ "foobar" ] [
- "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval
+ "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval( -- )
"help.syntax.tests" vocab vocab-help
] unit-test
[ { "foobar" } ] [
- "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval
+ "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval( -- )
"help.syntax.tests" vocab vocab-help
] unit-test
diff --git a/basis/help/syntax/tags.txt b/basis/help/syntax/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/basis/help/syntax/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor
index f53bdee9c7..cafeb009a4 100644
--- a/basis/help/topics/topics-tests.factor
+++ b/basis/help/topics/topics-tests.factor
@@ -3,11 +3,6 @@ help.markup help.syntax kernel sequences tools.test words parser
namespaces assocs source-files eval ;
IN: help.topics.tests
-\ article-name must-infer
-\ article-title must-infer
-\ article-content must-infer
-\ article-parent must-infer
-
! Test help cross-referencing
[ ] [ "Test B" { "Hello world." } <article> { "test" "b" } add-article ] unit-test
@@ -29,7 +24,7 @@ SYMBOL: foo
} "\n" join
[
"testfile" source-file file set
- eval
+ eval( -- )
] with-scope
] unit-test
diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor
index 26812947c0..7686022b70 100644
--- a/basis/help/tutorial/tutorial.factor
+++ b/basis/help/tutorial/tutorial.factor
@@ -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
@@ -76,9 +76,11 @@ $nl
{ $code "." }
"What we just did is called " { $emphasis "interactive testing" } ". A more advanced technique which comes into play with larger programs is " { $link "tools.test" } "."
$nl
-"Open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
+"Create a test harness file using the scaffold tool:"
+{ $code "\"palindrome\" scaffold-tests" }
+"Now, open the file named " { $snippet "palindrome-tests.factor" } "; it is located in the same directory as " { $snippet "palindrome.factor" } ", and it was created by the scaffold tool."
$nl
-"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
+"We will add some unit tests, which are similar to the interactive tests we did above. Unit tests are defined with the " { $link POSTPONE: unit-test } " word, which takes a sequence of expected outputs, and a piece of code. It runs the code, and asserts that it outputs the expected values."
$nl
"Add the following three lines to " { $snippet "palindrome-tests.factor" } ":"
{ $code
diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor
index a8c93feee4..b23143e572 100644
--- a/basis/help/vocabs/vocabs.factor
+++ b/basis/help/vocabs/vocabs.factor
@@ -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 -- )
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 804ef035f4..db04033275 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -1,10 +1,10 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
-byte-arrays byte-vectors io.binary io.streams.string splitting
-math generic generic.standard generic.standard.engines classes
-hashtables ;
+byte-arrays byte-vectors io.binary io.streams.string splitting math
+math.parser generic generic.single generic.standard classes
+hashtables namespaces ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
@@ -25,7 +25,7 @@ M: object specializer-declaration class ;
[ drop object eq? not ] assoc-filter
[ [ t ] ] [
[ swap specializer-predicate append ] { } assoc>map
- unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ [ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
] if-empty ;
: specializer-cases ( quot word -- default alist )
@@ -37,13 +37,18 @@ M: object specializer-declaration class ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
+! compiler.tree.propagation.inlining sets this to f
+SYMBOL: specialize-method?
+
+t specialize-method? set-global
+
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
- bi prefix ;
+ bi prefix [ declare ] curry [ ] like ;
: specialize-method ( quot method -- quot' )
- [ method-declaration '[ _ declare ] prepend ]
+ [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
[ "method-generic" word-prop "specializer" word-prop ] bi
[ specialize-quot ] when* ;
@@ -65,9 +70,8 @@ M: object specializer-declaration class ;
SYNTAX: HINTS:
scan-object
- dup method-spec? [ first2 method ] when
- [ redefined ]
- [ parse-definition "specializer" set-word-prop ] bi ;
+ [ changed-definition ]
+ [ parse-definition { } like "specializer" set-word-prop ] bi ;
! Default specializers
{ first first2 first3 first4 }
@@ -119,6 +123,8 @@ SYNTAX: HINTS:
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
-\ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop
+\ base> { string fixnum } "specializer" set-word-prop
-\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop
+M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
+
+M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor
index 72ceea20a0..da2e5b5991 100644
--- a/basis/html/components/components-tests.factor
+++ b/basis/html/components/components-tests.factor
@@ -4,8 +4,6 @@ io.streams.null accessors inspector html.streams
html.components html.forms namespaces
xml.writer ;
-\ render must-infer
-
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
diff --git a/basis/http/client/client-docs.factor b/basis/http/client/client-docs.factor
index 0d7f7851e2..e00f8e2263 100644
--- a/basis/http/client/client-docs.factor
+++ b/basis/http/client/client-docs.factor
@@ -1,6 +1,7 @@
USING: http help.markup help.syntax io.pathnames io.streams.string
io.encodings.8-bit io.encodings.binary kernel strings urls
-urls.encoding byte-arrays strings assocs sequences destructors ;
+urls.encoding byte-arrays strings assocs sequences destructors
+http.client.post-data.private ;
IN: http.client
HELP: download-failed
@@ -71,7 +72,7 @@ ARTICLE: "http.client.get" "GET requests with the HTTP client"
{ $subsection with-http-get }
{ $subsection with-http-request } ;
-ARTICLE: "http.client.post-data" "HTTP client submission data"
+ARTICLE: "http.client.post-data" "HTTP client post data"
"HTTP POST and PUT request words take a post data parameter, which can be one of the following:"
{ $list
{ "a " { $link byte-array } ": the data is sent the server without further encoding" }
@@ -85,7 +86,9 @@ ARTICLE: "http.client.post-data" "HTTP client submission data"
{ $code
"\"my-large-post-request.txt\" ascii <file-reader>"
"[ URL\" http://www.my-company.com/web-service\" http-post ] with-disposal"
-} ;
+}
+"An internal word used to convert objects to " { $link post-data } " instances:"
+{ $subsection >post-data } ;
ARTICLE: "http.client.post" "POST requests with the HTTP client"
"Basic usage involves passing post data and a " { $link url } ", and getting a " { $link response } " and data back:"
diff --git a/basis/http/client/client-tests.factor b/basis/http/client/client-tests.factor
index 4dcc6b8813..4f786cb22c 100644
--- a/basis/http/client/client-tests.factor
+++ b/basis/http/client/client-tests.factor
@@ -1,8 +1,6 @@
USING: http.client http.client.private http tools.test
namespaces urls ;
-\ download must-infer
-
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
diff --git a/basis/http/client/client.factor b/basis/http/client/client.factor
index 4099e3d84c..d1997c73f9 100644
--- a/basis/http/client/client.factor
+++ b/basis/http/client/client.factor
@@ -6,7 +6,7 @@ math.order hashtables byte-arrays destructors
io io.sockets io.streams.string io.files io.timeouts
io.pathnames io.encodings io.encodings.string io.encodings.ascii
io.encodings.utf8 io.encodings.8-bit io.encodings.binary io.crlf
-io.streams.duplex fry ascii urls urls.encoding present
+io.streams.duplex fry ascii urls urls.encoding present locals
http http.parsers http.client.post-data ;
IN: http.client
@@ -77,12 +77,13 @@ SYMBOL: redirects
: redirect? ( response -- ? )
code>> 300 399 between? ;
-: do-redirect ( quot: ( chunk -- ) response -- response )
+:: do-redirect ( quot: ( chunk -- ) response -- response )
redirects inc
redirects get max-redirects < [
request get clone
- swap "location" header redirect-url
- "GET" >>method swap (with-http-request)
+ response "location" header redirect-url
+ response code>> 307 = [ "GET" >>method ] unless
+ quot (with-http-request)
] [ too-many-redirects ] if ; inline recursive
: read-chunk-size ( -- n )
@@ -164,7 +165,7 @@ ERROR: download-failed response ;
present file-name "?" split1 drop "/" ?tail drop ;
: download-to ( url file -- )
- binary [ [ write ] with-http-get drop ] with-file-writer ;
+ binary [ [ write ] with-http-get check-response drop ] with-file-writer ;
: download ( url -- )
dup download-name download-to ;
@@ -183,6 +184,12 @@ ERROR: download-failed response ;
: http-put ( post-data url -- response data )
<put-request> http-request ;
+: <delete-request> ( url -- request )
+ "DELETE" <client-request> ;
+
+: http-delete ( url -- response data )
+ <delete-request> http-request ;
+
USING: vocabs vocabs.loader ;
"debugger" vocab [ "http.client.debugger" require ] when
diff --git a/basis/http/client/post-data/post-data-docs.factor b/basis/http/client/post-data/post-data-docs.factor
new file mode 100644
index 0000000000..24325e9ebd
--- /dev/null
+++ b/basis/http/client/post-data/post-data-docs.factor
@@ -0,0 +1,6 @@
+IN: http.client.post-data
+USING: http http.client.post-data.private help.markup help.syntax kernel ;
+
+HELP: >post-data
+{ $values { "object" object } { "post-data" { $maybe post-data } } }
+{ $description "Converts an object into a " { $link post-data } " tuple instance." } ;
diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor
index bc906fad44..5c73377cbe 100644
--- a/basis/http/http-tests.factor
+++ b/basis/http/http-tests.factor
@@ -1,8 +1,8 @@
-USING: http http.server http.client http.client.private tools.test multiline
-io.streams.string io.encodings.utf8 io.encodings.8-bit
-io.encodings.binary io.encodings.string kernel arrays splitting
-sequences assocs io.sockets db db.sqlite continuations urls
-hashtables accessors namespaces xml.data ;
+USING: http http.server http.client http.client.private tools.test
+multiline io.streams.string io.encodings.utf8 io.encodings.8-bit
+io.encodings.binary io.encodings.string io.encodings.ascii kernel
+arrays splitting sequences assocs io.sockets db db.sqlite
+continuations urls hashtables accessors namespaces xml.data ;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
@@ -359,4 +359,44 @@ SYMBOL: a
! Test basic auth
[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
+! Test a corner case with static responder
+[ ] [
+ <dispatcher>
+ add-quit-action
+ "vocab:http/test/foo.html" <static> >>default
+ test-httpd
+] unit-test
+[ t ] [
+ "http://localhost/" add-port http-get nip
+ "vocab:http/test/foo.html" ascii file-contents =
+] unit-test
+
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
+
+! Check behavior of 307 redirect (reported by Chris Double)
+[ ] [
+ <dispatcher>
+ add-quit-action
+ <action>
+ [ "b" <temporary-redirect> ] >>submit
+ "a" add-responder
+ <action>
+ [
+ request get post-data>> data>> "data" =
+ [ "OK" "text/plain" <content> ] [ "OOPS" throw ] if
+ ] >>submit
+ "b" add-responder
+ test-httpd
+] unit-test
+
+[ "OK" ] [ "data" "http://localhost/a" add-port http-post nip ] unit-test
+
+! Check that download throws errors (reported by Chris Double)
+[
+ "resource:temp" [
+ "http://localhost/tweet_my_twat" add-port download
+ ] with-directory
+] must-fail
+
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
diff --git a/basis/http/server/dispatchers/dispatchers-tests.factor b/basis/http/server/dispatchers/dispatchers-tests.factor
index 2c8db27259..08974aca3b 100644
--- a/basis/http/server/dispatchers/dispatchers-tests.factor
+++ b/basis/http/server/dispatchers/dispatchers-tests.factor
@@ -3,8 +3,6 @@ tools.test kernel namespaces accessors io http math sequences
assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
-\ find-responder must-infer
-
TUPLE: mock-responder path ;
C: <mock-responder> mock-responder
diff --git a/basis/http/server/redirection/redirection-tests.factor b/basis/http/server/redirection/redirection-tests.factor
index 14855ca875..72ff111db9 100644
--- a/basis/http/server/redirection/redirection-tests.factor
+++ b/basis/http/server/redirection/redirection-tests.factor
@@ -2,8 +2,6 @@ IN: http.server.redirection.tests
USING: http http.server.redirection urls accessors
namespaces tools.test present kernel ;
-\ relative-to-request must-infer
-
[
<request>
<url>
diff --git a/basis/http/server/server-docs.factor b/basis/http/server/server-docs.factor
index 29f61416fa..daf0305972 100644
--- a/basis/http/server/server-docs.factor
+++ b/basis/http/server/server-docs.factor
@@ -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
diff --git a/basis/http/server/server-tests.factor b/basis/http/server/server-tests.factor
index 171973fcd8..3dc97098a4 100644
--- a/basis/http/server/server-tests.factor
+++ b/basis/http/server/server-tests.factor
@@ -4,8 +4,6 @@ IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
-\ make-http-error must-infer
-
[ "text/plain; charset=UTF-8" ] [
<response>
"text/plain" >>content-type
diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor
index 8b22b9a885..3beb730499 100755
--- a/basis/http/server/server.factor
+++ b/basis/http/server/server.factor
@@ -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
diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor
index bbca70d845..f80a3cc7cd 100644
--- a/basis/http/server/static/static.factor
+++ b/basis/http/server/static/static.factor
@@ -47,8 +47,8 @@ TUPLE: file-responder root hook special allow-listings ;
if ;
: serving-path ( filename -- filename )
- [ file-responder get root>> trim-tail-separators "/" ] dip
- "" or trim-head-separators 3append ;
+ [ file-responder get root>> trim-tail-separators ] dip
+ [ "/" swap trim-head-separators 3append ] unless-empty ;
: serve-file ( filename -- response )
dup mime-type
diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor
index e154df26a1..29ba3b9b80 100644
--- a/basis/images/bitmap/bitmap-tests.factor
+++ b/basis/images/bitmap/bitmap-tests.factor
@@ -1,6 +1,7 @@
USING: images.bitmap images.viewer io.encodings.binary
io.files io.files.unique kernel tools.test images.loader
-literals sequences ;
+literals sequences checksums.md5 checksums
+images.normalization ;
IN: images.bitmap.tests
CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
@@ -11,17 +12,33 @@ CONSTANT: test-bitmap4 "vocab:images/test-images/rgb4bit.bmp"
CONSTANT: test-bitmap1 "vocab:images/test-images/1bit.bmp"
-[ t ]
-[
- test-bitmap24
- [ binary file-contents ] [ load-image ] bi
-
- "test-bitmap24" unique-file
- [ save-bitmap ] [ binary file-contents ] bi =
-] unit-test
+CONSTANT: test-40 "vocab:images/test-images/40red24bit.bmp"
+CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp"
+CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp"
+CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
{
$ test-bitmap8
$ test-bitmap24
"vocab:ui/render/test/reference.bmp"
-} [ [ ] swap [ load-image drop ] curry unit-test ] each
\ No newline at end of file
+} [ [ ] swap [ load-image drop ] curry unit-test ] each
+
+
+: test-bitmap-save ( path -- ? )
+ [ md5 checksum-file ]
+ [ load-image normalize-image ] bi
+ "bitmap-save-test" unique-file
+ [ save-bitmap ]
+ [ md5 checksum-file ] bi = ;
+
+[
+ t
+] [
+ {
+ $ test-40
+ $ test-41
+ $ test-42
+ $ test-43
+ $ test-bitmap24
+ } [ test-bitmap-save ] all?
+] unit-test
diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor
index 8209159a8e..48095bb26b 100755
--- a/basis/images/bitmap/bitmap.factor
+++ b/basis/images/bitmap/bitmap.factor
@@ -37,14 +37,14 @@ M: bitmap-magic summary
ERROR: bmp-not-supported n ;
: reverse-lines ( byte-array width -- byte-array )
- 3 * <sliced-groups> <reversed> concat ; inline
+ <sliced-groups> <reversed> concat ; inline
: raw-bitmap>seq ( loading-bitmap -- array )
dup bit-count>>
{
{ 32 [ color-index>> ] }
- { 24 [ [ color-index>> ] [ width>> ] bi reverse-lines ] }
- { 8 [ [ 8bit>buffer ] [ width>> ] bi reverse-lines ] }
+ { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
+ { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
[ bmp-not-supported ]
} case >byte-array ;
@@ -81,30 +81,31 @@ ERROR: bmp-not-supported n ;
: image-size ( loading-bitmap -- n )
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
+: bitmap-padding ( width -- n )
+ 3 * 4 mod 4 swap - 4 mod ; inline
+
:: fixup-color-index ( loading-bitmap -- loading-bitmap )
loading-bitmap width>> :> width
width 3 * :> width*3
- loading-bitmap height>> abs :> height
- loading-bitmap color-index>> length :> color-index-length
- color-index-length height /i :> stride
- color-index-length width*3 height * - height /i :> padding
+ loading-bitmap width>> bitmap-padding :> padding
+ loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
+ loading-bitmap
padding 0 > [
- loading-bitmap [
+ [
stride <sliced-groups>
[ width*3 head-slice ] map concat
] change-color-index
- ] [
- loading-bitmap
- ] if ;
+ ] when ;
: parse-bitmap ( loading-bitmap -- loading-bitmap )
dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index
fixup-color-index ;
-: load-bitmap-data ( path loading-bitmap -- loading-bitmap )
- [ binary ] dip '[
- _ parse-file-header parse-bitmap-header parse-bitmap
+: load-bitmap-data ( path -- loading-bitmap )
+ binary [
+ loading-bitmap new
+ parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ;
ERROR: unknown-component-order bitmap ;
@@ -117,8 +118,7 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
-: loading-bitmap>bitmap-image ( loading-bitmap -- bitmap-image )
- [ bitmap-image new ] dip
+: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
{
[ raw-bitmap>seq >>bitmap ]
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
@@ -127,20 +127,30 @@ ERROR: unknown-component-order bitmap ;
} cleave ;
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
- drop loading-bitmap new
- load-bitmap-data
- loading-bitmap>bitmap-image ;
+ swap load-bitmap-data loading-bitmap>bitmap-image ;
PRIVATE>
-: bitmap>color-index ( bitmap-array -- byte-array )
- 4 <sliced-groups> [ 3 head-slice <reversed> ] map B{ } join ; inline
+: bitmap>color-index ( bitmap -- byte-array )
+ [
+ bitmap>>
+ 4 <sliced-groups>
+ [ 3 head-slice <reversed> ] map
+ B{ } join
+ ] [
+ dim>> first dup bitmap-padding dup 0 > [
+ [ 3 * group ] dip '[ _ <byte-array> append ] map
+ B{ } join
+ ] [
+ 2drop
+ ] if
+ ] bi ;
: save-bitmap ( image path -- )
binary [
B{ CHAR: B CHAR: M } write
[
- bitmap>> bitmap>color-index length 14 + 40 + write4
+ bitmap>color-index length 14 + 40 + write4
0 write4
54 write4
40 write4
@@ -159,7 +169,7 @@ PRIVATE>
[ drop 0 write4 ]
! size-image
- [ bitmap>> bitmap>color-index length write4 ]
+ [ bitmap>color-index length write4 ]
! x-pels
[ drop 0 write4 ]
@@ -175,7 +185,9 @@ PRIVATE>
! rgb-quads
[
- [ bitmap>> bitmap>color-index ] [ dim>> first ] bi
+ [ bitmap>color-index ]
+ [ dim>> first 3 * ]
+ [ dim>> first bitmap-padding + ] tri
reverse-lines write
]
} cleave
diff --git a/basis/images/images.factor b/basis/images/images.factor
index b32953f67c..178b91ab52 100755
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -3,7 +3,7 @@
USING: combinators kernel accessors ;
IN: images
-SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
@@ -11,6 +11,7 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
: bytes-per-pixel ( component-order -- n )
{
{ L [ 1 ] }
+ { LA [ 2 ] }
{ BGR [ 3 ] }
{ RGB [ 3 ] }
{ BGRA [ 4 ] }
@@ -33,4 +34,4 @@ TUPLE: image dim component-order upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
-GENERIC: load-image* ( path tuple -- image )
\ No newline at end of file
+GENERIC: load-image* ( path tuple -- image )
diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor
index b8bafc021f..fe33cc8f00 100644
--- a/basis/images/loader/loader.factor
+++ b/basis/images/loader/loader.factor
@@ -1,8 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images images.normalization
-io.pathnames ;
+accessors images.bitmap images.tiff images io.pathnames ;
IN: images.loader
ERROR: unknown-image-extension extension ;
@@ -16,4 +15,4 @@ ERROR: unknown-image-extension extension ;
} case ;
: load-image ( path -- image )
- dup image-class new load-image* normalize-image ;
+ dup image-class new load-image* ;
diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor
index 80eaff8140..6bf1ea2ff1 100755
--- a/basis/images/tiff/tiff.factor
+++ b/basis/images/tiff/tiff.factor
@@ -463,6 +463,7 @@ ERROR: unknown-component-order ifd ;
{ { 16 16 16 } [ 2 seq>native-endianness ] }
{ { 8 8 8 8 } [ ] }
{ { 8 8 8 } [ ] }
+ { 8 [ ] }
[ unknown-component-order ]
} case >>bitmap ;
@@ -474,11 +475,11 @@ ERROR: unknown-component-order ifd ;
{ { 16 16 16 } [ R16G16B16 ] }
{ { 8 8 8 8 } [ RGBA ] }
{ { 8 8 8 } [ RGB ] }
+ { 8 [ LA ] }
[ unknown-component-order ]
} case ;
: normalize-alpha-data ( seq -- byte-array )
- ! [ normalize-alpha-data ] change-bitmap
B{ } like dup
byte-array>float-array
4 <sliced-groups>
diff --git a/basis/interpolate/tags.txt b/basis/interpolate/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/basis/interpolate/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/basis/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor
index 9d81992eae..51ab6f27d9 100644
--- a/basis/inverse/inverse-tests.factor
+++ b/basis/inverse/inverse-tests.factor
@@ -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
@@ -83,3 +85,12 @@ C: <nil> nil
[ [ sqrt ] ] [ [ sq ] [undo] ] unit-test
[ [ not ] ] [ [ not ] [undo] ] unit-test
[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test
+
+TUPLE: funny-tuple ;
+: <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ;
+: funny-tuple ( -- ) "OOPS" throw ;
+
+[ ] [ [ <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
diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor
index 3a86703caf..4e807bd992 100755
--- a/basis/inverse/inverse.factor
+++ b/basis/inverse/inverse.factor
@@ -1,20 +1,20 @@
-! 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 ;
M: fail summary drop "Matching failed" ;
-: assure ( ? -- ) [ fail ] unless ;
+: assure ( ? -- ) [ fail ] unless ; inline
-: =/fail ( obj1 obj2 -- ) = assure ;
+: =/fail ( obj1 obj2 -- ) = assure ; inline
! Inverse of a quotation
@@ -74,7 +74,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: fold-word ( stack word -- stack )
2dup enough?
- [ 1quotation with-datastack ] [ [ % ] [ , ] bi* { } ] if ;
+ [ 1quotation with-datastack ]
+ [ [ [ literalize , ] each ] [ , ] bi* { } ]
+ if ;
: fold ( quot -- folded-quot )
[ { } [ fold-word ] reduce % ] [ ] make ;
@@ -141,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
@@ -171,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? }
@@ -192,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
@@ -212,14 +225,18 @@ 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 ;
: slot-readers ( class -- quot )
- all-slots
- [ name>> reader-word 1quotation [ keep ] curry ] map concat
- [ ] like [ drop ] compose ;
+ all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
: ?wrapped ( object -- wrapped )
dup wrapper? [ wrapped>> ] when ;
@@ -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 ;
diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor
index 6f283ac1bb..4dfe02d651 100755
--- a/basis/io/backend/windows/nt/nt.factor
+++ b/basis/io/backend/windows/nt/nt.factor
@@ -46,7 +46,7 @@ M: winnt add-completion ( win32-handle -- )
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
first dup eof?
- [ drop 0 ] [ (win32-error-string) throw ] if
+ [ drop 0 ] [ n>win32-error-string throw ] if
] }
} cond
] with-timeout ;
@@ -105,7 +105,7 @@ M: winnt seek-handle ( n seek-type handle -- )
GetLastError {
{ [ dup expected-io-error? ] [ drop f ] }
{ [ dup eof? ] [ drop t ] }
- [ (win32-error-string) throw ]
+ [ n>win32-error-string throw ]
} cond
] [ f ] if ;
diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/io/backend/windows/nt/privileges/privileges.factor
index 64218f75b0..33577a9394 100755
--- a/basis/io/backend/windows/nt/privileges/privileges.factor
+++ b/basis/io/backend/windows/nt/privileges/privileges.factor
@@ -2,7 +2,7 @@ USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.ports io.backend.windows io.files.windows
kernel libc math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 io.backend system accessors
-io.backend.windows.privileges ;
+io.backend.windows.privileges windows.errors ;
IN: io.backend.windows.nt.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor
index 6ecbc49f2a..9f5c00cc5f 100755
--- a/basis/io/backend/windows/windows.factor
+++ b/basis/io/backend/windows/windows.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend
-io.buffers io.files io.ports io.binary io.timeouts
-windows.errors strings kernel math namespaces sequences windows
-windows.kernel32 windows.shell32 windows.types windows.winsock
-splitting continuations math.bitwise system accessors ;
+io.buffers io.files io.ports io.binary io.timeouts system
+windows.errors strings kernel math namespaces sequences
+windows.errors windows.kernel32 windows.shell32 windows.types
+windows.winsock splitting continuations math.bitwise accessors ;
IN: io.backend.windows
: set-inherit ( handle ? -- )
@@ -51,4 +51,4 @@ HOOK: add-completion io-backend ( port -- )
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
"SECURITY_ATTRIBUTES" heap-size
- over set-SECURITY_ATTRIBUTES-nLength ;
\ No newline at end of file
+ over set-SECURITY_ATTRIBUTES-nLength ;
diff --git a/basis/io/buffers/buffers.factor b/basis/io/buffers/buffers.factor
index 4df081b17d..49b5357d98 100644
--- a/basis/io/buffers/buffers.factor
+++ b/basis/io/buffers/buffers.factor
@@ -22,7 +22,7 @@ M: buffer dispose* ptr>> free ;
swap >>fill 0 >>pos drop ;
: buffer-capacity ( buffer -- n )
- [ size>> ] [ fill>> ] bi - ; inline
+ [ size>> ] [ fill>> ] bi - >fixnum ; inline
: buffer-empty? ( buffer -- ? )
fill>> zero? ; inline
diff --git a/basis/io/crlf/crlf-tests.factor b/basis/io/crlf/crlf-tests.factor
new file mode 100644
index 0000000000..2412945ab3
--- /dev/null
+++ b/basis/io/crlf/crlf-tests.factor
@@ -0,0 +1,8 @@
+IN: io.crlf.tests
+USING: io.crlf tools.test io.streams.string io ;
+
+[ "Hello, world." ] [ "Hello, world." [ read-crlf ] with-string-reader ] unit-test
+[ "Hello, world." ] [ "Hello, world.\r\n" [ read-crlf ] with-string-reader ] unit-test
+[ "Hello, world.\r" [ read-crlf ] with-string-reader ] must-fail
+[ f ] [ "" [ read-crlf ] with-string-reader ] unit-test
+[ "" ] [ "\r\n" [ read-crlf ] with-string-reader ] unit-test
diff --git a/basis/io/crlf/crlf.factor b/basis/io/crlf/crlf.factor
index 53dddce199..29f10300de 100644
--- a/basis/io/crlf/crlf.factor
+++ b/basis/io/crlf/crlf.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel ;
+USING: io kernel sequences ;
IN: io.crlf
: crlf ( -- )
@@ -8,4 +8,4 @@ IN: io.crlf
: read-crlf ( -- seq )
"\r" read-until
- [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
+ [ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;
diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor
index 818899606d..a6c82a1bff 100644
--- a/basis/io/directories/search/search-docs.factor
+++ b/basis/io/directories/search/search-docs.factor
@@ -15,13 +15,20 @@ HELP: each-file
}
} ;
-HELP: recursive-directory
+HELP: recursive-directory-files
{ $values
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" }
{ "paths" "a sequence of pathname strings" }
}
{ $description "Traverses a directory path recursively and returns a sequence of files in a breadth-first or depth-first manner." } ;
+HELP: recursive-directory-entries
+{ $values
+ { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" }
+ { "directory-entries" "a sequence of directory-entries" }
+}
+{ $description "Traverses a directory path recursively and returns a sequence of directory-entries in a breadth-first or depth-first manner." } ;
+
HELP: find-file
{ $values
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
@@ -41,11 +48,11 @@ HELP: find-all-files
{ "path" "a pathname string" } { "quot" quotation }
{ "paths/f" "a sequence of pathname strings or f" }
}
-{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ;
+{ $description "Recursively finds all files in the input directory matching the predicate quotation." } ;
HELP: find-all-in-directories
{ $values
- { "directories" "a sequence of directory paths" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
+ { "directories" "a sequence of directory paths" } { "quot" quotation }
{ "paths/f" "a sequence of pathname strings or f" }
}
{ $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
@@ -55,7 +62,8 @@ HELP: find-all-in-directories
ARTICLE: "io.directories.search" "Searching directories"
"The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl
"Traversing directories:"
-{ $subsection recursive-directory }
+{ $subsection recursive-directory-files }
+{ $subsection recursive-directory-entries }
{ $subsection each-file }
"Finding files:"
{ $subsection find-file }
diff --git a/basis/io/directories/search/search-tests.factor b/basis/io/directories/search/search-tests.factor
index 5281ca9c2b..db4b58c4fd 100644
--- a/basis/io/directories/search/search-tests.factor
+++ b/basis/io/directories/search/search-tests.factor
@@ -1,12 +1,14 @@
-USING: io.directories.search io.files io.files.unique
-io.pathnames kernel namespaces sequences sorting tools.test ;
+USING: combinators.smart io.directories
+io.directories.hierarchy io.directories.search io.files
+io.files.unique io.pathnames kernel namespaces sequences
+sorting strings tools.test ;
IN: io.directories.search.tests
[ t ] [
[
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
current-temporary-directory get [ ] find-all-files
- ] with-unique-directory drop [ natural-sort ] bi@ =
+ ] cleanup-unique-directory [ natural-sort ] bi@ =
] unit-test
[ f ] [
@@ -18,3 +20,18 @@ IN: io.directories.search.tests
[ f ] [
{ } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
] unit-test
+
+[ t ] [
+ [
+ current-temporary-directory get
+ "the-head" unique-file drop t
+ [ file-name "the-head" head? ] find-file string?
+ ] cleanup-unique-directory
+] unit-test
+
+[ t ] [
+ [ unique-directory unique-directory ] output>array
+ [ [ "abcd" append-path touch-file ] each ]
+ [ [ file-name "abcd" = ] find-all-in-directories length 2 = ]
+ [ [ delete-tree ] each ] tri
+] unit-test
diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor
index 6db83ebca6..f7d18306f8 100755
--- a/basis/io/directories/search/search.factor
+++ b/basis/io/directories/search/search.factor
@@ -2,72 +2,108 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays continuations deques dlists fry
io.directories io.files io.files.info io.pathnames kernel
-sequences system vocabs.loader ;
+sequences system vocabs.loader locals math namespaces
+sorting assocs calendar threads io math.parser ;
IN: io.directories.search
+: qualified-directory-entries ( path -- seq )
+ dup directory-entries
+ [ [ append-path ] change-name ] with map ;
+
+: qualified-directory-files ( path -- seq )
+ dup directory-files [ append-path ] with map ;
+
+: with-qualified-directory-files ( path quot -- )
+ '[ "" qualified-directory-files @ ] with-directory ; inline
+
+: with-qualified-directory-entries ( path quot -- )
+ '[ "" qualified-directory-entries @ ] with-directory ; inline
+
<PRIVATE
TUPLE: directory-iterator path bfs queue ;
-: qualified-directory ( path -- seq )
- dup directory-files [ append-path ] with map ;
-
-: push-directory ( path iter -- )
- [ qualified-directory ] dip [
- [ queue>> ] [ bfs>> ] bi
+: push-directory-entries ( path iter -- )
+ [ [ qualified-directory-entries ] [ 2drop f ] recover ] dip '[
+ _ [ queue>> ] [ bfs>> ] bi
[ push-front ] [ push-back ] if
- ] curry each ;
+ ] each ;
: <directory-iterator> ( path bfs? -- iterator )
<dlist> directory-iterator boa
- dup path>> over push-directory ;
+ dup path>> over push-directory-entries ;
-: next-file ( iter -- file/f )
+: next-directory-entry ( iter -- directory-entry/f )
dup queue>> deque-empty? [ drop f ] [
- dup queue>> pop-back dup link-info directory?
- [ over push-directory next-file ] [ nip ] if
+ dup queue>> pop-back
+ dup directory?
+ [ name>> over push-directory-entries next-directory-entry ]
+ [ nip ] if
] if ;
-: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
- over next-file [
- over call
- [ 2nip ] [ iterate-directory ] if*
+:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f )
+ iter next-directory-entry [
+ quot call
+ [ iter quot iterate-directory-entries ] unless*
] [
- 2drop f
+ f
] if* ; inline recursive
+: iterate-directory ( iter quot -- path/f )
+ [ name>> ] prepose iterate-directory-entries ; inline
+
+: setup-traversal ( path bfs quot -- iterator quot' )
+ [ <directory-iterator> ] dip [ f ] compose ; inline
+
PRIVATE>
-: each-file ( path bfs? quot: ( obj -- ) -- )
+: each-file ( path bfs? quot -- )
+ setup-traversal iterate-directory drop ; inline
+
+: each-directory-entry ( path bfs? quot -- )
+ setup-traversal iterate-directory-entries drop ; inline
+
+: recursive-directory-files ( path bfs? -- paths )
+ [ ] accumulator [ each-file ] dip ; inline
+
+: recursive-directory-entries ( path bfs? -- directory-entries )
+ [ ] accumulator [ each-directory-entry ] dip ; inline
+
+: find-file ( path bfs? quot -- path/f )
[ <directory-iterator> ] dip
- [ f ] compose iterate-directory drop ; inline
+ [ keep and ] curry iterate-directory ; inline
-: recursive-directory ( path bfs? -- paths )
- [ ] accumulator [ each-file ] dip ;
+: find-all-files ( path quot -- paths/f )
+ [ f <directory-iterator> ] dip pusher
+ [ [ f ] compose iterate-directory drop ] dip ; inline
-: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
- '[
- _ _ _ [ <directory-iterator> ] dip
- [ keep and ] curry iterate-directory
- ] [ drop f ] recover ; inline
+ERROR: file-not-found path bfs? quot ;
-: find-all-files ( path quot: ( obj -- ? ) -- paths/f )
- f swap
- '[
- _ _ _ [ <directory-iterator> ] dip
- pusher [ [ f ] compose iterate-directory drop ] dip
- ] [ drop f ] recover ; inline
+: find-file-throws ( path bfs? quot -- path )
+ 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline
-ERROR: file-not-found ;
+: find-in-directories ( directories bfs? quot -- path'/f )
+ '[ _ [ _ _ find-file-throws ] attempt-all ]
+ [ drop f ] recover ; inline
-: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
- '[
- _ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
- ] [
- drop f
- ] recover ; inline
+: find-all-in-directories ( directories quot -- paths/f )
+ '[ _ find-all-files ] map concat ; inline
-: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
- '[ _ _ find-all-files ] map concat ; inline
+: link-size/0 ( path -- n )
+ [ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
+
+: directory-size ( path -- n )
+ 0 swap t [ link-size/0 + ] each-file ;
+
+: path>usage ( directory-entry -- name size )
+ [ name>> dup ] [ directory? ] bi
+ [ directory-size ] [ link-size/0 ] if ;
+
+: directory-usage ( path -- assoc )
+ [
+ [
+ [ path>usage ] [ drop name>> 0 ] recover
+ ] { } map>assoc
+ ] with-qualified-directory-entries sort-values ;
os windows? [ "io.directories.search.windows" require ] when
diff --git a/basis/io/encodings/8-bit/8-bit-tests.factor b/basis/io/encodings/8-bit/8-bit-tests.factor
index 8b18e2a9af..55b9c44934 100644
--- a/basis/io/encodings/8-bit/8-bit-tests.factor
+++ b/basis/io/encodings/8-bit/8-bit-tests.factor
@@ -4,11 +4,11 @@ IN: io.encodings.8-bit.tests
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" latin1 encode ] unit-test
[ { 256 } >string latin1 encode ] must-fail
-[ B{ 255 } ] [ { 255 } latin1 encode ] unit-test
+[ B{ 255 } ] [ { 255 } >string latin1 encode ] unit-test
[ "bar" ] [ "bar" latin1 decode ] unit-test
-[ { CHAR: b 233 CHAR: r } ] [ { CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
-[ { HEX: fffd HEX: 20AC } ] [ { HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test
+[ { CHAR: b 233 CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } latin1 decode >array ] unit-test
+[ { HEX: fffd HEX: 20AC } ] [ B{ HEX: 81 HEX: 80 } windows-1252 decode >array ] unit-test
[ t ] [ \ latin1 8-bit-encoding? ] unit-test
[ "bar" ] [ "bar" \ latin1 decode ] unit-test
diff --git a/basis/io/encodings/ascii/ascii-tests.factor b/basis/io/encodings/ascii/ascii-tests.factor
index 4f6d28835a..fcd549d31f 100644
--- a/basis/io/encodings/ascii/ascii-tests.factor
+++ b/basis/io/encodings/ascii/ascii-tests.factor
@@ -3,7 +3,7 @@ IN: io.encodings.ascii.tests
[ B{ CHAR: f CHAR: o CHAR: o } ] [ "foo" ascii encode ] unit-test
[ { 128 } >string ascii encode ] must-fail
-[ B{ 127 } ] [ { 127 } ascii encode ] unit-test
+[ B{ 127 } ] [ { 127 } >string ascii encode ] unit-test
[ "bar" ] [ "bar" ascii decode ] unit-test
-[ { CHAR: b HEX: fffd CHAR: r } ] [ { CHAR: b 233 CHAR: r } ascii decode >array ] unit-test
+[ { CHAR: b HEX: fffd CHAR: r } ] [ B{ CHAR: b 233 CHAR: r } ascii decode >array ] unit-test
diff --git a/basis/io/encodings/gb18030/gb18030-tests.factor b/basis/io/encodings/gb18030/gb18030-tests.factor
index 20ea522a4d..da44d1cf9a 100644
--- a/basis/io/encodings/gb18030/gb18030-tests.factor
+++ b/basis/io/encodings/gb18030/gb18030-tests.factor
@@ -6,7 +6,7 @@ IN: io.encodings.gb18030.tests
[ "hello" ] [ "hello" gb18030 encode >string ] unit-test
[ "hello" ] [ "hello" gb18030 decode ] unit-test
[ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } ]
-[ B{ HEX: B7 HEX: B8 } gb18030 encode ] unit-test
+[ B{ HEX: B7 HEX: B8 } >string gb18030 encode ] unit-test
[ { HEX: B7 HEX: B8 } ]
[ B{ HEX: A1 HEX: A4 HEX: 81 HEX: 30 HEX: 86 HEX: 30 } gb18030 decode >array ] unit-test
[ { HEX: B7 CHAR: replacement-character } ]
@@ -18,9 +18,9 @@ IN: io.encodings.gb18030.tests
[ { HEX: B7 } ]
[ B{ HEX: A1 HEX: A4 } gb18030 decode >array ] unit-test
[ { CHAR: replacement-character } ]
-[ B{ HEX: A1 } gb18030 decode >array ] unit-test
+[ B{ HEX: A1 } >string gb18030 decode >array ] unit-test
[ { HEX: 44D7 HEX: 464B } ]
[ B{ HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 }
gb18030 decode >array ] unit-test
[ { HEX: 82 HEX: 33 HEX: A3 HEX: 39 HEX: 82 HEX: 33 HEX: C9 HEX: 31 } ]
-[ { HEX: 44D7 HEX: 464B } gb18030 encode >array ] unit-test
+[ { HEX: 44D7 HEX: 464B } >string gb18030 encode >array ] unit-test
diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor
index 899bedfbc6..594e245a9c 100644
--- a/basis/io/encodings/iana/iana.factor
+++ b/basis/io/encodings/iana/iana.factor
@@ -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
\ No newline at end of file
diff --git a/basis/io/encodings/string/string.factor b/basis/io/encodings/string/string.factor
index 5e57a943a9..3659939fb0 100644
--- a/basis/io/encodings/string/string.factor
+++ b/basis/io/encodings/string/string.factor
@@ -4,7 +4,7 @@ USING: io io.streams.byte-array ;
IN: io.encodings.string
: decode ( byte-array encoding -- string )
- <byte-reader> contents ;
+ <byte-reader> stream-contents ;
: encode ( string encoding -- byte-array )
[ write ] with-byte-writer ;
diff --git a/basis/io/encodings/utf16/utf16-tests.factor b/basis/io/encodings/utf16/utf16-tests.factor
deleted file mode 100644
index 230612cc77..0000000000
--- a/basis/io/encodings/utf16/utf16-tests.factor
+++ /dev/null
@@ -1,25 +0,0 @@
-! Copyright (C) 2008 Daniel Ehrenberg.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test io.encodings.utf16 arrays sbufs
-io.streams.byte-array sequences io.encodings io
-io.encodings.string alien.c-types alien.strings accessors classes ;
-IN: io.encodings.utf16.tests
-
-[ { CHAR: x } ] [ { 0 CHAR: x } utf16be decode >array ] unit-test
-[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
-
-[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } utf16be encode >array ] unit-test
-
-[ { CHAR: x } ] [ { CHAR: x 0 } utf16le decode >array ] unit-test
-[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } utf16le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } utf16le decode >array ] unit-test
-
-[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16le encode >array ] unit-test
-
-[ { CHAR: x } ] [ { HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
-[ { CHAR: x } ] [ { HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
-
-[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } utf16 encode >array ] unit-test
diff --git a/basis/io/encodings/utf32/utf32-tests.factor b/basis/io/encodings/utf32/utf32-tests.factor
index be1111e242..2a80e47c7b 100644
--- a/basis/io/encodings/utf32/utf32-tests.factor
+++ b/basis/io/encodings/utf32/utf32-tests.factor
@@ -1,30 +1,30 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test io.encodings.utf32 arrays sbufs
-io.streams.byte-array sequences io.encodings io
+io.streams.byte-array sequences io.encodings io strings
io.encodings.string alien.c-types alien.strings accessors classes ;
IN: io.encodings.utf32.tests
-[ { CHAR: x } ] [ { 0 0 0 CHAR: x } utf32be decode >array ] unit-test
-[ { HEX: 1D11E } ] [ { 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 1 HEX: D1 } utf32be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 1 } utf32be decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { 0 } utf32be decode >array ] unit-test
+[ { CHAR: x } ] [ B{ 0 0 0 CHAR: x } utf32be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ B{ 0 1 HEX: D1 HEX: 1E } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ 0 1 HEX: D1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ 0 1 } utf32be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ 0 } utf32be decode >array ] unit-test
[ { } ] [ { } utf32be decode >array ] unit-test
-[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } utf32be encode >array ] unit-test
+[ { 0 0 0 CHAR: x 0 1 HEX: D1 HEX: 1E } ] [ { CHAR: x HEX: 1d11e } >string utf32be encode >array ] unit-test
-[ { CHAR: x } ] [ { CHAR: x 0 0 0 } utf32le decode >array ] unit-test
-[ { HEX: 1d11e } ] [ { HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
-[ { CHAR: replacement-character } ] [ { HEX: 1e } utf32le decode >array ] unit-test
+[ { CHAR: x } ] [ B{ CHAR: x 0 0 0 } utf32le decode >array ] unit-test
+[ { HEX: 1d11e } ] [ B{ HEX: 1e HEX: d1 1 0 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ HEX: 1e HEX: d1 } utf32le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ HEX: 1e } utf32le decode >array ] unit-test
[ { } ] [ { } utf32le decode >array ] unit-test
-[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32le encode >array ] unit-test
+[ { 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32le encode >array ] unit-test
-[ { CHAR: x } ] [ { HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
-[ { CHAR: x } ] [ { 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ HEX: ff HEX: fe 0 0 CHAR: x 0 0 0 } utf32 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ 0 0 HEX: fe HEX: ff 0 0 0 CHAR: x } utf32 decode >array ] unit-test
-[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } utf32 encode >array ] unit-test
+[ { HEX: ff HEX: fe 0 0 120 0 0 0 HEX: 1e HEX: d1 1 0 } ] [ { CHAR: x HEX: 1d11e } >string utf32 encode >array ] unit-test
diff --git a/basis/io/files/info/info-tests.factor b/basis/io/files/info/info-tests.factor
index b94bc0635c..7b19f56b10 100644
--- a/basis/io/files/info/info-tests.factor
+++ b/basis/io/files/info/info-tests.factor
@@ -3,9 +3,6 @@ io.directories kernel io.pathnames accessors tools.test
sequences io.files.temp ;
IN: io.files.info.tests
-\ file-info must-infer
-\ link-info must-infer
-
[ t ] [
temp-directory [ "hi41" "test41" utf8 set-file-contents ] with-directory
temp-directory "test41" append-path utf8 file-contents "hi41" =
diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor
index fd21850612..5c5d2c93d2 100644
--- a/basis/io/files/info/info.factor
+++ b/basis/io/files/info/info.factor
@@ -5,7 +5,7 @@ vocabs.loader io.files.types ;
IN: io.files.info
! File info
-TUPLE: file-info type size permissions created modified
+TUPLE: file-info type size size-on-disk permissions created modified
accessed ;
HOOK: file-info os ( path -- info )
@@ -25,4 +25,4 @@ HOOK: file-system-info os ( path -- file-system-info )
{
{ [ os unix? ] [ "io.files.info.unix." os name>> append ] }
{ [ os windows? ] [ "io.files.info.windows" ] }
-} cond require
\ No newline at end of file
+} cond require
diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor
index 616f70cccc..80f4b74ac8 100644
--- a/basis/io/files/info/unix/unix.factor
+++ b/basis/io/files/info/unix/unix.factor
@@ -63,6 +63,8 @@ M: unix link-info ( path -- info )
M: unix new-file-info ( -- class ) unix-file-info new ;
+CONSTANT: standard-unix-block-size 512
+
M: unix stat>file-info ( stat -- file-info )
[ new-file-info ] dip
{
@@ -80,6 +82,7 @@ M: unix stat>file-info ( stat -- file-info )
[ stat-st_rdev >>rdev ]
[ stat-st_blocks >>blocks ]
[ stat-st_blksize >>blocksize ]
+ [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
} cleave ;
: n>file-type ( n -- type )
diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor
index fdff368491..81e43f8dd9 100755
--- a/basis/io/files/info/windows/windows.factor
+++ b/basis/io/files/info/windows/windows.factor
@@ -5,11 +5,33 @@ io.files.windows io.files.windows.nt kernel windows.kernel32
windows.time windows accessors alien.c-types combinators
generalizations system alien.strings io.encodings.utf16n
sequences splitting windows.errors fry continuations destructors
-calendar ascii combinators.short-circuit ;
+calendar ascii combinators.short-circuit locals ;
IN: io.files.info.windows
+:: round-up-to ( n multiple -- n' )
+ n multiple rem dup 0 = [
+ drop n
+ ] [
+ multiple swap - n +
+ ] if ;
+
TUPLE: windows-file-info < file-info attributes ;
+: get-compressed-file-size ( path -- n )
+ "DWORD" <c-object> [ GetCompressedFileSize ] keep
+ over INVALID_FILE_SIZE = [
+ win32-error-string throw
+ ] [
+ *uint >64bit
+ ] if ;
+
+: set-windows-size-on-disk ( file-info path -- file-info )
+ over attributes>> +compressed+ swap member? [
+ get-compressed-file-size
+ ] [
+ drop dup size>> 4096 round-up-to
+ ] if >>size-on-disk ;
+
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
{
@@ -79,7 +101,9 @@ TUPLE: windows-file-info < file-info attributes ;
] if ;
M: windows file-info ( path -- info )
- normalize-path get-file-information-stat ;
+ normalize-path
+ [ get-file-information-stat ]
+ [ set-windows-size-on-disk ] bi ;
M: windows link-info ( path -- info )
file-info ;
diff --git a/basis/io/files/links/links-docs.factor b/basis/io/files/links/links-docs.factor
index 8419399c92..bf1bedaa08 100644
--- a/basis/io/files/links/links-docs.factor
+++ b/basis/io/files/links/links-docs.factor
@@ -5,6 +5,10 @@ HELP: make-link
{ $values { "target" "a path to the symbolic link's target" } { "symlink" "a path to new symbolic link" } }
{ $description "Creates a symbolic link." } ;
+HELP: make-hard-link
+{ $values { "target" "a path to the hard link's target" } { "link" "a path to new symbolic link" } }
+{ $description "Creates a hard link." } ;
+
HELP: read-link
{ $values { "symlink" "a path to an existing symbolic link" } { "path" "the path pointed to by the symbolic link" } }
{ $description "Reads the symbolic link and returns its target path." } ;
diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor
index 1212d579db..7aec916c72 100644
--- a/basis/io/files/links/links.factor
+++ b/basis/io/files/links/links.factor
@@ -6,6 +6,8 @@ IN: io.files.links
HOOK: make-link os ( target symlink -- )
+HOOK: make-hard-link os ( target link -- )
+
HOOK: read-link os ( symlink -- path )
: copy-link ( target symlink -- )
diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor
index 7d2a6ee4f3..c9a651b484 100644
--- a/basis/io/files/links/unix/unix.factor
+++ b/basis/io/files/links/unix/unix.factor
@@ -7,6 +7,9 @@ IN: io.files.links.unix
M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ;
+M: unix make-hard-link ( path1 path2 -- )
+ normalize-path link io-error ;
+
M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ;
diff --git a/basis/io/files/unique/unique-docs.factor b/basis/io/files/unique/unique-docs.factor
index 74fc045032..6a7be47813 100644
--- a/basis/io/files/unique/unique-docs.factor
+++ b/basis/io/files/unique/unique-docs.factor
@@ -62,8 +62,8 @@ HELP: current-temporary-directory
HELP: unique-file
{ $values
+ { "prefix" string }
{ "path" "a pathname string" }
- { "path'" "a pathname string" }
}
{ $description "Creates a temporary file in the directory stored in " { $link current-temporary-directory } " and outputs the path name." } ;
diff --git a/basis/io/files/unique/unique-tests.factor b/basis/io/files/unique/unique-tests.factor
index fd8cf2c69f..53a77907cf 100644
--- a/basis/io/files/unique/unique-tests.factor
+++ b/basis/io/files/unique/unique-tests.factor
@@ -5,7 +5,7 @@ IN: io.files.unique.tests
[ 123 ] [
"core" ".test" [
- [ [ 123 CHAR: a <repetition> ] dip ascii set-file-contents ]
+ [ [ 123 CHAR: a <string> ] dip ascii set-file-contents ]
[ file-info size>> ] bi
] cleanup-unique-file
] unit-test
diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor
index 7bd96aa63b..0e4338e3e0 100644
--- a/basis/io/files/unique/unique.factor
+++ b/basis/io/files/unique/unique.factor
@@ -64,7 +64,7 @@ PRIVATE>
[ unique-directory ] dip
'[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
-: unique-file ( path -- path' )
+: unique-file ( prefix -- path )
"" make-unique-file ;
{
diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor
index 9e449982fb..32424a37a3 100755
--- a/basis/io/files/windows/nt/nt.factor
+++ b/basis/io/files/windows/nt/nt.factor
@@ -4,7 +4,8 @@ io.backend.windows io.files.windows io.encodings.utf16n windows
windows.kernel32 kernel libc math threads system environment
alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings assocs
-namespaces make accessors tr windows.time ;
+namespaces make accessors tr windows.time windows.shell32
+windows.errors ;
IN: io.files.windows.nt
M: winnt cwd
@@ -58,4 +59,9 @@ M: winnt open-append
[ dup windows-file-size ] [ drop 0 ] recover
[ (open-append) ] dip >>ptr ;
-M: winnt home "USERPROFILE" os-env ;
+M: winnt home
+ {
+ [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
+ [ "USERPROFILE" os-env ]
+ [ my-documents ]
+ } 0|| ;
diff --git a/basis/io/launcher/launcher-docs.factor b/basis/io/launcher/launcher-docs.factor
index 3585214735..f20e65dc27 100644
--- a/basis/io/launcher/launcher-docs.factor
+++ b/basis/io/launcher/launcher-docs.factor
@@ -140,7 +140,46 @@ HELP: <process-stream>
{ "desc" "a launch descriptor" }
{ "encoding" "an encoding descriptor" }
{ "stream" "a bidirectional stream" } }
-{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream of the given encoding." } ;
+{ $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream with the given encoding." } ;
+
+HELP: <process-reader>
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "stream" "an input stream" } }
+{ $description "Launches a process and redirects its output via a pipe which may be read as a stream with the given encoding." } ;
+
+HELP: <process-writer>
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "stream" "an output stream" }
+}
+{ $description "Launches a process and redirects its input via a pipe which may be written to as a stream with the given encoding." } ;
+
+HELP: with-process-stream
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+}
+{ $description "Launches a process and redirects its input and output via a pair of pipes. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to these pipes." } ;
+
+HELP: with-process-reader
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+}
+{ $description "Launches a process and redirects its output via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
+
+HELP: with-process-writer
+{ $values
+ { "desc" "a launch descriptor" }
+ { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+}
+{ $description "Launches a process and redirects its input via a pipe. The quotation is called with " { $link input-stream } " and " { $link output-stream } " rebound to this pipe." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" object } }
@@ -175,7 +214,11 @@ ARTICLE: "io.launcher.launch" "Launching processes"
"Redirecting standard input and output to a pipe:"
{ $subsection <process-reader> }
{ $subsection <process-writer> }
-{ $subsection <process-stream> } ;
+{ $subsection <process-stream> }
+"Combinators built on top of the above:"
+{ $subsection with-process-reader }
+{ $subsection with-process-writer }
+{ $subsection with-process-stream } ;
ARTICLE: "io.launcher.examples" "Launcher examples"
"Starting a command and waiting for it to finish:"
diff --git a/basis/io/launcher/launcher-tests.factor b/basis/io/launcher/launcher-tests.factor
index 003f382020..da7284dbe5 100644
--- a/basis/io/launcher/launcher-tests.factor
+++ b/basis/io/launcher/launcher-tests.factor
@@ -1,6 +1,3 @@
IN: io.launcher.tests
USING: tools.test io.launcher ;
-\ <process-stream> must-infer
-\ <process-reader> must-infer
-\ <process-writer> must-infer
diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor
index f5809223fc..838c09c657 100755
--- a/basis/io/launcher/launcher.factor
+++ b/basis/io/launcher/launcher.factor
@@ -3,9 +3,9 @@
USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors environment
-io io.backend io.timeouts io.pipes io.pipes.private io.encodings
-io.streams.duplex io.ports debugger prettyprint summary
-calendar ;
+io io.encodings.ascii io.backend io.timeouts io.pipes
+io.pipes.private io.encodings io.streams.duplex io.ports
+debugger prettyprint summary calendar ;
IN: io.launcher
TUPLE: process < identity-tuple
@@ -265,3 +265,5 @@ M: object run-pipeline-element
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ]
} cond
+
+: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;
diff --git a/basis/io/launcher/unix/parser/parser-tests.factor b/basis/io/launcher/unix/parser/parser-tests.factor
index 07502e87a4..90504ccac2 100644
--- a/basis/io/launcher/unix/parser/parser-tests.factor
+++ b/basis/io/launcher/unix/parser/parser-tests.factor
@@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ;
[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
-[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
-[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
-[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
-[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
-[ "'abc def' \"hey" tokenize-command ] must-fail
-[ "'abc def" tokenize-command ] must-fail
-[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
+[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test
+[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test
+[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test
+[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test
+[ "\"abc def\" \"hey" tokenize-command ] must-fail
+[ "\"abc def" tokenize-command ] must-fail
+[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
[
V{
diff --git a/basis/io/launcher/unix/parser/parser.factor b/basis/io/launcher/unix/parser/parser.factor
index 97e6dee95f..bcc5f965e9 100644
--- a/basis/io/launcher/unix/parser/parser.factor
+++ b/basis/io/launcher/unix/parser/parser.factor
@@ -1,33 +1,17 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: peg peg.parsers kernel sequences strings words ;
+USING: peg peg.ebnf arrays sequences strings kernel ;
IN: io.launcher.unix.parser
! Our command line parser. Supported syntax:
! foo bar baz -- simple tokens
! foo\ bar -- escaping the space
-! 'foo bar' -- quotation
! "foo bar" -- quotation
-: 'escaped-char' ( -- parser )
- "\\" token any-char 2seq [ second ] action ;
-
-: 'quoted-char' ( delimiter -- parser' )
- 'escaped-char'
- swap [ member? not ] curry satisfy
- 2choice ; inline
-
-: 'quoted' ( delimiter -- parser )
- dup 'quoted-char' repeat0 swap dup surrounded-by ;
-
-: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
-
-: 'argument' ( -- parser )
- "\"" 'quoted'
- "'" 'quoted'
- 'unquoted' 3choice
- [ >string ] action ;
-
-PEG: tokenize-command ( command -- ast/f )
- 'argument' " " token repeat1 list-of
- " " token repeat0 tuck pack
- just ;
+EBNF: tokenize-command
+space = " "
+escaped-char = "\" .:ch => [[ ch ]]
+quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
+unquoted = (escaped-char | [^ "])+
+argument = (quoted | unquoted) => [[ >string ]]
+command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
+;EBNF
diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor
index f375bb41e8..99d45e4fd7 100644
--- a/basis/io/launcher/unix/unix-tests.factor
+++ b/basis/io/launcher/unix/unix-tests.factor
@@ -33,7 +33,7 @@ concurrency.promises threads unix.process ;
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] unit-test
[ ] [
@@ -52,7 +52,7 @@ concurrency.promises threads unix.process ;
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] unit-test
[ ] [
@@ -70,14 +70,14 @@ concurrency.promises threads unix.process ;
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] unit-test
[ t ] [
<process>
"env" >>command
{ { "A" "B" } } >>environment
- ascii <process-reader> lines
+ ascii <process-reader> stream-lines
"A=B" swap member?
] unit-test
@@ -86,7 +86,7 @@ concurrency.promises threads unix.process ;
"env" >>command
{ { "A" "B" } } >>environment
+replace-environment+ >>environment-mode
- ascii <process-reader> lines
+ ascii <process-reader> stream-lines
] unit-test
[ "hi\n" ] [
@@ -113,13 +113,13 @@ concurrency.promises threads unix.process ;
"append-test" temp-file utf8 file-contents
] unit-test
-[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
+[ t ] [ "ls" utf8 <process-stream> stream-contents >boolean ] unit-test
[ "Hello world.\n" ] [
"cat" utf8 <process-stream> [
"Hello world.\n" write
output-stream get dispose
- input-stream get contents
+ input-stream get stream-contents
] with-stream
] unit-test
diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor
index 04202365fd..53b3d3ce7e 100755
--- a/basis/io/launcher/windows/nt/nt-tests.factor
+++ b/basis/io/launcher/windows/nt/nt-tests.factor
@@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
os-envs =
] unit-test
@@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
os-envs =
] unit-test
@@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
"A" swap at
] unit-test
@@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
] unit-test
diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor
index 21b3d294c9..a80ce3bc82 100644
--- a/basis/io/mmap/functor/functor.factor
+++ b/basis/io/mmap/functor/functor.factor
@@ -9,13 +9,14 @@ SLOT: length
: mapped-file>direct ( mapped-file type -- alien length )
[ [ address>> ] [ length>> ] bi ] dip
- heap-size [ 1- + ] keep /i ;
+ heap-size [ 1 - + ] keep /i ;
FUNCTOR: define-mapped-array ( T -- )
-<mapped-A> DEFINES <mapped-${T}-array>
-<A> IS <direct-${T}-array>
-with-mapped-A-file DEFINES with-mapped-${T}-file
+<mapped-A> DEFINES <mapped-${T}-array>
+<A> IS <direct-${T}-array>
+with-mapped-A-file DEFINES with-mapped-${T}-file
+with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader
WHERE
@@ -25,4 +26,7 @@ WHERE
: with-mapped-A-file ( path quot -- )
'[ <mapped-A> @ ] with-mapped-file ; inline
+: with-mapped-A-file-reader ( path quot -- )
+ '[ <mapped-A> @ ] with-mapped-file-reader ; inline
+
;FUNCTOR
diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor
index 5ef3400a6d..1da82e42e2 100644
--- a/basis/io/mmap/mmap-docs.factor
+++ b/basis/io/mmap/mmap-docs.factor
@@ -18,7 +18,13 @@ HELP: <mapped-file>
HELP: with-mapped-file
{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
-{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
+{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
+{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
+{ $errors "Throws an error if a memory mapping could not be established." } ;
+
+HELP: with-mapped-file-reader
+{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } }
+{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." }
{ $errors "Throws an error if a memory mapping could not be established." } ;
@@ -54,11 +60,20 @@ ARTICLE: "io.mmap.arrays" "Memory-mapped arrays"
ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly"
"Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ;
+ARTICLE: "io.mmap.examples" "Memory-mapped file example"
+"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
+{ $code
+ "USING: accessors grouping io.files io.mmap.char kernel sequences ;"
+ "\"mydata.dat\" ["
+ " 4 <sliced-groups> [ reverse-here ] change-each"
+ "] with-mapped-char-file"
+} ;
+
ARTICLE: "io.mmap" "Memory-mapped files"
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
{ $subsection <mapped-file> }
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "."
-$nl
+{ $subsection "io.mmap.examples" }
"A utility combinator which wraps the above:"
{ $subsection with-mapped-file }
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor
index a4d55f3c1e..0e1cd1a036 100644
--- a/basis/io/mmap/mmap-tests.factor
+++ b/basis/io/mmap/mmap-tests.factor
@@ -7,6 +7,7 @@ IN: io.mmap.tests
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor
index 1a58471514..e03d5fb30b 100644
--- a/basis/io/mmap/mmap.factor
+++ b/basis/io/mmap/mmap.factor
@@ -8,14 +8,27 @@ IN: io.mmap
TUPLE: mapped-file address handle length disposed ;
-HOOK: (mapped-file) os ( path length -- address handle )
+HOOK: (mapped-file-reader) os ( path length -- address handle )
+HOOK: (mapped-file-r/w) os ( path length -- address handle )
ERROR: bad-mmap-size path size ;
-: <mapped-file> ( path -- mmap )
+<PRIVATE
+
+: prepare-mapped-file ( path -- path' n )
[ normalize-path ] [ file-info size>> ] bi
- dup 0 <= [ bad-mmap-size ] when
- [ (mapped-file) ] keep
+ dup 0 <= [ bad-mmap-size ] when ;
+
+PRIVATE>
+
+: <mapped-file-reader> ( path -- mmap )
+ prepare-mapped-file
+ [ (mapped-file-reader) ] keep
+ f mapped-file boa ;
+
+: <mapped-file> ( path -- mmap )
+ prepare-mapped-file
+ [ (mapped-file-r/w) ] keep
f mapped-file boa ;
HOOK: close-mapped-file io-backend ( mmap -- )
@@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
: with-mapped-file ( path quot -- )
[ <mapped-file> ] dip with-disposal ; inline
+: with-mapped-file-reader ( path quot -- )
+ [ <mapped-file-reader> ] dip with-disposal ; inline
+
{
{ [ os unix? ] [ "io.mmap.unix" require ] }
{ [ os winnt? ] [ "io.mmap.windows" require ] }
diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor
index 0fa8e1151f..7d12d52361 100644
--- a/basis/io/mmap/unix/unix.factor
+++ b/basis/io/mmap/unix/unix.factor
@@ -4,21 +4,23 @@ USING: alien io io.files kernel math math.bitwise system unix
io.backend.unix io.ports io.mmap destructors locals accessors ;
IN: io.mmap.unix
-: open-r/w ( path -- fd ) O_RDWR file-mode open-file ;
-
-:: mmap-open ( path length prot flags -- alien fd )
+:: mmap-open ( path length prot flags open-mode -- alien fd )
[
f length prot flags
- path open-r/w [ <fd> |dispose drop ] keep
+ path open-mode file-mode open-file [ <fd> |dispose drop ] keep
[ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep
] with-destructors ;
-M: unix (mapped-file)
+M: unix (mapped-file-r/w)
{ PROT_READ PROT_WRITE } flags
{ MAP_FILE MAP_SHARED } flags
- mmap-open ;
+ O_RDWR mmap-open ;
+
+M: unix (mapped-file-reader)
+ { PROT_READ } flags
+ { MAP_FILE MAP_SHARED } flags
+ O_RDONLY mmap-open ;
M: unix close-mapped-file ( mmap -- )
[ [ address>> ] [ length>> ] bi munmap io-error ]
- [ handle>> close-file ]
- bi ;
+ [ handle>> close-file ] bi ;
diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor
index fcdf416511..8fdc7fefd9 100644
--- a/basis/io/mmap/windows/windows.factor
+++ b/basis/io/mmap/windows/windows.factor
@@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.mmap
io.ports io.backend.windows io.files.windows io.backend.windows.privileges
kernel libc math math.bitwise namespaces quotations sequences
windows windows.advapi32 windows.kernel32 io.backend system
-accessors locals ;
+accessors locals windows.errors ;
IN: io.mmap.windows
: create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
@@ -12,8 +12,8 @@ IN: io.mmap.windows
MapViewOfFile [ win32-error=0/f ] keep ;
:: mmap-open ( path length access-mode create-mode protect access -- handle handle address )
- [let | lo [ length HEX: ffffffff bitand ]
- hi [ length -32 shift HEX: ffffffff bitand ] |
+ [let | lo [ length 32 bits ]
+ hi [ length -32 shift 32 bits ] |
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
path access-mode create-mode 0 open-file |dispose
dup handle>> f protect hi lo f create-file-mapping |dispose
@@ -28,7 +28,7 @@ M: win32-mapped-file dispose
C: <win32-mapped-file> win32-mapped-file
-M: windows (mapped-file)
+M: windows (mapped-file-r/w)
[
{ GENERIC_WRITE GENERIC_READ } flags
OPEN_ALWAYS
@@ -37,6 +37,15 @@ M: windows (mapped-file)
-rot <win32-mapped-file>
] with-destructors ;
+M: windows (mapped-file-reader)
+ [
+ GENERIC_READ
+ OPEN_ALWAYS
+ { PAGE_READONLY SEC_COMMIT } flags
+ FILE_MAP_READ mmap-open
+ -rot <win32-mapped-file>
+ ] with-destructors ;
+
M: windows close-mapped-file ( mapped-file -- )
[
[ handle>> &dispose drop ]
diff --git a/basis/io/monitors/recursive/recursive-tests.factor b/basis/io/monitors/recursive/recursive-tests.factor
index ace93ace44..db8e02ae73 100644
--- a/basis/io/monitors/recursive/recursive-tests.factor
+++ b/basis/io/monitors/recursive/recursive-tests.factor
@@ -4,8 +4,6 @@ concurrency.mailboxes tools.test destructors io.files.info
io.pathnames io.files.temp io.directories.hierarchy ;
IN: io.monitors.recursive.tests
-\ pump-thread must-infer
-
SINGLETON: mock-io-backend
TUPLE: counter i ;
diff --git a/basis/io/monitors/windows/nt/nt-tests.factor b/basis/io/monitors/windows/nt/nt-tests.factor
index 79cd7e9e9f..a7ee649400 100644
--- a/basis/io/monitors/windows/nt/nt-tests.factor
+++ b/basis/io/monitors/windows/nt/nt-tests.factor
@@ -1,4 +1,4 @@
IN: io.monitors.windows.nt.tests
USING: io.monitors.windows.nt tools.test ;
-\ fill-queue-thread must-infer
+
diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor
index d2408a3dd1..bec249c04c 100755
--- a/basis/io/monitors/windows/nt/nt.factor
+++ b/basis/io/monitors/windows/nt/nt.factor
@@ -6,7 +6,7 @@ hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.backend.windows
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
io.buffers io.files io.timeouts io.encodings.string
-io.encodings.utf16n io windows windows.kernel32 windows.types
+io.encodings.utf16n io windows.errors windows.kernel32 windows.types
io.pathnames ;
IN: io.monitors.windows.nt
diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor
index 569366d4b8..b2d71fd535 100644
--- a/basis/io/ports/ports.factor
+++ b/basis/io/ports/ports.factor
@@ -189,4 +189,4 @@ HINTS: decoder-read-until { string input-port utf8 } { string input-port ascii }
HINTS: decoder-readln { input-port utf8 } { input-port ascii } ;
-HINTS: encoder-write { string output-port utf8 } { string output-port ascii } ;
+HINTS: encoder-write { object output-port utf8 } { object output-port ascii } ;
diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor
index ae79290f0a..ab99531eb4 100644
--- a/basis/io/servers/connection/connection-tests.factor
+++ b/basis/io/servers/connection/connection-tests.factor
@@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ;
dup start-server* sockets>> first addr>> port>> "port" set
] unit-test
-[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test
+[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop stream-contents ] unit-test
diff --git a/basis/io/sockets/secure/unix/unix-tests.factor b/basis/io/sockets/secure/unix/unix-tests.factor
index a3bfacc8a8..f87ad93fbd 100644
--- a/basis/io/sockets/secure/unix/unix-tests.factor
+++ b/basis/io/sockets/secure/unix/unix-tests.factor
@@ -5,7 +5,6 @@ io.backend.unix classes words destructors threads tools.test
concurrency.promises byte-arrays locals calendar io.timeouts
io.sockets.secure.unix.debug ;
-\ <secure-config> must-infer
{ 1 0 } [ [ ] with-secure-context ] must-infer-as
[ ] [ <promise> "port" set ] unit-test
@@ -24,7 +23,7 @@ io.sockets.secure.unix.debug ;
: client-test ( -- string )
<secure-config> [
- "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
+ "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop stream-contents
] with-secure-context ;
[ ] [ [ class name>> write ] server-test ] unit-test
diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor
index a66ed1d0c0..970aa34ea6 100644
--- a/basis/io/sockets/sockets-docs.factor
+++ b/basis/io/sockets/sockets-docs.factor
@@ -56,12 +56,23 @@ $nl
}
"The " { $link inet } " address specifier is not supported by the " { $link send } " word because a single host name can resolve to any number of IPv4 or IPv6 addresses, therefore there is no way to know which address should be used. Applications should call " { $link resolve-host } " then use some kind of strategy to pick the correct address (for example, by sending a packet to each one and waiting for a response, or always assuming IPv4)." ;
+ARTICLE: "network-examples" "Networking examples"
+"Send some bytes to a remote host:"
+{ $code
+ "USING: io io.encodings.ascii io.sockets strings ;"
+ "\"myhost\" 1033 <inet> ascii"
+ "[ B{ 12 17 102 } write ] with-client"
+}
+"Look up the IP addresses associated with a host name:"
+{ $code "USING: io.sockets ;" "\"www.apple.com\" 80 <inet> resolve-host ." } ;
+
ARTICLE: "network-streams" "Networking"
"Factor supports connection-oriented and packet-oriented communication over a variety of protocols:"
{ $list
"TCP/IP and UDP/IP, over IPv4 and IPv6"
"Unix domain sockets (Unix only)"
}
+{ $subsection "network-examples" }
{ $subsection "network-addressing" }
{ $subsection "network-connection" }
{ $subsection "network-packet" }
diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor
index 8dce527553..a0beb1f421 100644
--- a/basis/io/sockets/sockets.factor
+++ b/basis/io/sockets/sockets.factor
@@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local )
] with-destructors ;
: <client> ( remote encoding -- stream local )
- [ (client) -rot ] dip <encoder-duplex> swap ;
+ [ (client) ] dip swap [ <encoder-duplex> ] dip ;
SYMBOL: local-address
diff --git a/basis/io/streams/limited/limited-tests.factor b/basis/io/streams/limited/limited-tests.factor
index 36c257fb5e..86d652d17c 100644
--- a/basis/io/streams/limited/limited-tests.factor
+++ b/basis/io/streams/limited/limited-tests.factor
@@ -76,3 +76,9 @@ IN: io.streams.limited.tests
[ decoder? ] both?
] with-destructors
] unit-test
+
+[ "HELL" ] [
+ "HELLO"
+ [ f stream-throws limit-input 4 read ]
+ with-string-reader
+] unit-test
\ No newline at end of file
diff --git a/basis/io/streams/limited/limited.factor b/basis/io/streams/limited/limited.factor
index fe3dd9ad93..b1b07a08c0 100755
--- a/basis/io/streams/limited/limited.factor
+++ b/basis/io/streams/limited/limited.factor
@@ -22,7 +22,7 @@ M: decoder limit ( stream limit mode -- stream' )
[ clone ] 2dip '[ _ _ limit ] change-stream ;
M: object limit ( stream limit mode -- stream' )
- <limited-stream> ;
+ over [ <limited-stream> ] [ 2drop ] if ;
GENERIC: unlimited ( stream -- stream' )
@@ -32,9 +32,11 @@ M: decoder unlimited ( stream -- stream' )
M: object unlimited ( stream -- stream' )
stream>> stream>> ;
-: limit-input ( limit mode -- ) input-stream [ -rot limit ] change ;
+: limit-input ( limit mode -- )
+ [ input-stream ] 2dip '[ _ _ limit ] change ;
-: unlimited-input ( -- ) input-stream [ unlimited ] change ;
+: unlimited-input ( -- )
+ input-stream [ unlimited ] change ;
: with-unlimited-stream ( stream quot -- )
[ clone unlimited ] dip call ; inline
diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor
index a0087a70ee..85cb3022f5 100644
--- a/basis/io/streams/string/string.factor
+++ b/basis/io/streams/string/string.factor
@@ -33,5 +33,6 @@ M: sbuf stream-element-type drop +character+ ;
512 <sbuf> ;
: with-string-writer ( quot -- str )
- <string-writer> swap [ output-stream get ] compose with-output-stream*
- >string ; inline
\ No newline at end of file
+ <string-writer> [
+ swap with-output-stream*
+ ] keep >string ; inline
\ No newline at end of file
diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor
old mode 100644
new mode 100755
index ed45d5ccb9..8fcf12aae9
--- a/basis/io/styles/styles-docs.factor
+++ b/basis/io/styles/styles-docs.factor
@@ -1,17 +1,17 @@
USING: help.markup help.syntax io.streams.plain io strings
-hashtables kernel quotations colors ;
+hashtables kernel quotations colors assocs ;
IN: io.styles
HELP: stream-format
-{ $values { "str" string } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $values { "str" string } { "style" assoc } { "stream" "an output stream" } }
{ $contract "Writes formatted text to the stream. If the stream does buffering, output may not be performed immediately; use " { $link stream-flush } " to force output."
$nl
-"The " { $snippet "style" } " hashtable holds character style information. See " { $link "character-styles" } "." }
+"The " { $snippet "style" } " assoc holds character style information. See " { $link "character-styles" } "." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link format } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-block-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
@@ -21,7 +21,7 @@ $nl
$io-error ;
HELP: stream-write-table
-{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" "a hashtable" } { "stream" "an output stream" } }
+{ $values { "table-cells" "a sequence of sequences of table cells" } { "style" assoc } { "stream" "an output stream" } }
{ $contract "Prints a table of cells produced by " { $link with-cell } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
@@ -29,13 +29,13 @@ $nl
$io-error ;
HELP: make-cell-stream
-{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
+{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" object } }
{ $contract "Creates an output stream which writes to a table cell object." }
{ $notes "Most code only works on one stream at a time and should instead use " { $link with-cell } "; see " { $link "stdio" } "." }
$io-error ;
HELP: make-span-stream
-{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
+{ $values { "style" assoc } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
@@ -43,19 +43,19 @@ $nl
$io-error ;
HELP: format
-{ $values { "str" string } { "style" "a hashtable" } }
+{ $values { "str" string } { "style" assoc } }
{ $description "Writes formatted text to " { $link output-stream } ". If the stream does buffering, output may not be performed immediately; use " { $link flush } " to force output." }
{ $notes "Details are in the documentation for " { $link stream-format } "." }
$io-error ;
HELP: with-nesting
-{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $values { "style" assoc } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to a nested paragraph stream, with formatting information applied." }
{ $notes "Details are in the documentation for " { $link make-block-stream } "." }
$io-error ;
HELP: tabular-output
-{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $values { "style" assoc } { "quot" quotation } }
{ $description "Calls a quotation which emits a series of equal-length table rows using " { $link with-row } ". The results are laid out in a tabular fashion on " { $link output-stream } "."
$nl
"The " { $snippet "style" } " hashtable holds table style information. See " { $link "table-styles" } "." }
@@ -85,7 +85,7 @@ HELP: write-cell
$io-error ;
HELP: with-style
-{ $values { "style" "a hashtable" } { "quot" quotation } }
+{ $values { "style" assoc } { "quot" quotation } }
{ $description "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "." }
{ $notes "Details are in the documentation for " { $link make-span-stream } "." }
$io-error ;
@@ -274,7 +274,7 @@ HELP: <input>
{ $description "Creates a new " { $link input } "." } ;
HELP: standard-table-style
-{ $values { "style" hashtable } }
+{ $values { "value" hashtable } }
{ $description "Outputs a table style where cells are separated by 5-pixel gaps and framed by a light gray border. This style can be passed to " { $link tabular-output } "." } ;
ARTICLE: "io.streams.plain" "Plain writer streams"
diff --git a/basis/io/styles/styles-tests.factor b/basis/io/styles/styles-tests.factor
index 86c3681c2a..0259e4ab0b 100644
--- a/basis/io/styles/styles-tests.factor
+++ b/basis/io/styles/styles-tests.factor
@@ -1,8 +1,2 @@
IN: io.styles.tests
USING: io.styles tools.test ;
-
-\ stream-format must-infer
-\ stream-write-table must-infer
-\ make-span-stream must-infer
-\ make-block-stream must-infer
-\ make-cell-stream must-infer
\ No newline at end of file
diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor
index 89fe90b568..2d25016919 100644
--- a/basis/io/styles/styles.factor
+++ b/basis/io/styles/styles.factor
@@ -99,7 +99,11 @@ M: plain-writer make-block-stream
nip <ignore-close-stream> ;
M: plain-writer stream-write-table
- [ drop format-table [ nl ] [ write ] interleave ] with-output-stream* ;
+ [
+ drop
+ [ [ >string ] map ] map format-table
+ [ nl ] [ write ] interleave
+ ] with-output-stream* ;
M: plain-writer make-cell-stream 2drop <string-writer> ;
@@ -135,11 +139,11 @@ SYMBOL: wrap-margin
SYMBOL: table-gap
SYMBOL: table-border
-: standard-table-style ( -- style )
+CONSTANT: standard-table-style
H{
{ table-gap { 5 5 } }
{ table-border T{ rgba f 0.8 0.8 0.8 1.0 } }
- } ;
+ }
! Input history
TUPLE: input string ;
@@ -156,3 +160,5 @@ M: input summary
] "" make ;
: write-object ( str obj -- ) presented associate format ;
+
+: write-image ( image -- ) [ "" ] dip image associate format ;
diff --git a/basis/json/reader/reader.factor b/basis/json/reader/reader.factor
index 0014ba1eb1..887a7a50e5 100644
--- a/basis/json/reader/reader.factor
+++ b/basis/json/reader/reader.factor
@@ -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
diff --git a/basis/lcs/lcs-tests.factor b/basis/lcs/lcs-tests.factor
index 7d9a9ffd27..3aa10a0687 100644
--- a/basis/lcs/lcs-tests.factor
+++ b/basis/lcs/lcs-tests.factor
@@ -2,10 +2,6 @@
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lcs ;
-\ lcs must-infer
-\ diff must-infer
-\ levenshtein must-infer
-
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
diff --git a/basis/lcs/lcs.factor b/basis/lcs/lcs.factor
index 8c67590697..d32b199873 100644
--- a/basis/lcs/lcs.factor
+++ b/basis/lcs/lcs.factor
@@ -8,7 +8,7 @@ IN: lcs
0 1 ? + [ [ 1+ ] bi@ ] dip min min ;
: lcs-step ( insert delete change same? -- next )
- 1 -1./0. ? + max max ; ! -1./0. is -inf (float)
+ 1 -1/0. ? + max max ; ! -1/0. is -inf (float)
:: loop-step ( i j matrix old new step -- )
i j 1+ matrix nth nth ! insertion
diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor
index 014e096b1d..0f13b6dd86 100644
--- a/basis/listener/listener-docs.factor
+++ b/basis/listener/listener-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax kernel io system prettyprint ;
+USING: help.markup help.syntax kernel io system prettyprint continuations ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
@@ -41,32 +41,18 @@ $nl
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
{ $subsection "listener-watch" }
-"You can start a nested listener or exit a listener using the following words:"
+"To start a nested listener:"
{ $subsection listener }
-{ $subsection bye }
-"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
+"To exit the listener, invoke the " { $link return } " word."
+$nl
+"Multi-line quotations can be read independently of the rest of the listener:"
{ $subsection read-quot } ;
ABOUT: "listener"
-<PRIVATE
-
-HELP: quit-flag
-{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
-
-PRIVATE>
-
HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }
{ $description "Reads a Factor expression which possibly spans more than one line from " { $link input-stream } ". Additional lines of input are read while the parser stack height is greater than one. Since structural parsing words push partial quotations on the stack, this will keep on reading input until all delimited parsing words are terminated." } ;
-HELP: listen
-{ $description "Prompts for an expression on " { $link input-stream } " and evaluates it. On end of file, " { $link quit-flag } " is set to terminate the listener loop." }
-{ $errors "If the expression input by the user throws an error, the error is printed to " { $link output-stream } " and the word returns normally." } ;
-
HELP: listener
{ $description "Prompts for expressions on " { $link input-stream } " and evaluates them until end of file is reached." } ;
-
-HELP: bye
-{ $description "Exits the current listener." }
-{ $notes "This word is for interactive use only. To exit the Factor runtime, use " { $link exit } "." } ;
diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor
index 0616794939..7ed082234a 100644
--- a/basis/listener/listener-tests.factor
+++ b/basis/listener/listener-tests.factor
@@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ;
"\\ + 1 2 3 4" parse-interactive
"cont" get continue-with
] ignore-errors
- "USE: debugger :1" eval
+ "USE: debugger :1" eval( -- quot )
] callcc1
] unit-test
] with-file-vocabs
@@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ;
[
[ ] [
- "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
+ "IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive
drop
] unit-test
] with-file-vocabs
diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor
index 4f7ccf227e..68777f2f73 100644
--- a/basis/listener/listener.factor
+++ b/basis/listener/listener.factor
@@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors prettyprint fry
-sets vocabs.parser ;
+sets vocabs.parser source-files.errors locals ;
IN: listener
GENERIC: stream-read-quot ( stream -- quot/f )
@@ -32,17 +32,9 @@ M: object stream-read-quot
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
-<PRIVATE
-
-SYMBOL: quit-flag
-
-PRIVATE>
-
-: bye ( -- ) quit-flag on ;
-
SYMBOL: visible-vars
-: show-var ( var -- ) visible-vars [ swap suffix ] change ;
+: show-var ( var -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
@@ -68,6 +60,10 @@ SYMBOL: max-stack-items
10 max-stack-items set-global
+SYMBOL: error-summary?
+
+t error-summary? set-global
+
<PRIVATE
: title. ( string -- )
@@ -96,26 +92,39 @@ SYMBOL: max-stack-items
] dip
] when stack. ;
-: stacks. ( -- )
+: datastack. ( datastack -- )
display-stacks? get [
- datastack [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
- ] when ;
+ [ nl "--- Data stack:" title. trimmed-stack. ] unless-empty
+ ] [ drop ] if ;
: prompt. ( -- )
- "( " in get auto-use? get [ " - auto" append ] when " )" 3append
+ in get auto-use? get [ " - auto" append ] when "( " " )" surround
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
-: listen ( -- )
- visible-vars. stacks. prompt.
- [ read-quot [ [ call-error-hook ] recover ] [ bye ] if* ]
- [ dup lexer-error? [ call-error-hook ] [ rethrow ] if ] recover ;
+:: (listener) ( datastack -- )
+ error-summary? get [ error-summary ] when
+ visible-vars.
+ datastack datastack.
+ prompt.
-: until-quit ( -- )
- quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
+ [
+ read-quot [
+ '[ datastack _ with-datastack ]
+ [ call-error-hook datastack ]
+ recover
+ ] [ return ] if*
+ ] [
+ dup lexer-error?
+ [ call-error-hook datastack ]
+ [ rethrow ]
+ if
+ ] recover
+
+ (listener) ;
PRIVATE>
: listener ( -- )
- [ until-quit ] with-interactive-vocabs ;
+ [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
MAIN: listener
diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor
index 4b0abb7f2d..fecb76f1c0 100644
--- a/basis/lists/lists.factor
+++ b/basis/lists/lists.factor
@@ -106,7 +106,8 @@ PRIVATE>
: deep-sequence>cons ( sequence -- cons )
[ <reversed> ] keep nil
- [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
+ [ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
+ with reduce ;
<PRIVATE
:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )
diff --git a/extra/literals/authors.txt b/basis/literals/authors.txt
similarity index 100%
rename from extra/literals/authors.txt
rename to basis/literals/authors.txt
diff --git a/extra/literals/literals-docs.factor b/basis/literals/literals-docs.factor
similarity index 100%
rename from extra/literals/literals-docs.factor
rename to basis/literals/literals-docs.factor
diff --git a/extra/literals/literals-tests.factor b/basis/literals/literals-tests.factor
similarity index 85%
rename from extra/literals/literals-tests.factor
rename to basis/literals/literals-tests.factor
index 024c94e4f2..29072f1299 100644
--- a/extra/literals/literals-tests.factor
+++ b/basis/literals/literals-tests.factor
@@ -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
diff --git a/extra/literals/literals.factor b/basis/literals/literals.factor
similarity index 52%
rename from extra/literals/literals.factor
rename to basis/literals/literals.factor
index e55d78ab6e..7c7592dda8 100644
--- a/extra/literals/literals.factor
+++ b/basis/literals/literals.factor
@@ -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 ;
diff --git a/extra/literals/summary.txt b/basis/literals/summary.txt
similarity index 100%
rename from extra/literals/summary.txt
rename to basis/literals/summary.txt
diff --git a/extra/literals/tags.txt b/basis/literals/tags.txt
similarity index 100%
rename from extra/literals/tags.txt
rename to basis/literals/tags.txt
diff --git a/basis/locals/backend/backend-tests.factor b/basis/locals/backend/backend-tests.factor
index ee714f7ef7..ad78516059 100644
--- a/basis/locals/backend/backend-tests.factor
+++ b/basis/locals/backend/backend-tests.factor
@@ -1,14 +1,14 @@
IN: locals.backend.tests
-USING: tools.test locals.backend kernel arrays ;
+USING: tools.test locals.backend kernel arrays accessors ;
: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
-\ get-local-test-1 must-infer
+\ get-local-test-1 def>> must-infer
[ 3 ] [ get-local-test-1 ] unit-test
: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
-\ get-local-test-2 must-infer
+\ get-local-test-2 def>> must-infer
[ 3 ] [ get-local-test-2 ] unit-test
diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor
index 18dabed4b0..b1f0b6ca17 100644
--- a/basis/locals/locals-docs.factor
+++ b/basis/locals/locals-docs.factor
@@ -112,7 +112,15 @@ HELP: MEMO::
{ $description "Defines a memoized word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." } ;
{ POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
+
+HELP: M::
+{ $syntax "M:: class generic ( bindings... -- outputs... ) body... ;" }
+{ $description "Defines a method with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope." }
+{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ;
+{ POSTPONE: M: POSTPONE: M:: } related-words
+
+
ARTICLE: "locals-literals" "Locals in literals"
"Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
$nl
@@ -237,13 +245,14 @@ $nl
}
"The reason is that locals are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to local transformation, however "{ $vocab-link "macros.expander" } " does not deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ;
-ARTICLE: "locals" "Local variables and lexical closures"
+ARTICLE: "locals" "Lexical variables and closures"
"The " { $vocab-link "locals" } " vocabulary implements lexical scope with full closures, both downward and upward. Mutable bindings are supported, including assignment to bindings in outer scope."
$nl
"Compile-time transformation is used to compile local variables to efficient code; prettyprinter extensions are defined so that " { $link see } " can display original word definitions with local variables and not the closure-converted concatenative code which results."
$nl
"Applicative word definitions where the inputs are named local variables:"
{ $subsection POSTPONE: :: }
+{ $subsection POSTPONE: M:: }
{ $subsection POSTPONE: MEMO:: }
{ $subsection POSTPONE: MACRO:: }
"Lexical binding forms:"
diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
index 8e61e39faf..1549a77663 100644
--- a/basis/locals/locals-tests.factor
+++ b/basis/locals/locals-tests.factor
@@ -43,8 +43,8 @@ IN: locals.tests
[ { 1 2 } ] [ 2 let-test-4 ] unit-test
-:: let-test-5 ( a -- b )
- a [let | a [ ] b [ ] | a b 2array ] ;
+:: let-test-5 ( a b -- b )
+ a b [let | a [ ] b [ ] | a b 2array ] ;
[ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
@@ -129,7 +129,8 @@ write-test-2 "q" set
SYMBOL: a
:: use-test ( a b c -- a b c )
- USE: kernel ;
+ USE: kernel
+ a b c ;
[ t ] [ a symbol? ] unit-test
@@ -171,9 +172,9 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
[ ] [ \ lambda-generic see ] unit-test
-:: unparse-test-1 ( a -- ) [let | a! [ ] | ] ;
+:: unparse-test-1 ( a -- ) [let | a! [ 3 ] | ] ;
-[ "[let | a! [ ] | ]" ] [
+[ "[let | a! [ 3 ] | ]" ] [
\ unparse-test-1 "lambda" word-prop body>> first unparse
] unit-test
@@ -261,7 +262,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
-[ ] [ new-definition eval ] unit-test
+[ ] [ new-definition eval( -- ) ] unit-test
[ t ] [
[ \ a-word-with-locals see ] with-string-writer
@@ -286,7 +287,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ [ a b > ] [ 5 ] }
} cond ;
-\ cond-test must-infer
+\ cond-test def>> must-infer
[ 3 ] [ 1 2 cond-test ] unit-test
[ 4 ] [ 2 2 cond-test ] unit-test
@@ -295,7 +296,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
:: 0&&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
-\ 0&&-test must-infer
+\ 0&&-test def>> must-infer
[ f ] [ 1.5 0&&-test ] unit-test
[ f ] [ 3 0&&-test ] unit-test
@@ -305,7 +306,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
:: &&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
-\ &&-test must-infer
+\ &&-test def>> must-infer
[ f ] [ 1.5 &&-test ] unit-test
[ f ] [ 3 &&-test ] unit-test
@@ -321,7 +322,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
]
] ;
-\ let-and-cond-test-1 must-infer
+\ let-and-cond-test-1 def>> must-infer
[ 20 ] [ let-and-cond-test-1 ] unit-test
@@ -332,7 +333,7 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
]
] ;
-\ let-and-cond-test-2 must-infer
+\ let-and-cond-test-2 def>> must-infer
[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
@@ -388,7 +389,7 @@ ERROR: punned-class x ;
{ 5 [ a a ^ ] }
} case ;
-\ big-case-test must-infer
+\ big-case-test def>> must-infer
[ 9 ] [ 3 big-case-test ] unit-test
@@ -400,7 +401,7 @@ ERROR: punned-class x ;
[| x | x 12 + { "howdy" } nth ]
} case ;
-\ littledan-case-problem-1 must-infer
+\ littledan-case-problem-1 def>> must-infer
[ "howdy" ] [ -12 \ littledan-case-problem-1 def>> call ] unit-test
[ "howdy" ] [ -12 littledan-case-problem-1 ] unit-test
@@ -412,7 +413,7 @@ ERROR: punned-class x ;
[| x | x a - { "howdy" } nth ]
} case ;
-\ littledan-case-problem-2 must-infer
+\ littledan-case-problem-2 def>> must-infer
[ "howdy" ] [ -12 \ littledan-case-problem-2 def>> call ] unit-test
[ "howdy" ] [ -12 littledan-case-problem-2 ] unit-test
@@ -424,7 +425,7 @@ ERROR: punned-class x ;
[| x | x a - { "howdy" } nth ]
} cond ;
-\ littledan-cond-problem-1 must-infer
+\ littledan-cond-problem-1 def>> must-infer
[ f ] [ -12 \ littledan-cond-problem-1 def>> call ] unit-test
[ 4 ] [ 12 \ littledan-cond-problem-1 def>> call ] unit-test
@@ -448,62 +449,62 @@ ERROR: punned-class x ;
: littledan-case-problem-4 ( a -- b )
[ 1 + ] littledan-case-problem-3 ;
-\ littledan-case-problem-4 must-infer
+\ littledan-case-problem-4 def>> must-infer
*/
GENERIC: lambda-method-forget-test ( a -- b )
-M:: integer lambda-method-forget-test ( a -- b ) ;
+M:: integer lambda-method-forget-test ( a -- b ) a ;
-[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
+[ ] [ [ M\ integer lambda-method-forget-test forget ] with-compilation-unit ] unit-test
[ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
[
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
- eval call
+ eval( -- ) call
] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
-\ funny-macro-test must-infer
+\ funny-macro-test def>> must-infer
[ t ] [ 3 funny-macro-test ] unit-test
[ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases
-[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
:: FAILdog-1 ( -- b ) { [| c | c ] } ;
-\ FAILdog-1 must-infer
+\ FAILdog-1 def>> must-infer
:: FAILdog-2 ( a -- b ) a { [| c | c ] } cond ;
-\ FAILdog-2 must-infer
+\ FAILdog-2 def>> must-infer
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
-[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail
+[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
-[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail
+[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
-[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail
+[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
-[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail
+[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
-[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
+[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
-[ "USE: locals [| | { :> a } ]" eval ] must-fail
+[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
-[ "USE: locals 3 :> a" eval ] must-fail
+[ "USE: locals 3 :> a" eval( -- ) ] must-fail
[ 3 ] [ 3 [| | :> a a ] call ] unit-test
@@ -518,7 +519,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
] ;
-\ wlet-&&-test must-infer
+\ wlet-&&-test def>> must-infer
[ f ] [ 1.5 wlet-&&-test ] unit-test
[ f ] [ 3 wlet-&&-test ] unit-test
[ f ] [ 8 wlet-&&-test ] unit-test
@@ -527,13 +528,13 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
: fry-locals-test-1 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
-\ fry-locals-test-1 must-infer
+\ fry-locals-test-1 def>> must-infer
[ 10 ] [ fry-locals-test-1 ] unit-test
:: fry-locals-test-2 ( -- n )
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
-\ fry-locals-test-2 must-infer
+\ fry-locals-test-2 def>> must-infer
[ 10 ] [ fry-locals-test-2 ] unit-test
[ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
@@ -584,4 +585,4 @@ M: integer ed's-bug neg ;
:: ed's-test-case ( a -- b )
{ [ a ed's-bug ] } && ;
-[ t ] [ \ ed's-test-case optimized>> ] unit-test
\ No newline at end of file
+[ t ] [ \ ed's-test-case optimized? ] unit-test
diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor
old mode 100644
new mode 100755
index acd2c3383f..6a4672bea0
--- a/basis/macros/macros-docs.factor
+++ b/basis/macros/macros-docs.factor
@@ -49,6 +49,7 @@ $nl
{ $subsection POSTPONE: MACRO: }
"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion."
{ $subsection define-transform }
-"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ;
+"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated."
+{ $see-also "generalizations" "fry" } ;
ABOUT: "macros"
diff --git a/basis/macros/macros-tests.factor b/basis/macros/macros-tests.factor
index 91aa6880e6..bf483f72ea 100644
--- a/basis/macros/macros-tests.factor
+++ b/basis/macros/macros-tests.factor
@@ -13,11 +13,11 @@ unit-test
[ t ] [ \ see-test macro? ] unit-test
[ t ] [
- "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval
+ "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- )
[ \ see-test see ] with-string-writer =
] unit-test
[ f ] [ \ see-test macro? ] unit-test
-[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test
+[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor
index a86b711340..0e5ef30f51 100644
--- a/basis/macros/macros.factor
+++ b/basis/macros/macros.factor
@@ -12,10 +12,11 @@ IN: macros
PRIVATE>
: define-macro ( word definition effect -- )
- real-macro-effect
- [ [ memoize-quot [ call ] append ] keep define-declared ]
- [ drop "macro" set-word-prop ]
- 3bi ;
+ real-macro-effect {
+ [ [ memoize-quot [ call ] append ] keep define-declared ]
+ [ drop "macro" set-word-prop ]
+ [ 2drop changed-effect ]
+ } 3cleave ;
SYNTAX: MACRO: (:) define-macro ;
diff --git a/basis/match/match.factor b/basis/match/match.factor
index b21d8c6d73..ec0cb8c9e6 100644
--- a/basis/match/match.factor
+++ b/basis/match/match.factor
@@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- )
} cond ;
: match-replace ( object pattern1 pattern2 -- result )
- -rot
- match [ "Pattern does not match" throw ] unless*
+ [ match [ "Pattern does not match" throw ] unless* ] dip swap
[ replace-patterns ] bind ;
: ?1-tail ( seq -- tail/f )
diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor
index 7698760f84..e10853af18 100644
--- a/basis/math/bitwise/bitwise-tests.factor
+++ b/basis/math/bitwise/bitwise-tests.factor
@@ -26,7 +26,7 @@ CONSTANT: b 2
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
-\ foo must-infer
+\ foo def>> must-infer
[ 1 ] [ { 1 } flags ] unit-test
diff --git a/basis/math/blas/config/config.factor b/basis/math/blas/config/config.factor
index 8ed515625d..09f736c036 100644
--- a/basis/math/blas/config/config.factor
+++ b/basis/math/blas/config/config.factor
@@ -15,9 +15,10 @@ blas-fortran-abi [
{
{ [ os macosx? ] [ intel-unix-abi ] }
{ [ os windows? cpu x86.32? and ] [ f2c-abi ] }
+ { [ os netbsd? cpu x86.64? and ] [ g95-abi ] }
{ [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
{ [ os freebsd? ] [ gfortran-abi ] }
- { [ os linux? cpu x86.32? and ] [ gfortran-abi ] }
+ { [ os linux? ] [ gfortran-abi ] }
[ f2c-abi ]
} cond
] initialize
diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor
index 6b6f5c95bd..a51b86ff0b 100644
--- a/basis/math/complex/complex-docs.factor
+++ b/basis/math/complex/complex-docs.factor
@@ -25,7 +25,3 @@ HELP: complex
{ $class-description "The class of complex numbers with non-zero imaginary part." } ;
ABOUT: "complex-numbers"
-
-HELP: <complex> ( x y -- z )
-{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } }
-{ $description "Low-level complex number constructor. User code should call " { $link rect> } " instead." } ;
diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor
index c41faaf558..832a9e64ba 100644
--- a/basis/math/complex/complex.factor
+++ b/basis/math/complex/complex.factor
@@ -15,14 +15,14 @@ M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ;
: complex= ( x y quot -- ? ) componentwise and ; inline
M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ;
M: complex number= [ number= ] complex= ;
-: complex-op ( x y quot -- z ) componentwise (rect>) ; inline
+: complex-op ( x y quot -- z ) componentwise rect> ; inline
M: complex + [ + ] complex-op ;
M: complex - [ - ] complex-op ;
: *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline
: *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline
-M: complex * [ *re - ] [ *im + ] 2bi (rect>) ;
+M: complex * [ *re - ] [ *im + ] 2bi rect> ;
: (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
-: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ (rect>) ; inline
+: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline
M: complex / [ / ] complex/ ;
M: complex /f [ /f ] complex/ ;
M: complex /i [ /i ] complex/ ;
diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor
index f7d0d5a941..48da8aa6ec 100644
--- a/basis/math/functions/functions-docs.factor
+++ b/basis/math/functions/functions-docs.factor
@@ -100,11 +100,6 @@ ARTICLE: "math-functions" "Mathematical functions"
ABOUT: "math-functions"
-HELP: (rect>)
-{ $values { "x" real } { "y" real } { "z" number } }
-{ $description "Creates a complex number from real and imaginary components." }
-{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ;
-
HELP: rect>
{ $values { "x" real } { "y" real } { "z" number } }
{ $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ;
diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor
index 4c9d151fd8..397a7cc2f3 100644
--- a/basis/math/functions/functions-tests.factor
+++ b/basis/math/functions/functions-tests.factor
@@ -22,9 +22,9 @@ IN: math.functions.tests
[ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
[ t ] [ 0 0 ^ fp-nan? ] unit-test
-[ 1.0/0.0 ] [ 0 -2 ^ ] unit-test
+[ 1/0. ] [ 0 -2 ^ ] unit-test
[ t ] [ 0 0.0 ^ fp-nan? ] unit-test
-[ 1.0/0.0 ] [ 0 -2.0 ^ ] unit-test
+[ 1/0. ] [ 0 -2.0 ^ ] unit-test
[ 0 ] [ 0 3.0 ^ ] unit-test
[ 0 ] [ 0 3 ^ ] unit-test
diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index 1eac321e3b..c21053317e 100644
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -7,19 +7,8 @@ IN: math.functions
: >fraction ( a/b -- a b )
[ numerator ] [ denominator ] bi ; inline
-<PRIVATE
-
-: (rect>) ( x y -- z )
- dup 0 = [ drop ] [ <complex> ] if ; inline
-
-PRIVATE>
-
: rect> ( x y -- z )
- 2dup [ real? ] both? [
- (rect>)
- ] [
- "Complex number must have real components" throw
- ] if ; inline
+ dup 0 = [ drop ] [ complex boa ] if ; inline
GENERIC: sqrt ( x -- y ) foldable
@@ -81,7 +70,7 @@ PRIVATE>
2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
: 0^ ( x -- z )
- dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
+ dup zero? [ drop 0/0. ] [ 0 < 1/0. 0 ? ] if ; inline
: (^mod) ( n x y -- z )
make-bits 1 [
diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor
index 378ca2fb4b..2b8b3dff24 100644
--- a/basis/math/intervals/intervals-tests.factor
+++ b/basis/math/intervals/intervals-tests.factor
@@ -255,11 +255,11 @@ IN: math.intervals.tests
0 pick interval-contains? over first \ recip eq? and [
2drop t
] [
- [ [ random-element ] dip first execute ] 2keep
- second execute interval-contains?
+ [ [ random-element ] dip first execute( a -- b ) ] 2keep
+ second execute( a -- b ) interval-contains?
] if ;
-[ t ] [ 80000 [ drop unary-test ] all? ] unit-test
+[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test
: random-binary-op ( -- pair )
{
@@ -286,11 +286,11 @@ IN: math.intervals.tests
0 pick interval-contains? over first { / /i mod rem } member? and [
3drop t
] [
- [ [ [ random-element ] bi@ ] dip first execute ] 3keep
- second execute interval-contains?
+ [ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep
+ second execute( a b -- c ) interval-contains?
] if ;
-[ t ] [ 80000 [ drop binary-test ] all? ] unit-test
+[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test
: random-comparison ( -- pair )
{
@@ -302,10 +302,10 @@ IN: math.intervals.tests
: comparison-test ( -- ? )
random-interval random-interval random-comparison
- [ [ [ random-element ] bi@ ] dip first execute ] 3keep
- second execute dup incomparable eq? [ 2drop t ] [ = ] if ;
+ [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep
+ second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ;
-[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test
+[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test
[ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test
@@ -322,7 +322,7 @@ IN: math.intervals.tests
[ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test
! Test that commutative interval ops really are
-: random-interval-or-empty ( -- )
+: random-interval-or-empty ( -- obj )
10 random 0 = [ empty-interval ] [ random-interval ] if ;
: random-commutative-op ( -- op )
@@ -333,7 +333,7 @@ IN: math.intervals.tests
} random ;
[ t ] [
- 80000 [
+ 80000 iota [
drop
random-interval-or-empty random-interval-or-empty
random-commutative-op
diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor
index 4fbc880971..02ea181f4e 100755
--- a/basis/math/intervals/intervals.factor
+++ b/basis/math/intervals/intervals.factor
@@ -40,13 +40,13 @@ TUPLE: interval { from read-only } { to read-only } ;
: [a,a] ( a -- interval )
closed-point dup <interval> ; foldable
-: [-inf,a] ( a -- interval ) -1./0. swap [a,b] ; inline
+: [-inf,a] ( a -- interval ) -1/0. swap [a,b] ; inline
-: [-inf,a) ( a -- interval ) -1./0. swap [a,b) ; inline
+: [-inf,a) ( a -- interval ) -1/0. swap [a,b) ; inline
-: [a,inf] ( a -- interval ) 1./0. [a,b] ; inline
+: [a,inf] ( a -- interval ) 1/0. [a,b] ; inline
-: (a,inf] ( a -- interval ) 1./0. (a,b] ; inline
+: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
: [-inf,inf] ( -- interval ) full-interval ; inline
diff --git a/basis/math/libm/libm-docs.factor b/basis/math/libm/libm-docs.factor
index bf4c608d77..a890a59c19 100644
--- a/basis/math/libm/libm-docs.factor
+++ b/basis/math/libm/libm-docs.factor
@@ -6,7 +6,7 @@ ARTICLE: "math.libm" "C standard library math functions"
$nl
"They can be called directly, however there is little reason to do so, since they only implement real-valued functions, and in some cases place restrictions on the domain:"
{ $example "USE: math.functions" "2 acos ." "C{ 0.0 1.316957896924817 }" }
-{ $unchecked-example "USE: math.libm" "2 facos ." "0.0/0.0" }
+{ $unchecked-example "USE: math.libm" "2 facos ." "0/0." }
"Trigonometric functions:"
{ $subsection fcos }
{ $subsection fsin }
diff --git a/basis/tools/vocabs/monitor/authors.txt b/basis/math/matrices/authors.txt
similarity index 100%
rename from basis/tools/vocabs/monitor/authors.txt
rename to basis/math/matrices/authors.txt
diff --git a/core/compiler/errors/authors.txt b/basis/math/matrices/elimination/authors.txt
old mode 100755
new mode 100644
similarity index 100%
rename from core/compiler/errors/authors.txt
rename to basis/math/matrices/elimination/authors.txt
diff --git a/extra/math/matrices/elimination/elimination-tests.factor b/basis/math/matrices/elimination/elimination-tests.factor
similarity index 100%
rename from extra/math/matrices/elimination/elimination-tests.factor
rename to basis/math/matrices/elimination/elimination-tests.factor
diff --git a/extra/math/matrices/elimination/elimination.factor b/basis/math/matrices/elimination/elimination.factor
similarity index 100%
rename from extra/math/matrices/elimination/elimination.factor
rename to basis/math/matrices/elimination/elimination.factor
diff --git a/extra/math/matrices/elimination/summary.txt b/basis/math/matrices/elimination/summary.txt
similarity index 100%
rename from extra/math/matrices/elimination/summary.txt
rename to basis/math/matrices/elimination/summary.txt
diff --git a/extra/math/matrices/matrices-tests.factor b/basis/math/matrices/matrices-tests.factor
similarity index 100%
rename from extra/math/matrices/matrices-tests.factor
rename to basis/math/matrices/matrices-tests.factor
diff --git a/extra/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor
similarity index 92%
rename from extra/math/matrices/matrices.factor
rename to basis/math/matrices/matrices.factor
index 7c687d753d..cfdbe17c06 100755
--- a/extra/math/matrices/matrices.factor
+++ b/basis/math/matrices/matrices.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.vectors sequences ;
+USING: arrays kernel math math.order math.vectors
+sequences sequences.private accessors columns ;
IN: math.matrices
! Matrices
diff --git a/extra/math/matrices/summary.txt b/basis/math/matrices/summary.txt
similarity index 100%
rename from extra/math/matrices/summary.txt
rename to basis/math/matrices/summary.txt
diff --git a/basis/math/quaternions/quaternions-docs.factor b/basis/math/quaternions/quaternions-docs.factor
index bb34ec8da2..a24011cb7c 100644
--- a/basis/math/quaternions/quaternions-docs.factor
+++ b/basis/math/quaternions/quaternions-docs.factor
@@ -1,6 +1,16 @@
USING: help.markup help.syntax math math.vectors vectors ;
IN: math.quaternions
+HELP: q+
+{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u+v" "a quaternion" } }
+{ $description "Add quaternions." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q+ ." "{ C{ 0 1 } 1 }" } } ;
+
+HELP: q-
+{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u-v" "a quaternion" } }
+{ $description "Subtract quaternions." }
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q- ." "{ C{ 0 1 } -1 }" } } ;
+
HELP: q*
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } }
{ $description "Multiply quaternions." }
diff --git a/basis/math/quaternions/quaternions-tests.factor b/basis/math/quaternions/quaternions-tests.factor
index a6d255e421..3efc417e42 100644
--- a/basis/math/quaternions/quaternions-tests.factor
+++ b/basis/math/quaternions/quaternions-tests.factor
@@ -24,3 +24,7 @@ math.constants ;
[ t ] [ qk q>v v>q qk = ] unit-test
[ t ] [ 1 c>q q1 = ] unit-test
[ t ] [ C{ 0 1 } c>q qi = ] unit-test
+[ t ] [ qi qi q+ qi 2 q*n = ] unit-test
+[ t ] [ qi qi q- q0 = ] unit-test
+[ t ] [ qi qj q+ qj qi q+ = ] unit-test
+[ t ] [ qi qj q- qj qi q- -1 q*n = ] unit-test
diff --git a/basis/math/quaternions/quaternions.factor b/basis/math/quaternions/quaternions.factor
index f2c2c6d226..b713f44ebd 100755
--- a/basis/math/quaternions/quaternions.factor
+++ b/basis/math/quaternions/quaternions.factor
@@ -20,6 +20,12 @@ IN: math.quaternions
PRIVATE>
+: q+ ( u v -- u+v )
+ v+ ;
+
+: q- ( u v -- u-v )
+ v- ;
+
: q* ( u v -- u*v )
[ q*a ] [ q*b ] 2bi 2array ;
diff --git a/basis/math/ranges/ranges-docs.factor b/basis/math/ranges/ranges-docs.factor
index 8987def80b..e35adb10e5 100644
--- a/basis/math/ranges/ranges-docs.factor
+++ b/basis/math/ranges/ranges-docs.factor
@@ -2,7 +2,7 @@ USING: help.syntax help.markup arrays sequences ;
IN: math.ranges
-ARTICLE: "ranges" "Ranges"
+ARTICLE: "math.ranges" "Numeric ranges"
"A " { $emphasis "range" } " is a virtual sequence with real number elements "
"ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } ". Ascending as well as descending ranges are supported."
$nl
@@ -24,4 +24,4 @@ $nl
{ $code "100 1 [a,b] product" }
"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
-ABOUT: "ranges"
\ No newline at end of file
+ABOUT: "math.ranges"
\ No newline at end of file
diff --git a/basis/math/ratios/ratios-docs.factor b/basis/math/ratios/ratios-docs.factor
index 7b6393dabe..2e51fa1870 100644
--- a/basis/math/ratios/ratios-docs.factor
+++ b/basis/math/ratios/ratios-docs.factor
@@ -47,6 +47,3 @@ HELP: 2>fraction
{ $values { "a/b" rational } { "c/d" rational } { "a" integer } { "c" integer } { "b" "a positive integer" } { "d" "a positive integer" } }
{ $description "Extracts the numerator and denominator of two rational numbers at once." } ;
-HELP: <ratio> ( a b -- a/b )
-{ $values { "a" integer } { "b" integer } { "a/b" "a ratio" } }
-{ $description "Primitive ratio constructor. User code should call " { $link / } " to create ratios instead." } ;
diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor
index 54e4bee1a8..d4f457180e 100644
--- a/basis/math/ratios/ratios.factor
+++ b/basis/math/ratios/ratios.factor
@@ -9,7 +9,7 @@ IN: math.ratios
<PRIVATE
: fraction> ( a b -- a/b )
- dup 1 number= [ drop ] [ <ratio> ] if ; inline
+ dup 1 number= [ drop ] [ ratio boa ] if ; inline
: scale ( a/b c/d -- a*d b*c )
2>fraction [ * swap ] dip * swap ; inline
diff --git a/basis/math/rectangles/rectangles-tests.factor b/basis/math/rectangles/rectangles-tests.factor
index ca722859d2..7959d98f92 100644
--- a/basis/math/rectangles/rectangles-tests.factor
+++ b/basis/math/rectangles/rectangles-tests.factor
@@ -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
\ No newline at end of file
+] unit-test
diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor
index 1d9c91328f..90174d144e 100644
--- a/basis/math/rectangles/rectangles.factor
+++ b/basis/math/rectangles/rectangles.factor
@@ -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
\ No newline at end of file
+ 2bi ; inline
diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor
index cfb5cffb37..a551272f43 100644
--- a/basis/memoize/memoize-docs.factor
+++ b/basis/memoize/memoize-docs.factor
@@ -3,6 +3,20 @@
USING: help.syntax help.markup words quotations effects ;
IN: memoize
+ARTICLE: "memoize" "Memoization"
+"The " { $vocab-link "memoize" } " vocabulary implements a simple form of memoization, which is when a word caches results for every unique set of inputs that is supplied. Calling a memoized word with the same inputs more than once does not recalculate anything."
+$nl
+"Memoization is useful in situations where the set of possible inputs is small, but the results are expensive to compute and should be cached. Memoized words should not have any side effects."
+$nl
+"Defining a memoized word at parse time:"
+{ $subsection POSTPONE: MEMO: }
+"Defining a memoized word at run time:"
+{ $subsection define-memoized }
+"Clearing memoized results:"
+{ $subsection reset-memoized } ;
+
+ABOUT: "memoize"
+
HELP: define-memoized
{ $values { "word" word } { "quot" quotation } { "effect" effect } }
{ $description "defines the given word at runtime as one which memoizes its output given a particular input" }
diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor
index 54378bd37e..d82abe5b07 100644
--- a/basis/memoize/memoize-tests.factor
+++ b/basis/memoize/memoize-tests.factor
@@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test
-[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail
+[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
MEMO: see-test ( a -- b ) reverse ;
@@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ;
[ [ \ see-test see ] with-string-writer ]
unit-test
-[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test
+[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test
[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test
diff --git a/basis/memoize/memoize.factor b/basis/memoize/memoize.factor
index 4e10fc3de4..74ca07cda3 100644
--- a/basis/memoize/memoize.factor
+++ b/basis/memoize/memoize.factor
@@ -61,3 +61,5 @@ M: memoized reset-word
: invalidate-memoized ( inputs... word -- )
[ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
+
+\ invalidate-memoized t "no-compile" set-word-prop
\ No newline at end of file
diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor
index 0edfb05a30..0cf7556bcd 100755
--- a/basis/mime/multipart/multipart.factor
+++ b/basis/mime/multipart/multipart.factor
@@ -137,9 +137,6 @@ ERROR: no-content-disposition multipart ;
[ no-content-disposition ]
} case ;
-: assert-sequence= ( a b -- )
- 2dup sequence= [ 2drop ] [ assert ] if ;
-
: read-assert-sequence= ( sequence -- )
[ length read ] keep assert-sequence= ;
diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor
index aad033600a..ed1f423bb0 100644
--- a/basis/mirrors/mirrors-tests.factor
+++ b/basis/mirrors/mirrors-tests.factor
@@ -56,6 +56,6 @@ TUPLE: color
! Test reshaping with a mirror
1 2 3 color boa <mirror> "mirror" set
-[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test
+[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test
[ 1 ] [ "red" "mirror" get at ] unit-test
diff --git a/basis/models/arrow/smart/authors.txt b/basis/models/arrow/smart/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/models/arrow/smart/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/models/arrow/smart/smart-docs.factor b/basis/models/arrow/smart/smart-docs.factor
new file mode 100644
index 0000000000..3cc22d8d40
--- /dev/null
+++ b/basis/models/arrow/smart/smart-docs.factor
@@ -0,0 +1,21 @@
+IN: models.arrow.smart
+USING: help.syntax help.markup models.product ;
+
+HELP: <smart-arrow>
+{ $values { "quot" { $quotation "( ... -- output )" } } }
+{ $description "A macro that expands into a form with the stack effect of the quotation. The form constructs a model which applies the quotation to values from an underlying " { $link product } " model having as many components as the quotation has inputs." }
+{ $examples
+ "A model which adds the values of two existing models:"
+ { $example
+ "USING: models models.arrow.smart accessors kernel math prettyprint ;"
+ "1 <model> 2 <model> [ + ] <smart-arrow>"
+ "[ activate-model ] [ value>> ] bi ."
+ "3"
+ }
+} ;
+
+ARTICLE: "models.arrow.smart" "Smart arrow models"
+"The " { $vocab-link "models.arrow.smart" } " vocabulary generalizes arrows to arbitrary input arity. They're called “smart” because they resemble " { $link "combinators.smart" } "."
+{ $subsection <smart-arrow> } ;
+
+ABOUT: "models.arrow.smart"
\ No newline at end of file
diff --git a/basis/models/arrow/smart/smart-tests.factor b/basis/models/arrow/smart/smart-tests.factor
new file mode 100644
index 0000000000..3e8375e512
--- /dev/null
+++ b/basis/models/arrow/smart/smart-tests.factor
@@ -0,0 +1,4 @@
+IN: models.arrows.smart.tests
+USING: models.arrow.smart tools.test accessors models math kernel ;
+
+[ 7 ] [ 3 <model> 4 <model> [ + ] <smart-arrow> [ activate-model ] [ value>> ] bi ] unit-test
\ No newline at end of file
diff --git a/basis/models/arrow/smart/smart.factor b/basis/models/arrow/smart/smart.factor
new file mode 100644
index 0000000000..257a2bb1ea
--- /dev/null
+++ b/basis/models/arrow/smart/smart.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: models.arrow models.product stack-checker accessors fry
+generalizations macros kernel ;
+IN: models.arrow.smart
+
+MACRO: <smart-arrow> ( quot -- quot' )
+ [ infer in>> dup ] keep
+ '[ _ narray <product> [ _ firstn @ ] <arrow> ] ;
\ No newline at end of file
diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor
index 2b90bdb0d5..8f40a8adbe 100644
--- a/basis/models/models-docs.factor
+++ b/basis/models/models-docs.factor
@@ -133,7 +133,6 @@ $nl
{ $subsection "models-impl" }
{ $subsection "models.arrow" }
{ $subsection "models.product" }
-{ $subsection "models-history" }
{ $subsection "models-range" }
{ $subsection "models-delay" } ;
diff --git a/basis/models/models-tests.factor b/basis/models/models-tests.factor
index f875fa3140..7368a2aa54 100644
--- a/basis/models/models-tests.factor
+++ b/basis/models/models-tests.factor
@@ -31,6 +31,3 @@ T{ model-tester f f } "tester" set
"tester" get
"model-c" get value>>
] unit-test
-
-\ model-changed must-infer
-\ set-model must-infer
diff --git a/basis/models/search/search.factor b/basis/models/search/search.factor
index 4bf74b3b92..5ecb0fa34a 100644
--- a/basis/models/search/search.factor
+++ b/basis/models/search/search.factor
@@ -1,12 +1,10 @@
! Copyright (C) 2008, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
-sequences unicode.case ;
+USING: fry kernel models.arrow.smart sequences unicode.case ;
IN: models.search
: <search> ( values search quot -- model )
- [ 2array <product> ] dip
- '[ first2 _ curry filter ] <arrow> ;
+ '[ _ curry filter ] <smart-arrow> ; inline
: <string-search> ( values search quot -- model )
- '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ;
+ '[ swap @ [ >case-fold ] bi@ subseq? ] <search> ; inline
diff --git a/basis/models/sort/sort.factor b/basis/models/sort/sort.factor
index 23c150796f..efd2e4927b 100644
--- a/basis/models/sort/sort.factor
+++ b/basis/models/sort/sort.factor
@@ -1,8 +1,7 @@
-! Copyright (C) 2008 Slava Pestov
+! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry kernel models.product models.arrow
-sequences sorting ;
+USING: sorting models.arrow.smart fry ;
IN: models.sort
: <sort> ( values sort -- model )
- 2array <product> [ first2 sort ] <arrow> ;
\ No newline at end of file
+ [ '[ _ call( obj1 obj2 -- <=> ) ] sort ] <smart-arrow> ; inline
\ No newline at end of file
diff --git a/basis/opengl/authors.txt b/basis/opengl/authors.txt
index 55ac3c728e..f4e25322b8 100644
--- a/basis/opengl/authors.txt
+++ b/basis/opengl/authors.txt
@@ -1,3 +1,4 @@
Slava Pestov
Eduardo Cavazos
Joe Groff
+Alex Chapman
diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor
index 09d49b33c2..ad04ce7fa5 100755
--- a/basis/opengl/capabilities/capabilities.factor
+++ b/basis/opengl/capabilities/capabilities.factor
@@ -32,6 +32,8 @@ IN: opengl.capabilities
(gl-version) drop ;
: gl-vendor-version ( -- version )
(gl-version) nip ;
+: gl-vendor ( -- name )
+ GL_VENDOR glGetString ;
: has-gl-version? ( version -- ? )
gl-version version-before? ;
: (make-gl-version-error) ( required-version -- )
diff --git a/basis/opengl/gl/authors.txt b/basis/opengl/gl/authors.txt
index 1901f27a24..e9c193bac7 100644
--- a/basis/opengl/gl/authors.txt
+++ b/basis/opengl/gl/authors.txt
@@ -1 +1 @@
-Slava Pestov
+Alex Chapman
diff --git a/basis/opengl/gl/windows/windows.factor b/basis/opengl/gl/windows/windows.factor
index 8f48f60d3c..c8a179edf5 100644
--- a/basis/opengl/gl/windows/windows.factor
+++ b/basis/opengl/gl/windows/windows.factor
@@ -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
diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor
index f474c97b73..b773833280 100644
--- a/basis/opengl/opengl-docs.factor
+++ b/basis/opengl/opengl-docs.factor
@@ -15,8 +15,8 @@ HELP: do-enabled
{ $description "Wraps a quotation in " { $link glEnable } "/" { $link glDisable } " calls." } ;
HELP: do-matrix
-{ $values { "mode" { $link GL_MODELVIEW } " or " { $link GL_PROJECTION } } { "quot" quotation } }
-{ $description "Saves and restores the matrix specified by " { $snippet "mode" } " before and after calling the quotation." } ;
+{ $values { "quot" quotation } }
+{ $description "Saves and restores the current matrix before and after calling the quotation." } ;
HELP: gl-line
{ $values { "a" "a pair of integers" } { "b" "a pair of integers" } }
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index 0a21f67376..72ca8b8cdb 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -3,7 +3,7 @@
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types continuations kernel libc math macros
-namespaces math.vectors math.parser opengl.gl opengl.glu combinators
+namespaces math.vectors math.parser opengl.gl combinators
combinators.smart arrays sequences splitting words byte-arrays assocs
colors colors.constants accessors generalizations locals fry
specialized-arrays.float specialized-arrays.uint ;
@@ -16,10 +16,23 @@ IN: opengl
: gl-clear ( color -- )
gl-clear-color GL_COLOR_BUFFER_BIT glClear ;
+: error>string ( n -- string )
+ H{
+ { HEX: 0 "No error" }
+ { HEX: 0501 "Invalid value" }
+ { HEX: 0500 "Invalid enumerant" }
+ { HEX: 0502 "Invalid operation" }
+ { HEX: 0503 "Stack overflow" }
+ { HEX: 0504 "Stack underflow" }
+ { HEX: 0505 "Out of memory" }
+ } at "Unknown error" or ;
+
+TUPLE: gl-error code string ;
+
: gl-error ( -- )
- glGetError dup zero? [
- "GL error: " over gluErrorString append throw
- ] unless drop ;
+ glGetError dup 0 = [ drop ] [
+ dup error>string \ gl-error boa throw
+ ] if ;
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
@@ -44,9 +57,8 @@ MACRO: all-enabled ( seq quot -- )
MACRO: all-enabled-client-state ( seq quot -- )
[ words>values ] dip '[ _ _ (all-enabled-client-state) ] ;
-: do-matrix ( mode quot -- )
- swap [ glMatrixMode glPushMatrix call ] keep
- glMatrixMode glPopMatrix ; inline
+: do-matrix ( quot -- )
+ glPushMatrix call glPopMatrix ; inline
: gl-material ( face pname params -- )
float-array{ } like glMaterialfv ;
@@ -152,9 +164,6 @@ MACRO: all-enabled-client-state ( seq quot -- )
MACRO: set-draw-buffers ( buffers -- )
words>values '[ _ (set-draw-buffers) ] ;
-: gl-look-at ( eye focus up -- )
- [ first3 ] tri@ gluLookAt ;
-
: gen-dlist ( -- id ) 1 glGenLists ;
: make-dlist ( type quot -- id )
@@ -165,7 +174,7 @@ MACRO: set-draw-buffers ( buffers -- )
: delete-dlist ( id -- ) 1 glDeleteLists ;
: with-translation ( loc quot -- )
- GL_MODELVIEW [ [ gl-translate ] dip call ] do-matrix ; inline
+ [ [ gl-translate ] dip call ] do-matrix ; inline
: fix-coordinates ( point1 point2 -- x1 y2 x2 y2 )
[ first2 [ >fixnum ] bi@ ] bi@ ;
@@ -177,6 +186,7 @@ MACRO: set-draw-buffers ( buffers -- )
fix-coordinates glViewport ;
: init-matrices ( -- )
+ #! Leaves with matrix mode GL_MODELVIEW
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode
diff --git a/basis/opengl/textures/textures-tests.factor b/basis/opengl/textures/textures-tests.factor
index 163871028d..3efdb43cd8 100644
--- a/basis/opengl/textures/textures-tests.factor
+++ b/basis/opengl/textures/textures-tests.factor
@@ -5,56 +5,6 @@ opengl.textures.private images kernel namespaces accessors
sequences ;
IN: opengl.textures.tests
-[ ] [
- T{ image
- { dim { 3 5 } }
- { component-order RGB }
- { bitmap
- B{
- 1 2 3 4 5 6 7 8 9
- 10 11 12 13 14 15 16 17 18
- 19 20 21 22 23 24 25 26 27
- 28 29 30 31 32 33 34 35 36
- 37 38 39 40 41 42 43 44 45
- }
- }
- } "image" set
-] unit-test
-
-[
- T{ image
- { dim { 4 8 } }
- { component-order RGB }
- { bitmap
- B{
- 1 2 3 4 5 6 7 8 9 7 8 9
- 10 11 12 13 14 15 16 17 18 16 17 18
- 19 20 21 22 23 24 25 26 27 25 26 27
- 28 29 30 31 32 33 34 35 36 34 35 36
- 37 38 39 40 41 42 43 44 45 43 44 45
- 37 38 39 40 41 42 43 44 45 43 44 45
- 37 38 39 40 41 42 43 44 45 43 44 45
- 37 38 39 40 41 42 43 44 45 43 44 45
- }
- }
- }
-] [
- "image" get power-of-2-image
-] unit-test
-
-[
- T{ image
- { dim { 0 0 } }
- { component-order R32G32B32 }
- { bitmap B{ } } }
-] [
- T{ image
- { dim { 0 0 } }
- { component-order R32G32B32 }
- { bitmap B{ } }
- } power-of-2-image
-] unit-test
-
[
{
{ { 0 0 } { 10 0 } }
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index 3efe924fb5..d103e90bee 100755
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -1,11 +1,23 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache colors.constants destructors fry kernel
-opengl opengl.gl combinators images images.tesselation grouping
-specialized-arrays.float locals sequences math math.vectors
-math.matrices generalizations fry columns arrays ;
+opengl opengl.gl opengl.capabilities combinators images
+images.tesselation grouping specialized-arrays.float sequences math
+math.vectors math.matrices generalizations fry arrays namespaces
+system ;
IN: opengl.textures
+SYMBOL: non-power-of-2-textures?
+
+: check-extensions ( -- )
+ #! ATI frglx driver doesn't implement GL_ARB_texture_non_power_of_two properly.
+ #! See thread 'Linux font display problem' April 2009 on Factor-talk
+ gl-vendor "ATI Technologies Inc." = not os macosx? or [
+ "2.0" { "GL_ARB_texture_non_power_of_two" }
+ has-gl-version-or-extensions?
+ non-power-of-2-textures? set
+ ] when ;
+
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
@@ -18,60 +30,52 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ;
+M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ;
-GENERIC: draw-texture ( texture -- )
+SLOT: display-list
+
+: draw-texture ( texture -- ) display-list>> [ glCallList ] when* ;
GENERIC: draw-scaled-texture ( dim texture -- )
<PRIVATE
-TUPLE: single-texture image loc dim texture-coords texture display-list disposed ;
+TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
-: repeat-last ( seq n -- seq' )
- over peek pad-tail concat ;
-
-: power-of-2-bitmap ( rows dim size -- bitmap dim )
- '[
- first2
- [ [ _ ] dip '[ _ group _ repeat-last ] map ]
- [ repeat-last ]
- bi*
- ] keep ;
-
-: image-rows ( image -- rows )
- [ bitmap>> ]
- [ dim>> first ]
- [ component-order>> bytes-per-pixel ]
- tri * group ; inline
-
-: power-of-2-image ( image -- image )
- dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [
- clone dup
- [ image-rows ]
- [ dim>> [ next-power-of-2 ] map ]
- [ component-order>> bytes-per-pixel ] tri
- power-of-2-bitmap
- [ >>bitmap ] [ >>dim ] bi*
+: adjust-texture-dim ( dim -- dim' )
+ non-power-of-2-textures? get [
+ [ dup 1 = [ next-power-of-2 ] unless ] map
] unless ;
-:: make-texture ( image -- id )
+: (tex-image) ( image bitmap -- )
+ [
+ [ GL_TEXTURE_2D 0 GL_RGBA ] dip
+ [ dim>> adjust-texture-dim first2 0 ]
+ [ component-order>> component-order>format ] bi
+ ] dip
+ glTexImage2D ;
+
+: (tex-sub-image) ( image -- )
+ [ GL_TEXTURE_2D 0 0 0 ] dip
+ [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
+ glTexSubImage2D ;
+
+: make-texture ( image -- id )
+ #! We use glTexSubImage2D to work around the power of 2 texture size
+ #! limitation
gen-texture [
GL_TEXTURE_BIT [
GL_TEXTURE_2D swap glBindTexture
- GL_TEXTURE_2D
- 0
- GL_RGBA
- image dim>> first2
- 0
- image component-order>> component-order>format
- image bitmap>>
- glTexImage2D
+ non-power-of-2-textures? get
+ [ dup bitmap>> (tex-image) ]
+ [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
] do-attribs
] keep ;
: init-texture ( -- )
- GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
- GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
@@ -100,20 +104,19 @@ TUPLE: single-texture image loc dim texture-coords texture display-list disposed
] with-texturing ;
: texture-coords ( texture -- coords )
+ [ [ dim>> ] [ image>> dim>> adjust-texture-dim ] bi v/ ]
[
- [ dim>> ] [ image>> dim>> ] bi v/
- { { 0 0 } { 1 0 } { 1 1 } { 0 1 } }
- [ v* ] with map
- ] keep
- image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when
- float-array{ } join ;
+ image>> upside-down?>>
+ { { 0 1 } { 1 1 } { 1 0 } { 0 0 } }
+ { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } ?
+ ] bi
+ [ v* ] with map float-array{ } join ;
: make-texture-display-list ( texture -- dlist )
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
-: <single-texture> ( image loc dim -- texture )
- [ power-of-2-image ] 2dip
- single-texture new swap >>dim swap >>loc swap >>image
+: <single-texture> ( image loc -- texture )
+ single-texture new swap >>loc swap [ >>image ] [ dim>> >>dim ] bi
dup image>> dim>> product 0 = [
dup texture-coords >>texture-coords
dup image>> make-texture >>texture
@@ -124,21 +127,21 @@ M: single-texture dispose*
[ texture>> [ delete-texture ] when* ]
[ display-list>> [ delete-dlist ] when* ] bi ;
-M: single-texture draw-texture display-list>> [ glCallList ] when* ;
-
M: single-texture draw-scaled-texture
- dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
+ 2dup dim>> = [ nip draw-texture ] [
+ dup texture>> [ draw-textured-rect ] [ 2drop ] if
+ ] if ;
TUPLE: multi-texture grid display-list loc disposed ;
: image-locs ( image-grid -- loc-grid )
- [ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
+ [ first [ dim>> first ] map ] [ [ first dim>> second ] map ] bi
[ 0 [ + ] accumulate nip ] bi@
cross-zip flip ;
: <texture-grid> ( image-grid loc -- grid )
[ dup image-locs ] dip
- '[ [ _ v+ over dim>> <single-texture> |dispose ] 2map ] 2map ;
+ '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
: draw-textured-grid ( grid -- )
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
@@ -165,7 +168,7 @@ TUPLE: multi-texture grid display-list loc disposed ;
f multi-texture boa
] with-destructors ;
-M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
+M: multi-texture draw-scaled-texture nip draw-texture ;
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
@@ -173,10 +176,7 @@ CONSTANT: max-texture-size { 512 512 }
PRIVATE>
-: small-texture? ( dim -- ? )
- max-texture-size [ <= ] 2all? ;
-
-: <texture> ( image loc dim -- texture )
- pick dim>> small-texture?
+: <texture> ( image loc -- texture )
+ over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
- [ drop [ max-texture-size tesselate ] dip <multi-texture> ] if ;
\ No newline at end of file
+ [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
diff --git a/basis/pango/layouts/layouts.factor b/basis/pango/layouts/layouts.factor
index defcdec6f8..25aee74ca4 100644
--- a/basis/pango/layouts/layouts.factor
+++ b/basis/pango/layouts/layouts.factor
@@ -44,7 +44,7 @@ FUNCTION: PangoLayoutLine*
pango_layout_get_line_readonly ( PangoLayout* layout, int line ) ;
FUNCTION: void
-pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, gboolean trailing, int* x_pos ) ;
+pango_layout_line_index_to_x ( PangoLayoutLine* line, int index_, uint trailing, int* x_pos ) ;
FUNCTION: gboolean
pango_layout_line_x_to_index ( PangoLayoutLine* line, int x_pos, int* index_, int* trailing ) ;
@@ -122,7 +122,7 @@ MEMO: missing-font-metrics ( font -- metrics )
: line-offset>x ( layout n -- x )
#! n is an index into the UTF8 encoding of the text
[ drop first-line ] [ swap string>> >utf8-index ] 2bi
- f 0 <int> [ pango_layout_line_index_to_x ] keep
+ 0 0 <int> [ pango_layout_line_index_to_x ] keep
*int pango>float ;
: x>line-offset ( layout x -- n )
@@ -205,4 +205,4 @@ SYMBOL: cached-layouts
: cached-line ( font string -- line )
cached-layout layout>> first-line ;
-[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook
\ No newline at end of file
+[ <cache-assoc> cached-layouts set-global ] "pango.layouts" add-init-hook
diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor
index cc83a55c7e..329156d733 100644
--- a/basis/peg/ebnf/ebnf-tests.factor
+++ b/basis/peg/ebnf/ebnf-tests.factor
@@ -300,8 +300,6 @@ main = Primary
"x[i][j].y" primary
] unit-test
-'ebnf' compile must-infer
-
{ V{ V{ "a" "b" } "c" } } [
"abc" [EBNF a="a" "b" foo=(a "c") EBNF]
] unit-test
@@ -444,12 +442,12 @@ foo=<foreign any-char> 'd'
"ad" parser4
] unit-test
-{ t } [
- "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t
+{ } [
+ "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" eval( -- )
] unit-test
[
- "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval drop
+ "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval( -- ) drop
] must-fail
{ t } [
@@ -521,12 +519,12 @@ Tok = Spaces (Number | Special )
"\\" [EBNF foo="\\" EBNF]
] unit-test
-[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail
+[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail
[ <" USE: peg.ebnf [EBNF
lol = a
lol = b
- EBNF] "> eval
+ EBNF] "> eval( -- )
] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with
diff --git a/basis/peg/ebnf/tags.txt b/basis/peg/ebnf/tags.txt
index 5af5dba748..1ccdafb2bb 100644
--- a/basis/peg/ebnf/tags.txt
+++ b/basis/peg/ebnf/tags.txt
@@ -1,2 +1,3 @@
+extensions
text
parsing
diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor
index 7d5cb1e76a..cae1e05dc8 100644
--- a/basis/peg/peg-tests.factor
+++ b/basis/peg/peg-tests.factor
@@ -5,8 +5,6 @@ USING: kernel tools.test strings namespaces make arrays sequences
peg peg.private peg.parsers accessors words math accessors ;
IN: peg.tests
-\ parse must-infer
-
[ ] [ reset-pegs ] unit-test
[
@@ -201,12 +199,10 @@ IN: peg.tests
USE: compiler
-[ ] [ disable-compiler ] unit-test
+[ ] [ disable-optimizer ] unit-test
[ ] [ "" epsilon parse drop ] unit-test
-[ ] [ enable-compiler ] unit-test
+[ ] [ enable-optimizer ] unit-test
[ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test
-
-[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test
\ No newline at end of file
diff --git a/basis/peg/search/search-tests.factor b/basis/peg/search/search-tests.factor
index 96d89d4611..b22a5ef0d0 100644
--- a/basis/peg/search/search-tests.factor
+++ b/basis/peg/search/search-tests.factor
@@ -17,5 +17,3 @@ IN: peg.search.tests
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
] unit-test
-\ search must-infer
-\ replace must-infer
diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor
index 91f1dcf1f8..ca9a86b6d9 100644
--- a/basis/persistent/deques/deques.factor
+++ b/basis/persistent/deques/deques.factor
@@ -21,7 +21,7 @@ TUPLE: deque { front read-only } { back read-only } ;
[ back>> ] [ front>> ] bi deque boa ;
: flipped ( deque quot -- newdeque )
- [ flip ] dip call flip ;
+ [ flip ] dip call flip ; inline
PRIVATE>
: deque-empty? ( deque -- ? )
diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor
index 5ed72e5d59..eea31dd34e 100644
--- a/basis/persistent/hashtables/hashtables-tests.factor
+++ b/basis/persistent/hashtables/hashtables-tests.factor
@@ -83,7 +83,7 @@ M: hash-0-b hashcode* 2drop 0 ;
: random-string ( -- str )
1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ;
-: random-assocs ( -- hash phash )
+: random-assocs ( n -- hash phash )
[ random-string ] replicate
[ H{ } clone [ '[ swap _ set-at ] each-index ] keep ]
[ PH{ } clone swap [ spin new-at ] each-index ]
@@ -92,7 +92,7 @@ M: hash-0-b hashcode* 2drop 0 ;
: ok? ( assoc1 assoc2 -- ? )
[ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ;
-: test-persistent-hashtables-1 ( n -- )
+: test-persistent-hashtables-1 ( n -- ? )
random-assocs ok? ;
[ t ] [ 10 test-persistent-hashtables-1 ] unit-test
@@ -106,7 +106,7 @@ M: hash-0-b hashcode* 2drop 0 ;
[ t ] [ 10000 test-persistent-hashtables-1 ] unit-test
[ t ] [ 50000 test-persistent-hashtables-1 ] unit-test
-: test-persistent-hashtables-2 ( n -- )
+: test-persistent-hashtables-2 ( n -- ? )
random-assocs
dup keys [
[ nip over delete-at ] [ swap pluck-at nip ] 3bi
diff --git a/basis/persistent/vectors/vectors-tests.factor b/basis/persistent/vectors/vectors-tests.factor
index c232db8533..95fa70558d 100644
--- a/basis/persistent/vectors/vectors-tests.factor
+++ b/basis/persistent/vectors/vectors-tests.factor
@@ -3,10 +3,6 @@ USING: accessors tools.test persistent.vectors
persistent.sequences sequences kernel arrays random namespaces
vectors math math.order ;
-\ new-nth must-infer
-\ ppush must-infer
-\ ppop must-infer
-
[ 0 ] [ PV{ } length ] unit-test
[ 1 ] [ 3 PV{ } ppush length ] unit-test
diff --git a/basis/present/present-tests.factor b/basis/present/present-tests.factor
index 22d352cb5a..559b9ac01d 100644
--- a/basis/present/present-tests.factor
+++ b/basis/present/present-tests.factor
@@ -1,5 +1,5 @@
IN: present.tests
-USING: tools.test present math vocabs tools.vocabs sequences kernel ;
+USING: tools.test present math vocabs sequences kernel ;
[ "3" ] [ 3 present ] unit-test
[ "Hi" ] [ "Hi" present ] unit-test
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index bcd91a4d94..3dcd7fb0ed 100644
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -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 ;
@@ -35,24 +34,25 @@ M: effect pprint* effect>string "(" ")" surround text ;
name>> "( no name )" or ;
: pprint-word ( word -- )
- dup record-vocab
- dup word-name* swap word-style styled-text ;
+ [ record-vocab ]
+ [ [ word-name* ] [ word-style ] bi styled-text ] bi ;
: pprint-prefix ( word quot -- )
<block swap pprint-word call block> ; inline
+M: parsing-word pprint*
+ \ POSTPONE: [ pprint-word ] pprint-prefix ;
+
M: word pprint*
- dup parsing-word? [
- \ POSTPONE: [ pprint-word ] pprint-prefix
- ] [
- {
- [ "break-before" word-prop line-break ]
- [ pprint-word ]
- [ ?start-group ]
- [ ?end-group ]
- [ "break-after" word-prop line-break ]
- } cleave
- ] if ;
+ [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
+
+M: method-body pprint*
+ [
+ [
+ [ "M\\ " % "method-class" word-prop word-name* % ]
+ [ " " % "method-generic" word-prop word-name* % ] bi
+ ] "" make
+ ] [ word-style ] bi styled-text ;
M: real pprint* number>string text ;
@@ -134,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
@@ -148,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 [-]
@@ -164,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{ \ } ;
@@ -172,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 ;
@@ -201,13 +206,14 @@ 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 ;
M: wrapper pprint*
- dup wrapped>> word? [
- <block \ \ pprint-word wrapped>> pprint-word block>
- ] [
- pprint-object
- ] if ;
+ {
+ { [ dup wrapped>> method-body? ] [ wrapped>> pprint* ] }
+ { [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
+ [ pprint-object ]
+ } cond ;
diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor
index 7e37aa0da5..25ee83985e 100644
--- a/basis/prettyprint/prettyprint-tests.factor
+++ b/basis/prettyprint/prettyprint-tests.factor
@@ -2,8 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex
kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
-continuations generic compiler.units tools.walker eval
-accessors make vocabs.parser see ;
+continuations generic compiler.units tools.continuations
+tools.continuations.private eval accessors make vocabs.parser see ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
@@ -86,11 +86,10 @@ unit-test
drop ;
[ "drop ;" ] [
- \ blah f "inferred-effect" set-word-prop
[ \ blah see ] with-string-writer "\n" ?tail drop 6 tail*
] unit-test
-: check-see ( expect name -- )
+: check-see ( expect name -- ? )
[
use [ clone ] change
@@ -105,6 +104,7 @@ unit-test
GENERIC: method-layout ( a -- b )
M: complex method-layout
+ drop
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
;
@@ -116,8 +116,9 @@ M: object method-layout ;
[
{
- "USING: math prettyprint.tests ;"
+ "USING: kernel math prettyprint.tests ;"
"M: complex method-layout"
+ " drop"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
" ;"
""
@@ -180,37 +181,15 @@ DEFER: parse-error-file
"string-layout-test" string-layout check-see
] unit-test
-! Define dummy words for the below...
-: <NSRect> ( a b c d -- e ) ;
-: <PixelFormat> ( -- fmt ) ;
-: send ( obj -- ) ;
-
-\ send soft "break-after" set-word-prop
-
-: final-soft-break-test ( -- str )
- {
- "USING: kernel sequences ;"
- "IN: prettyprint.tests"
- ": final-soft-break-layout ( class dim -- view )"
- " [ \"alloc\" send 0 0 ] dip first2 <NSRect>"
- " <PixelFormat> \"initWithFrame:pixelFormat:\" send"
- " dup 1 \"setPostsBoundsChangedNotifications:\" send"
- " dup 1 \"setPostsFrameChangedNotifications:\" send ;"
- } ;
-
-[ t ] [
- "final-soft-break-layout" final-soft-break-test check-see
-] unit-test
-
-: narrow-test ( -- str )
+: narrow-test ( -- array )
{
"USING: arrays combinators continuations kernel sequences ;"
"IN: prettyprint.tests"
- ": narrow-layout ( obj -- )"
+ ": narrow-layout ( obj1 obj2 -- obj3 )"
" {"
" { [ dup continuation? ] [ append ] }"
" { [ dup not ] [ drop reverse ] }"
- " { [ dup pair? ] [ delete ] }"
+ " { [ dup pair? ] [ [ delete ] keep ] }"
" } cond ;"
} ;
@@ -218,7 +197,7 @@ DEFER: parse-error-file
"narrow-layout" narrow-test check-see
] unit-test
-: another-narrow-test ( -- str )
+: another-narrow-test ( -- array )
{
"IN: prettyprint.tests"
": another-narrow-layout ( -- obj )"
@@ -274,19 +253,15 @@ M: class-see-layout class-see-layout ;
! Regression
[ t ] [
"IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
- dup eval
+ dup eval( -- )
"generic-decl-test" "prettyprint.tests" lookup
[ see ] with-string-writer =
] unit-test
-[ [ + ] ] [
- [ \ + (step-into-execute) ] (remove-breakpoints)
-] unit-test
-
-[ [ (step-into-execute) ] ] [
- [ (step-into-execute) ] (remove-breakpoints)
-] unit-test
+[ [ + ] ] [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test
+[ [ (step-into-execute) ] ] [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test
+
[ [ 2 2 + . ] ] [
[ 2 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test
@@ -300,11 +275,7 @@ GENERIC: generic-see-test-with-f ( obj -- obj )
M: f generic-see-test-with-f ;
[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
- [ { POSTPONE: f generic-see-test-with-f } see ] with-string-writer
-] unit-test
-
-[ "USING: prettyprint.tests ;\nM: f generic-see-test-with-f ;\n" ] [
- [ \ f \ generic-see-test-with-f method see ] with-string-writer
+ [ M\ f generic-see-test-with-f see ] with-string-writer
] unit-test
PREDICATE: predicate-see-test < integer even? ;
@@ -331,5 +302,5 @@ GENERIC: ended-up-ballin' ( a -- b )
M: started-out-hustlin' ended-up-ballin' ; inline
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
- [ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
+ [ M\ started-out-hustlin' ended-up-ballin' see ] with-string-writer
] unit-test
diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor
index fe58e3d07c..c35d7488ac 100644
--- a/basis/random/mersenne-twister/mersenne-twister-tests.factor
+++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor
@@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests
100 [ 100 random ] replicate ;
: test-rng ( seed quot -- )
- [ <mersenne-twister> ] dip with-random ;
+ [ <mersenne-twister> ] dip with-random ; inline
[ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
diff --git a/basis/random/random.factor b/basis/random/random.factor
index ebde3802b4..d972e1e7ac 100755
--- a/basis/random/random.factor
+++ b/basis/random/random.factor
@@ -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 )
diff --git a/basis/random/windows/windows.factor b/basis/random/windows/windows.factor
index a4cf74e1df..488deef41f 100644
--- a/basis/random/windows/windows.factor
+++ b/basis/random/windows/windows.factor
@@ -1,6 +1,6 @@
USING: accessors alien.c-types byte-arrays continuations
-kernel windows windows.advapi32 init namespaces random
-destructors locals ;
+kernel windows.advapi32 init namespaces random destructors
+locals windows.errors ;
IN: random.windows
TUPLE: windows-rng provider type ;
diff --git a/basis/refs/authors.txt b/basis/refs/authors.txt
index 1901f27a24..22d592c1dd 100755
--- a/basis/refs/authors.txt
+++ b/basis/refs/authors.txt
@@ -1 +1,2 @@
Slava Pestov
+Alex Chapman
diff --git a/basis/refs/refs-docs.factor b/basis/refs/refs-docs.factor
old mode 100644
new mode 100755
index a219f0ba8b..9971a1d4fa
--- a/basis/refs/refs-docs.factor
+++ b/basis/refs/refs-docs.factor
@@ -1,52 +1,143 @@
-! Copyright (C) 2007 Slava Pestov
+! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
+USING: boxes help.markup help.syntax kernel math namespaces assocs ;
IN: refs
-ARTICLE: "refs" "References to assoc entries"
-"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary."
-{ $subsection get-ref }
-{ $subsection set-ref }
-{ $subsection delete-ref }
-"References to keys:"
-{ $subsection key-ref }
-{ $subsection <key-ref> }
-"References to values:"
-{ $subsection value-ref }
-{ $subsection <value-ref> }
-"References are used by the UI inspector." ;
+ARTICLE: "refs" "References"
+"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing a protocol."
+{ $subsection "refs-protocol" }
+{ $subsection "refs-impls" }
+{ $subsection "refs-utils" }
+"References are used by the " { $link "ui-inspector" } "." ;
ABOUT: "refs"
+ARTICLE: "refs-impls" "Reference implementations"
+"References to objects:"
+{ $subsection obj-ref }
+{ $subsection <obj-ref> }
+"References to assoc keys:"
+{ $subsection key-ref }
+{ $subsection <key-ref> }
+"References to assoc values:"
+{ $subsection value-ref }
+{ $subsection <value-ref> }
+"References to variables:"
+{ $subsection var-ref }
+{ $subsection <var-ref> }
+{ $subsection global-var-ref }
+{ $subsection <global-var-ref> }
+"References to tuple slots:"
+{ $subsection slot-ref }
+{ $subsection <slot-ref> }
+"Using boxes as references:"
+{ $subsection "box-refs" } ;
+
+ARTICLE: "refs-utils" "Reference utilities"
+{ $subsection ref-on }
+{ $subsection ref-off }
+{ $subsection ref-inc }
+{ $subsection ref-dec }
+{ $subsection set-ref* } ;
+
+ARTICLE: "refs-protocol" "Reference protocol"
+"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
+{ $subsection get-ref }
+{ $subsection set-ref }
+"References may also implement:"
+{ $subsection delete-ref } ;
+
+ARTICLE: "box-refs" "Boxes as references"
+{ $link "boxes" } " are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
+
HELP: ref
-{ $class-description "A class whose instances identify a key or value location in an associative structure. Instances of this clas are never used directly; only instances of " { $link key-ref } " and " { $link value-ref } " should be created." } ;
+{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
HELP: delete-ref
{ $values { "ref" ref } }
-{ $description "Deletes the association entry pointed at by this reference." } ;
+{ $description "Deletes the value pointed to by this reference. In most references this simply sets the value to f, but in some cases it is more destructive, such as in " { $link value-ref } " and " { $link key-ref } ", where it actually deletes the entry from the underlying assoc." } ;
HELP: get-ref
{ $values { "ref" ref } { "obj" object } }
-{ $description "Outputs the key or the value pointed at by this reference." } ;
+{ $description "Outputs the value pointed at by this reference." } ;
HELP: set-ref
{ $values { "obj" object } { "ref" ref } }
-{ $description "Stores a new key or value at by this reference." } ;
+{ $description "Stores a new value at this reference." } ;
+HELP: obj-ref
+{ $class-description "Instances of this class contain a value which can be changed using the " { $link "refs-protocol" } ". New object references are created by calling " { $link <obj-ref> } "." } ;
+
+HELP: <obj-ref>
+{ $values { "obj" object } { "obj-ref" obj-ref } }
+{ $description "Creates a reference which contains the value it references." } ;
+
+HELP: var-ref
+{ $class-description "Instances of this class reference a variable as defined by the " { $vocab-link "namespaces" } " vocabulary. New variable references are created by calling " { $link <var-ref> } "." } ;
+
+HELP: <var-ref>
+{ $values { "var" object } { "var-ref" var-ref } }
+{ $description "Creates a reference to the given variable. Note that this reference behaves just like any variable when it comes to dynamic scope. For example, if you use " { $link set-ref } " in an inner scope and then leave that scope, then calling " { $link get-ref } " may not return the expected value. If this is not what you want, try using an " { $link obj-ref } " instead." } ;
+
+HELP: global-var-ref
+{ $class-description "Instances of this class reference a global variable. New global references are created by calling " { $link <global-var-ref> } "." } ;
+
+HELP: <global-var-ref>
+{ $values { "var" object } { "global-var-ref" global-var-ref } }
+{ $description "Creates a reference to a global variable." } ;
+
+HELP: slot-ref
+{ $class-description "Instances of this class identify a particular slot of a particular instance of a tuple. New slot references are created by calling " { $link <slot-ref> } "." } ;
+
+HELP: <slot-ref>
+{ $values { "tuple" tuple } { "slot" integer } { "slot-ref" slot-ref } }
+{ $description "Creates a reference to the value in a particular slot of the given tuple. The slot must be given as an integer, where the first user-defined slot is number 2. This is mostly just a proof of concept until we have a way of generating this slot number from a slot name." } ;
+
HELP: key-ref
{ $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
HELP: <key-ref>
-{ $values { "assoc" "an assoc" } { "key" object } { "key-ref" key-ref } }
+{ $values { "assoc" assoc } { "key" object } { "key-ref" key-ref } }
{ $description "Creates a reference to a key stored in an assoc." } ;
HELP: value-ref
{ $class-description "Instances of this class identify a value associated to a key in an associative structure. New value references are created by calling " { $link <value-ref> } "." } ;
HELP: <value-ref>
-{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
+{ $values { "assoc" assoc } { "key" object } { "value-ref" value-ref } }
{ $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
-{ get-ref set-ref delete-ref } related-words
+{ get-ref set-ref delete-ref set-ref* } related-words
+
+{ <obj-ref> <var-ref> <global-var-ref> <slot-ref> <key-ref> <value-ref> } related-words
-{ <key-ref> <value-ref> } related-words
+HELP: set-ref*
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ;
+
+HELP: ref-on
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to t." } ;
+
+HELP: ref-off
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to f." } ;
+
+HELP: ref-inc
+{ $values { "ref" ref } }
+{ $description "Increment the value of the ref by 1." } ;
+
+HELP: ref-dec
+{ $values { "ref" ref } }
+{ $description "Decrement the value of the ref by 1." } ;
+
+HELP: take
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Retrieve the value of the ref and then delete it, returning the value." } ;
+
+{ ref-on ref-off ref-inc ref-dec take } related-words
+{ take delete-ref } related-words
+{ on ref-on } related-words
+{ off ref-off } related-words
+{ inc ref-inc } related-words
+{ dec ref-dec } related-words
diff --git a/basis/refs/refs-tests.factor b/basis/refs/refs-tests.factor
index 1d921854e9..bf58aaf43d 100644
--- a/basis/refs/refs-tests.factor
+++ b/basis/refs/refs-tests.factor
@@ -1,5 +1,7 @@
-USING: refs tools.test kernel ;
+USING: boxes kernel namespaces refs tools.test ;
+IN: refs.tests
+! assoc-refs
[ 3 ] [
H{ { "a" 3 } } "a" <value-ref> get-ref
] unit-test
@@ -20,3 +22,84 @@ USING: refs tools.test kernel ;
set-ref
] keep
] unit-test
+
+SYMBOLS: lion giraffe elephant rabbit ;
+
+! obj-refs
+[ rabbit ] [ rabbit <obj-ref> get-ref ] unit-test
+[ rabbit ] [ f <obj-ref> rabbit set-ref* get-ref ] unit-test
+[ rabbit ] [ rabbit <obj-ref> take ] unit-test
+[ rabbit f ] [ rabbit <obj-ref> [ take ] keep get-ref ] unit-test
+[ lion ] [ rabbit <obj-ref> dup [ drop lion ] change-ref get-ref ] unit-test
+
+! var-refs
+[ giraffe ] [ [ giraffe rabbit set rabbit <var-ref> get-ref ] with-scope ] unit-test
+
+[ rabbit ]
+[
+ [
+ lion rabbit set [
+ rabbit rabbit set rabbit <var-ref> get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <var-ref>
+ [
+ lion rabbit set [
+ rabbit rabbit set get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <var-ref>
+ [
+ elephant rabbit set [
+ rabbit rabbit set
+ ] with-scope
+ get-ref
+ ] with-scope
+] unit-test
+
+[ rabbit ] [
+ rabbit <var-ref>
+ [
+ elephant set-ref* [
+ rabbit set-ref* get-ref
+ ] with-scope
+ ] with-scope
+] unit-test
+
+[ elephant ] [
+ rabbit <var-ref>
+ [
+ elephant set-ref* [
+ rabbit set-ref*
+ ] with-scope
+ get-ref
+ ] with-scope
+] unit-test
+
+! Top Hats
+[ lion ] [ lion rabbit set-global rabbit <global-var-ref> get-ref ] unit-test
+[ giraffe ] [ rabbit <global-var-ref> giraffe set-ref* get-ref ] unit-test
+
+! Tuple refs
+TUPLE: foo bar ;
+C: <foo> foo
+
+: test-tuple ( -- tuple )
+ rabbit <foo> ;
+
+: test-slot-ref ( -- slot-ref )
+ test-tuple 2 <slot-ref> ; ! hack!
+
+[ rabbit ] [ test-slot-ref get-ref ] unit-test
+[ lion ] [ test-slot-ref lion set-ref* get-ref ] unit-test
+
+! Boxes as refs
+[ rabbit ] [ <box> rabbit set-ref* get-ref ] unit-test
+[ <box> rabbit set-ref* lion set-ref* ] must-fail
+[ <box> get-ref ] must-fail
diff --git a/basis/refs/refs.factor b/basis/refs/refs.factor
index 0164a1ea57..668cdd65c3 100644
--- a/basis/refs/refs.factor
+++ b/basis/refs/refs.factor
@@ -1,22 +1,77 @@
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2008 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: classes.tuple kernel assocs accessors ;
+USING: kernel assocs accessors boxes math namespaces ;
IN: refs
-TUPLE: ref assoc key ;
+MIXIN: ref
-: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
-
-: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
GENERIC: set-ref ( obj ref -- )
+GENERIC: delete-ref ( ref -- )
-TUPLE: key-ref < ref ;
+! works like >>slot words
+: set-ref* ( ref obj -- ref ) over set-ref ;
+
+! very similar to change, on, off, +@, inc, and dec from namespaces
+: change-ref ( ref quot -- )
+ [ [ get-ref ] keep ] dip dip set-ref ; inline
+: ref-on ( ref -- ) t swap set-ref ;
+: ref-off ( ref -- ) f swap set-ref ;
+: ref-+@ ( n ref -- ) [ 0 or + ] change-ref ;
+: ref-inc ( ref -- ) 1 swap ref-+@ ;
+: ref-dec ( ref -- ) -1 swap ref-+@ ;
+
+: take ( ref -- obj )
+ dup get-ref swap delete-ref ;
+
+! delete-ref defaults to setting ref to f
+M: ref delete-ref ref-off ;
+
+TUPLE: obj-ref obj ;
+C: <obj-ref> obj-ref
+M: obj-ref get-ref obj>> ;
+M: obj-ref set-ref (>>obj) ;
+INSTANCE: obj-ref ref
+
+TUPLE: var-ref var ;
+C: <var-ref> var-ref
+M: var-ref get-ref var>> get ;
+M: var-ref set-ref var>> set ;
+INSTANCE: var-ref ref
+
+TUPLE: global-var-ref var ;
+C: <global-var-ref> global-var-ref
+M: global-var-ref get-ref var>> get-global ;
+M: global-var-ref set-ref var>> set-global ;
+INSTANCE: global-var-ref ref
+
+USE: slots.private
+TUPLE: slot-ref tuple slot ;
+C: <slot-ref> slot-ref
+: >slot-ref< ( slot-ref -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
+M: slot-ref get-ref >slot-ref< slot ;
+M: slot-ref set-ref >slot-ref< set-slot ;
+INSTANCE: slot-ref ref
+
+M: box get-ref box> ;
+M: box set-ref >box ;
+M: box delete-ref box> drop ;
+INSTANCE: box ref
+
+TUPLE: assoc-ref assoc key ;
+
+: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
+
+M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ;
+
+TUPLE: key-ref < assoc-ref ;
C: <key-ref> key-ref
M: key-ref get-ref key>> ;
-M: key-ref set-ref >ref< rename-at ;
+M: key-ref set-ref >assoc-ref< rename-at ;
+INSTANCE: key-ref ref
-TUPLE: value-ref < ref ;
+TUPLE: value-ref < assoc-ref ;
C: <value-ref> value-ref
-M: value-ref get-ref >ref< at ;
-M: value-ref set-ref >ref< set-at ;
+M: value-ref get-ref >assoc-ref< at ;
+M: value-ref set-ref >assoc-ref< set-at ;
+INSTANCE: value-ref ref
diff --git a/basis/regexp/ast/ast.factor b/basis/regexp/ast/ast.factor
index be657227e5..2916ef7c32 100644
--- a/basis/regexp/ast/ast.factor
+++ b/basis/regexp/ast/ast.factor
@@ -21,12 +21,12 @@ CONSTANT: epsilon T{ tagged-epsilon { tag t } }
TUPLE: concatenation first second ;
: <concatenation> ( seq -- concatenation )
- [ epsilon ] [ unclip [ concatenation boa ] reduce ] if-empty ;
+ [ epsilon ] [ [ ] [ concatenation boa ] map-reduce ] if-empty ;
TUPLE: alternation first second ;
: <alternation> ( seq -- alternation )
- unclip [ alternation boa ] reduce ;
+ [ ] [ alternation boa ] map-reduce ;
TUPLE: star term ;
C: <star> star
diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor
index d137ee3e4f..2de4e8b0e0 100644
--- a/basis/regexp/dfa/dfa.factor
+++ b/basis/regexp/dfa/dfa.factor
@@ -51,10 +51,13 @@ IN: regexp.dfa
[ condition-states ] 2dip
'[ _ _ add-todo-state ] each ;
+: ensure-state ( key table -- )
+ 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ; inline
+
:: new-transitions ( nfa dfa new-states visited-states -- nfa dfa )
new-states [ nfa dfa ] [
pop :> state
- state dfa transitions>> maybe-initialize-key
+ state dfa transitions>> ensure-state
state nfa find-transitions
[| trans |
state trans nfa find-closure :> new-state
diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor
index 9fcadc4008..70281aa798 100644
--- a/basis/regexp/parser/parser.factor
+++ b/basis/regexp/parser/parser.factor
@@ -102,8 +102,10 @@ MEMO: simple-category-table ( -- table )
{ CHAR: s dotall }
} ;
+ERROR: nonexistent-option name ;
+
: ch>option ( ch -- singleton )
- options-assoc at ;
+ dup options-assoc at [ ] [ nonexistent-option ] ?if ;
: option>ch ( option -- string )
options-assoc value-at ;
diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor
index 2234386803..1f72fa04ba 100644
--- a/basis/regexp/regexp-tests.factor
+++ b/basis/regexp/regexp-tests.factor
@@ -4,10 +4,6 @@ USING: regexp tools.test kernel sequences regexp.parser regexp.private
eval strings multiline accessors ;
IN: regexp-tests
-\ <regexp> must-infer
-\ compile-regexp must-infer
-\ matches? must-infer
-
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
[ t ] [ "a" "a*" <regexp> matches? ] unit-test
@@ -262,11 +258,11 @@ IN: regexp-tests
! Comment inside a regular expression
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
-[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval( -- ) ] unit-test
-[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval( -- ) ] unit-test
-[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval( -- ) ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
diff --git a/basis/regexp/transition-tables/transition-tables.factor b/basis/regexp/transition-tables/transition-tables.factor
index 3c33ae8846..f452e3d24a 100644
--- a/basis/regexp/transition-tables/transition-tables.factor
+++ b/basis/regexp/transition-tables/transition-tables.factor
@@ -11,12 +11,7 @@ TUPLE: transition-table transitions start-state final-states ;
H{ } clone >>transitions
H{ } clone >>final-states ;
-: maybe-initialize-key ( key hashtable -- )
- ! Why do we have to do this?
- 2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
-
:: (set-transition) ( from to obj hash -- )
- to condition? [ to hash maybe-initialize-key ] unless
from hash at
[ [ to obj ] dip set-at ]
[ to obj associate from hash set-at ] if* ;
@@ -25,7 +20,6 @@ TUPLE: transition-table transitions start-state final-states ;
transitions>> (set-transition) ;
:: (add-transition) ( from to obj hash -- )
- to hash maybe-initialize-key
from hash at
[ [ to obj ] dip push-at ]
[ to 1vector obj associate from hash set-at ] if* ;
diff --git a/basis/see/see-docs.factor b/basis/see/see-docs.factor
index 6d51b42a86..b2e99843c7 100644
--- a/basis/see/see-docs.factor
+++ b/basis/see/see-docs.factor
@@ -13,7 +13,12 @@ HELP: synopsis*
HELP: see
{ $values { "defspec" "a definition specifier" } }
-{ $contract "Prettyprints a definition." } ;
+{ $contract "Prettyprints a definition." }
+{ $examples
+ "A word:" { $code "\\ append see" }
+ "A method:" { $code "USE: arrays" "M\\ array length see" }
+ "A help article:" { $code "USE: help.topics" "\"help\" >link see" }
+} ;
HELP: see-methods
{ $values { "word" "a " { $link generic } " or a " { $link class } } }
diff --git a/basis/see/see-tests.factor b/basis/see/see-tests.factor
new file mode 100644
index 0000000000..3f11ec987e
--- /dev/null
+++ b/basis/see/see-tests.factor
@@ -0,0 +1,11 @@
+IN: see.tests
+USING: see tools.test io.streams.string math ;
+
+CONSTANT: test-const 10
+[ "IN: see.tests\nCONSTANT: test-const 10 inline\n" ]
+[ [ \ test-const see ] with-string-writer ] unit-test
+
+ALIAS: test-alias +
+
+[ "USING: math ;\nIN: see.tests\nALIAS: test-alias + inline\n" ]
+[ [ \ test-alias see ] with-string-writer ] unit-test
diff --git a/basis/see/see.factor b/basis/see/see.factor
index 32f49499db..37153b5229 100644
--- a/basis/see/see.factor
+++ b/basis/see/see.factor
@@ -1,13 +1,13 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
-classes.intersection classes.mixin classes.predicate
-classes.singleton classes.tuple classes.union combinators
-definitions effects generic generic.standard io io.pathnames
+classes.intersection classes.mixin classes.predicate classes.singleton
+classes.tuple classes.union combinators definitions effects generic
+generic.single generic.standard generic.hook io io.pathnames
io.streams.string io.styles kernel make namespaces prettyprint
prettyprint.backend prettyprint.config prettyprint.custom
-prettyprint.sections sequences sets sorting strings summary
-words words.symbol ;
+prettyprint.sections sequences sets sorting strings summary words
+words.symbol words.constant words.alias ;
IN: see
GENERIC: synopsis* ( defspec -- )
@@ -29,8 +29,16 @@ GENERIC: see* ( defspec -- )
: comment. ( text -- )
H{ { font-style italic } } styled-text ;
+GENERIC: print-stack-effect? ( word -- ? )
+
+M: parsing-word print-stack-effect? drop f ;
+M: symbol print-stack-effect? drop f ;
+M: constant print-stack-effect? drop f ;
+M: alias print-stack-effect? drop f ;
+M: word print-stack-effect? drop t ;
+
: stack-effect. ( word -- )
- [ [ parsing-word? ] [ symbol? ] bi or not ] [ stack-effect ] bi and
+ [ print-stack-effect? ] [ stack-effect ] bi and
[ effect>string comment. ] when* ;
<PRIVATE
@@ -68,9 +76,6 @@ M: hook-generic synopsis*
[ stack-effect. ]
} cleave ;
-M: method-spec synopsis*
- first2 method synopsis* ;
-
M: method-body synopsis*
[ definer. ]
[ "method-class" word-prop pprint-word ]
@@ -114,9 +119,6 @@ M: object see*
block>
] with-use ;
-M: method-spec see*
- first2 method see* ;
-
GENERIC: see-class* ( word -- )
M: union-class see-class*
diff --git a/basis/smtp/authors.txt b/basis/smtp/authors.txt
index 159b1e91e9..ad5e36ed58 100644
--- a/basis/smtp/authors.txt
+++ b/basis/smtp/authors.txt
@@ -1,3 +1,5 @@
Elie Chaftari
Dirk Vleugels
Slava Pestov
+Doug Coleman
+Daniel Ehrenberg
diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor
index 5d7791292b..dbff4fd214 100644
--- a/basis/smtp/server/server.factor
+++ b/basis/smtp/server/server.factor
@@ -36,6 +36,7 @@ SYMBOL: data-mode
: process ( -- )
read-crlf {
+ { [ dup not ] [ f ] }
{
[ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
[ "220 and..?\r\n" write flush t ]
diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor
index 453f4009e2..0b13113427 100644
--- a/basis/smtp/smtp-docs.factor
+++ b/basis/smtp/smtp-docs.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel quotations help.syntax help.markup
-io.sockets strings calendar ;
+io.sockets strings calendar io.encodings.utf8 ;
IN: smtp
HELP: smtp-domain
@@ -41,7 +41,9 @@ HELP: email
{ { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." }
{ { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." }
{ { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." }
- { { $slot "subject" } " The subject of the e-mail. A string." }
+ { { $slot "subject" } "The subject of the e-mail. A string." }
+ { { $slot "content-type" } { "The MIME type of the body. A string, default is " { $snippet "text/plain" } "." } }
+ { { $slot "encoding" } { "An encoding to send the body as. Default is " { $link utf8 } "." } }
{ { $slot "body" } " The body of the e-mail. A string." }
}
"The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional."
diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor
index 8a9107b905..b8df0b7b5b 100644
--- a/basis/smtp/smtp-tests.factor
+++ b/basis/smtp/smtp-tests.factor
@@ -4,8 +4,6 @@ namespaces logging accessors assocs sorting smtp.private
concurrency.promises system ;
IN: smtp.tests
-\ send-email must-infer
-
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ "hello\nworld" validate-address ] must-fail
@@ -16,7 +14,7 @@ IN: smtp.tests
[ { "hello" "." "world" } validate-message ] must-fail
[ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
- "hello\nworld" [ send-body ] with-string-writer
+ T{ email { body "hello\nworld" } } [ send-body ] with-string-writer
] unit-test
[ { "500 syntax error" } <response> check-response ]
@@ -51,7 +49,7 @@ IN: smtp.tests
[
{
{ "Content-Transfer-Encoding" "base64" }
- { "Content-Type" "Text/plain; charset=utf-8" }
+ { "Content-Type" "text/plain; charset=UTF-8" }
{ "From" "Doug <erg@factorcode.org>" }
{ "MIME-Version" "1.0" }
{ "Subject" "Factor rules" }
diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor
index 03b9d8af11..83457defa5 100644
--- a/basis/smtp/smtp.factor
+++ b/basis/smtp/smtp.factor
@@ -1,12 +1,12 @@
-! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
-! Slava Pestov, Doug Coleman.
+! Copyright (C) 2007, 2009 Elie CHAFTARI, Dirk Vleugels,
+! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays namespaces make io io.encodings.string
-io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
-io.encodings.ascii kernel logging sequences combinators
-splitting assocs strings math.order math.parser random system
-calendar summary calendar.format accessors sets hashtables
-base64 debugger classes prettyprint io.crlf ;
+USING: arrays namespaces make io io.encodings io.encodings.string
+io.encodings.utf8 io.encodings.iana io.encodings.binary
+io.encodings.ascii io.timeouts io.sockets io.sockets.secure io.crlf
+kernel logging sequences combinators splitting assocs strings
+math.order math.parser random system calendar summary calendar.format
+accessors sets hashtables base64 debugger classes prettyprint words ;
IN: smtp
SYMBOL: smtp-domain
@@ -44,6 +44,8 @@ TUPLE: email
{ cc array }
{ bcc array }
{ subject string }
+ { content-type string initial: "text/plain" }
+ { encoding word initial: utf8 }
{ body string } ;
: <email> ( -- email ) email new ; inline
@@ -85,9 +87,10 @@ M: message-contains-dot summary ( obj -- string )
"." over member?
[ message-contains-dot ] when ;
-: send-body ( body -- )
- utf8 encode
- >base64-lines write crlf
+: send-body ( email -- )
+ binary encode-output
+ [ body>> ] [ encoding>> ] bi encode >base64-lines write
+ ascii encode-output crlf
"." command ;
: quit ( -- )
@@ -162,9 +165,8 @@ M: plain-auth send-auth
: encode-header ( string -- string' )
dup aux>> [
- "=?utf-8?B?"
- swap utf8 encode >base64
- "?=" 3append
+ utf8 encode >base64
+ "=?utf-8?B?" "?=" surround
] when ;
ERROR: invalid-header-string string ;
@@ -195,24 +197,23 @@ ERROR: invalid-header-string string ;
! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ;
-: utf8-mime-header ( -- alist )
- {
- { "MIME-Version" "1.0" }
- { "Content-Transfer-Encoding" "base64" }
- { "Content-Type" "Text/plain; charset=utf-8" }
- } ;
+: email-content-type ( email -- content-type )
+ [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
-: email>headers ( email -- hashtable )
+: email>headers ( email -- assoc )
[
+ now timestamp>rfc822 "Date" set
+ message-id "Message-Id" set
+ "1.0" "MIME-Version" set
+ "base64" "Content-Transfer-Encoding" set
{
[ from>> "From" set ]
[ to>> ", " join "To" set ]
[ cc>> ", " join [ "Cc" set ] unless-empty ]
[ subject>> "Subject" set ]
+ [ email-content-type "Content-Type" set ]
} cleave
- now timestamp>rfc822 "Date" set
- message-id "Message-Id" set
- ] { } make-assoc utf8-mime-header append ;
+ ] { } make-assoc ;
: (send-email) ( headers email -- )
[
@@ -227,7 +228,7 @@ ERROR: invalid-header-string string ;
data get-ok
swap write-headers
crlf
- body>> send-body get-ok
+ send-body get-ok
quit get-ok
] with-smtp-connection ;
diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor
index cc89d497e7..beb378d4bd 100644
--- a/basis/sorting/slots/slots-docs.factor
+++ b/basis/sorting/slots/slots-docs.factor
@@ -6,19 +6,21 @@ IN: sorting.slots
HELP: compare-slots
{ $values
- { "sort-specs" "a sequence of accessors ending with a comparator" }
- { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
+ { "obj1" object }
+ { "obj2" object }
+ { "sort-specs" "a sequence of accessors ending with a comparator" }
+ { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
}
{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
-HELP: sort-by-slots
+HELP: sort-by
{ $values
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
- { "sortedseq" sequence }
+ { "seq'" sequence }
}
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
{ $examples
- "Sort by slot c, then b descending:"
+ "Sort by slot a, then b descending:"
{ $example
"USING: accessors math.order prettyprint sorting.slots ;"
"IN: scratchpad"
@@ -27,32 +29,18 @@ HELP: sort-by-slots
" T{ sort-me f 2 3 } T{ sort-me f 3 2 }"
" T{ sort-me f 4 3 } T{ sort-me f 2 1 }"
"}"
- "{ { a>> <=> } { b>> >=< } } sort-by-slots ."
+ "{ { a>> <=> } { b>> >=< } } sort-by ."
"{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}"
}
} ;
-HELP: split-by-slots
-{ $values
- { "accessor-seqs" "a sequence of sequences of tuple accessors" }
- { "quot" quotation }
-}
-{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
-
-HELP: sort-by
-{ $values
- { "seq" sequence } { "sort-seq" "a sequence of comparators" }
- { "sortedseq" sequence }
-}
-{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
-
ARTICLE: "sorting.slots" "Sorting by slots"
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
"Comparing two objects by a sequence of slots:"
{ $subsection compare-slots }
"Sorting a sequence of tuples by a slot/comparator pairs:"
-{ $subsection sort-by-slots }
-"Sorting a sequence by a sequence of comparators:"
-{ $subsection sort-by } ;
+{ $subsection sort-by }
+{ $subsection sort-keys-by }
+{ $subsection sort-values-by } ;
ABOUT: "sorting.slots"
diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor
index 83900461c3..5ebd4438fe 100644
--- a/basis/sorting/slots/slots-tests.factor
+++ b/basis/sorting/slots/slots-tests.factor
@@ -24,7 +24,7 @@ TUPLE: tuple2 d ;
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
- } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
+ } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by
] unit-test
[
@@ -42,43 +42,14 @@ TUPLE: tuple2 d ;
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
- } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots
+ } { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by
] unit-test
-[
- {
- {
- T{ sort-test { a 1 } { b 1 } { c 10 } }
- T{ sort-test { a 1 } { b 1 } { c 11 } }
- }
- { T{ sort-test { a 1 } { b 3 } { c 9 } } }
- {
- T{ sort-test { a 2 } { b 5 } { c 3 } }
- T{ sort-test { a 2 } { b 5 } { c 2 } }
- }
- }
-] [
- {
- T{ sort-test f 1 3 9 }
- T{ sort-test f 1 1 10 }
- T{ sort-test f 1 1 11 }
- T{ sort-test f 2 5 3 }
- T{ sort-test f 2 5 2 }
- }
- { { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep
- [ but-last-slice ] map split-by-slots [ >array ] map
-] unit-test
-
-: split-test ( seq -- seq' )
- { { a>> } { b>> } } split-by-slots ;
-
-[ split-test ] must-infer
+[ { } ]
+[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test
[ { } ]
-[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
-
-[ { } ]
-[ { } { } sort-by-slots ] unit-test
+[ { } { } sort-by ] unit-test
[
{
@@ -97,55 +68,7 @@ TUPLE: tuple2 d ;
T{ sort-test f 6 f f T{ tuple2 f 3 } }
T{ sort-test f 5 f f T{ tuple2 f 3 } }
T{ sort-test f 6 f f T{ tuple2 f 2 } }
- } { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots
-] unit-test
-
-[
- {
- {
- T{ sort-test
- { a 6 }
- { tuple2 T{ tuple2 { d 1 } } }
- }
- }
- {
- T{ sort-test
- { a 6 }
- { tuple2 T{ tuple2 { d 2 } } }
- }
- }
- {
- T{ sort-test
- { a 5 }
- { tuple2 T{ tuple2 { d 3 } } }
- }
- }
- {
- T{ sort-test
- { a 6 }
- { tuple2 T{ tuple2 { d 3 } } }
- }
- T{ sort-test
- { a 6 }
- { tuple2 T{ tuple2 { d 3 } } }
- }
- }
- {
- T{ sort-test
- { a 5 }
- { tuple2 T{ tuple2 { d 4 } } }
- }
- }
- }
-] [
- {
- T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
- T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
- T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
- T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
- T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
- T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
- } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
+ } { { tuple2>> d>> <=> } { a>> <=> } } sort-by
] unit-test
@@ -159,3 +82,15 @@ TUPLE: tuple2 d ;
{ { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
{ length-test<=> <=> } sort-by
] unit-test
+
+[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ]
+[
+ { { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
+ { length-test<=> <=> } sort-keys-by
+] unit-test
+
+[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ]
+[
+ { { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
+ { length-test<=> <=> } sort-values-by
+] unit-test
diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor
index efec960c27..e3b4bc88ca 100644
--- a/basis/sorting/slots/slots.factor
+++ b/basis/sorting/slots/slots.factor
@@ -1,45 +1,28 @@
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit fry kernel macros math.order
-sequences words sorting sequences.deep assocs splitting.monotonic
-math ;
+USING: arrays fry kernel math.order sequences sorting ;
IN: sorting.slots
-<PRIVATE
+: execute-comparator ( obj1 obj2 word -- <=>/f )
+ execute( obj1 obj2 -- <=> ) dup +eq+ eq? [ drop f ] when ;
-: short-circuit-comparator ( obj1 obj2 word -- comparator/? )
- execute dup +eq+ eq? [ drop f ] when ; inline
+: execute-accessor ( obj1 obj2 word -- obj1' obj2' )
+ '[ _ execute( tuple -- value ) ] bi@ ;
-: slot-comparator ( seq -- quot )
- [
- but-last-slice
- [ '[ [ _ execute ] bi@ ] ] map concat
- ] [
- peek
- '[ @ _ short-circuit-comparator ]
- ] bi ;
-
-PRIVATE>
-
-MACRO: compare-slots ( sort-specs -- <=> )
+: compare-slots ( obj1 obj2 sort-specs -- <=> )
#! sort-spec: { accessors comparator }
- [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
+ [
+ dup array? [
+ unclip-last-slice
+ [ [ execute-accessor ] each ] dip
+ ] when execute-comparator
+ ] with with map-find drop +eq+ or ;
-MACRO: sort-by-slots ( sort-specs -- quot )
- '[ [ _ compare-slots ] sort ] ;
+: sort-by-with ( seq sort-specs quot -- seq' )
+ swap '[ _ bi@ _ compare-slots ] sort ; inline
-MACRO: compare-seq ( seq -- quot )
- [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
+: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ;
-MACRO: sort-by ( sort-seq -- quot )
- '[ [ _ compare-seq ] sort ] ;
+: sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ;
-MACRO: sort-keys-by ( sort-seq -- quot )
- '[ [ first ] bi@ _ compare-seq ] sort ;
-
-MACRO: sort-values-by ( sort-seq -- quot )
- '[ [ second ] bi@ _ compare-seq ] sort ;
-
-MACRO: split-by-slots ( accessor-seqs -- quot )
- [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
- '[ [ _ 2&& ] slice monotonic-slice ] ;
+: sort-values-by ( seq sort-seq -- seq' ) [ second ] sort-by-with ;
diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor
index 9e867f4fbb..338b052316 100755
--- a/basis/stack-checker/backend/backend.factor
+++ b/basis/stack-checker/backend/backend.factor
@@ -1,10 +1,9 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry arrays generic io io.streams.string kernel math
-namespaces parser sequences strings vectors words quotations
-effects classes continuations assocs combinators
-compiler.errors accessors math.order definitions sets
-generic.standard.engines.tuple hints stack-checker.state
+USING: fry arrays generic io io.streams.string kernel math namespaces
+parser sequences strings vectors words quotations effects classes
+continuations assocs combinators compiler.errors accessors math.order
+definitions sets hints macros stack-checker.state
stack-checker.visitor stack-checker.errors stack-checker.values
stack-checker.recursive-state ;
IN: stack-checker.backend
@@ -121,19 +120,13 @@ M: object apply-object push-literal ;
: infer-r> ( n -- )
consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ;
-: undo-infer ( -- )
- recorded get [ f "inferred-effect" set-word-prop ] each ;
-
-: (consume/produce) ( effect -- inputs outputs )
- [ in>> length consume-d ] [ out>> length produce-d ] bi ;
-
: consume/produce ( effect quot: ( inputs outputs -- ) -- )
- '[ (consume/produce) @ ]
+ '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ]
[ terminated?>> [ terminate ] when ]
bi ; inline
-: infer-word-def ( word -- )
- [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
+: apply-word/effect ( word effect -- )
+ swap '[ _ #call, ] consume/produce ;
: end-infer ( -- )
meta-d clone #return, ;
@@ -141,56 +134,20 @@ M: object apply-object push-literal ;
: required-stack-effect ( word -- effect )
dup stack-effect [ ] [ missing-effect ] ?if ;
-: check-effect ( word effect -- )
- over required-stack-effect 2dup effect<=
- [ 3drop ] [ effect-error ] if ;
-
-: finish-word ( word -- )
- [ current-effect check-effect ]
- [ recorded get push ]
- [ t "inferred-effect" set-word-prop ]
- tri ;
-
-: cannot-infer-effect ( word -- * )
- "cannot-infer" word-prop rethrow ;
-
-: maybe-cannot-infer ( word quot -- )
- [ [ "cannot-infer" set-word-prop ] keep rethrow ] recover ; inline
-
-: infer-word ( word -- effect )
- [
- [
- init-inference
- init-known-values
- stack-visitor off
- dependencies off
- generic-dependencies off
- [ infer-word-def end-infer ]
- [ finish-word ]
- [ stack-effect ]
- tri
- ] with-scope
- ] maybe-cannot-infer ;
-
-: apply-word/effect ( word effect -- )
- swap '[ _ #call, ] consume/produce ;
-
-: call-recursive-word ( word -- )
- dup required-stack-effect apply-word/effect ;
-
-: cached-infer ( word -- )
- dup stack-effect apply-word/effect ;
+: infer-word ( word -- )
+ {
+ { [ dup macro? ] [ do-not-compile ] }
+ { [ dup "no-compile" word-prop ] [ do-not-compile ] }
+ [ dup required-stack-effect apply-word/effect ]
+ } cond ;
: with-infer ( quot -- effect visitor )
[
- [
- V{ } clone recorded set
- init-inference
- init-known-values
- stack-visitor off
- call
- end-infer
- current-effect
- stack-visitor get
- ] [ ] [ undo-infer ] cleanup
+ init-inference
+ init-known-values
+ stack-visitor off
+ call
+ end-infer
+ current-effect
+ stack-visitor get
] with-scope ; inline
diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor
index e5c0f23b30..b222cbbcf7 100644
--- a/basis/stack-checker/call-effect/call-effect-tests.factor
+++ b/basis/stack-checker/call-effect/call-effect-tests.factor
@@ -1,7 +1,16 @@
-USING: stack-checker.call-effect tools.test math kernel ;
+USING: stack-checker.call-effect tools.test math kernel math effects ;
IN: stack-checker.call-effect.tests
[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
\ No newline at end of file
+[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
+
+[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
+[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
+[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
+[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
+[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
+[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
+[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
+[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test
\ No newline at end of file
diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor
index bd1f7c73c3..b3b678d93d 100644
--- a/basis/stack-checker/call-effect/call-effect.factor
+++ b/basis/stack-checker/call-effect/call-effect.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.private effects fry
kernel kernel.private make sequences continuations quotations
-stack-checker stack-checker.transforms ;
+stack-checker stack-checker.transforms words math ;
IN: stack-checker.call-effect
! call( and execute( have complex expansions.
@@ -18,14 +18,36 @@ IN: stack-checker.call-effect
TUPLE: inline-cache value ;
-: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline
+: cache-hit? ( word/quot ic -- ? )
+ [ value>> eq? ] [ value>> ] bi and ; inline
-SYMBOL: +unknown+
+SINGLETON: +unknown+
GENERIC: cached-effect ( quot -- effect )
M: object cached-effect drop +unknown+ ;
+GENERIC: curry-effect ( effect -- effect' )
+
+M: +unknown+ curry-effect ;
+
+M: effect curry-effect
+ [ in>> length ] [ out>> length ] [ terminated?>> ] tri
+ pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if
+ effect boa ;
+
+M: curry cached-effect
+ quot>> cached-effect curry-effect ;
+
+: compose-effects* ( effect1 effect2 -- effect' )
+ {
+ { [ 2dup [ effect? ] both? ] [ compose-effects ] }
+ { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
+ } cond ;
+
+M: compose cached-effect
+ [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
+
M: quotation cached-effect
dup cached-effect>>
[ ] [
@@ -54,6 +76,8 @@ M: quotation cached-effect
\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
+\ call-effect-slow t "no-compile" set-word-prop
+
: call-effect-fast ( quot effect inline-cache -- )
2over call-effect-unsafe?
[ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
@@ -71,11 +95,13 @@ M: quotation cached-effect
]
] 0 define-transform
+\ call-effect t "no-compile" set-word-prop
+
: execute-effect-slow ( word effect -- )
[ '[ _ execute ] ] dip call-effect-slow ; inline
: execute-effect-unsafe? ( word effect -- ? )
- over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+ over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
: execute-effect-fast ( word effect inline-cache -- )
2over execute-effect-unsafe?
@@ -93,3 +119,5 @@ M: quotation cached-effect
inline-cache new '[ _ _ execute-effect-ic ] ;
\ execute-effect [ execute-effect>quot ] 1 define-transform
+
+\ execute-effect t "no-compile" set-word-prop
\ No newline at end of file
diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor
old mode 100644
new mode 100755
index 5b314a3154..6a67b815cd
--- a/basis/stack-checker/errors/errors-docs.factor
+++ b/basis/stack-checker/errors/errors-docs.factor
@@ -3,10 +3,9 @@ sequences.private words ;
IN: stack-checker.errors
HELP: literal-expected
-{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." }
-{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." }
+{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." }
{ $examples
- "In this example, words calling " { $snippet "literal-expected-example" } " will compile, even if " { $snippet "literal-expected-example" } " does not compile itself:"
+ "In this example, words calling " { $snippet "literal-expected-example" } " will have a static stac keffect, even if " { $snippet "literal-expected-example" } " does not:"
{ $code
": literal-expected-example ( quot -- )"
" [ call ] [ call ] bi ; inline"
@@ -16,10 +15,8 @@ HELP: literal-expected
HELP: unbalanced-branches-error
{ $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } }
{ $description "Throws an " { $link unbalanced-branches-error } "." }
-{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height." }
-{ $notes "Conditionals with variable stack effects are considered to be bad style and should be avoided since they do not compile."
-$nl
-"If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." }
+{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height. See " { $link "inference-branches" } " for details." }
+{ $notes "If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." }
{ $examples
{ $code
": unbalanced-branches-example ( a b c -- )"
@@ -86,25 +83,27 @@ HELP: inconsistent-recursive-call-error
}
} ;
-ARTICLE: "inference-errors" "Inference warnings and errors"
-"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "."
-$nl
-"Main wrapper for all inference warnings and errors:"
-{ $subsection inference-error }
-"Inference warnings:"
+ARTICLE: "inference-errors" "Stack checker errors"
+"These " { $link "inference" } " failure conditions are reported in one of two ways:"
+{ $list
+ { { $link "tools.inference" } " throws them as errors" }
+ { "The " { $link "compiler" } " reports them via " { $link "tools.errors" } }
+}
+"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):"
{ $subsection literal-expected }
-"Inference errors:"
-{ $subsection recursive-quotation-error }
-{ $subsection unbalanced-branches-error }
+"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"
{ $subsection effect-error }
-{ $subsection missing-effect }
-"Inference errors for inline recursive words:"
+"Error thrown when branches have incompatible stack effects (see " { $link "inference-branches" } "):"
+{ $subsection unbalanced-branches-error }
+"Inference errors for inline recursive words (see " { $link "inference-recursive-combinators" } "):"
{ $subsection undeclared-recursion-error }
{ $subsection diverging-recursion-error }
{ $subsection unbalanced-recursion-error }
{ $subsection inconsistent-recursive-call-error }
-"Retain stack usage errors:"
+"More obscure errors that are unlikely to arise in ordinary code:"
+{ $subsection recursive-quotation-error }
{ $subsection too-many->r }
-{ $subsection too-many-r> } ;
+{ $subsection too-many-r> }
+{ $subsection missing-effect } ;
ABOUT: "inference-errors"
diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor
index 07c26ad100..b1071df708 100644
--- a/basis/stack-checker/errors/errors.factor
+++ b/basis/stack-checker/errors/errors.factor
@@ -1,83 +1,38 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generic sequences io words arrays summary effects
-continuations assocs accessors namespaces compiler.errors
-stack-checker.values stack-checker.recursive-state ;
+USING: kernel stack-checker.values ;
IN: stack-checker.errors
-: pretty-word ( word -- word' )
- dup method-body? [ "method-generic" word-prop ] when ;
+TUPLE: inference-error ;
-TUPLE: inference-error error type word ;
+ERROR: do-not-compile < inference-error word ;
-M: inference-error compiler-error-type type>> ;
+ERROR: literal-expected < inference-error what ;
-: (inference-error) ( ... class type -- * )
- [ boa ] dip
- recursive-state get word>>
- \ inference-error boa rethrow ; inline
+ERROR: unbalanced-branches-error < inference-error branches quots ;
-: inference-error ( ... class -- * )
- +error+ (inference-error) ; inline
+ERROR: too-many->r < inference-error ;
-: inference-warning ( ... class -- * )
- +warning+ (inference-error) ; inline
+ERROR: too-many-r> < inference-error ;
-TUPLE: literal-expected what ;
+ERROR: missing-effect < inference-error word ;
-: literal-expected ( what -- * ) \ literal-expected inference-warning ;
+ERROR: effect-error < inference-error inferred declared ;
-M: object (literal) "literal value" literal-expected ;
+ERROR: recursive-quotation-error < inference-error quot ;
-TUPLE: unbalanced-branches-error branches quots ;
+ERROR: undeclared-recursion-error < inference-error word ;
-: unbalanced-branches-error ( branches quots -- * )
- \ unbalanced-branches-error inference-error ;
+ERROR: diverging-recursion-error < inference-error word ;
-TUPLE: too-many->r ;
+ERROR: unbalanced-recursion-error < inference-error word height ;
-: too-many->r ( -- * ) \ too-many->r inference-error ;
+ERROR: inconsistent-recursive-call-error < inference-error word ;
-TUPLE: too-many-r> ;
+ERROR: unknown-primitive-error < inference-error ;
-: too-many-r> ( -- * ) \ too-many-r> inference-error ;
+ERROR: transform-expansion-error < inference-error word error ;
-TUPLE: missing-effect word ;
+ERROR: bad-declaration-error < inference-error declaration ;
-: missing-effect ( word -- * )
- pretty-word \ missing-effect inference-error ;
-
-TUPLE: effect-error word inferred declared ;
-
-: effect-error ( word inferred declared -- * )
- \ effect-error inference-error ;
-
-TUPLE: recursive-quotation-error quot ;
-
-: recursive-quotation-error ( word -- * )
- \ recursive-quotation-error inference-error ;
-
-TUPLE: undeclared-recursion-error word ;
-
-: undeclared-recursion-error ( word -- * )
- \ undeclared-recursion-error inference-error ;
-
-TUPLE: diverging-recursion-error word ;
-
-: diverging-recursion-error ( word -- * )
- \ diverging-recursion-error inference-error ;
-
-TUPLE: unbalanced-recursion-error word height ;
-
-: unbalanced-recursion-error ( word height -- * )
- \ unbalanced-recursion-error inference-error ;
-
-TUPLE: inconsistent-recursive-call-error word ;
-
-: inconsistent-recursive-call-error ( word -- * )
- \ inconsistent-recursive-call-error inference-error ;
-
-TUPLE: unknown-primitive-error ;
-
-: unknown-primitive-error ( -- * )
- \ unknown-primitive-error inference-warning ;
+M: object (literal) "literal value" literal-expected ;
\ No newline at end of file
diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor
index 9dc82339b5..5be5722c23 100644
--- a/basis/stack-checker/errors/prettyprint/prettyprint.factor
+++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor
@@ -1,67 +1,62 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel prettyprint io debugger
sequences assocs stack-checker.errors summary effects ;
IN: stack-checker.errors.prettyprint
-M: inference-error error-help error>> error-help ;
+M: literal-expected summary
+ what>> "Got a computed value where a " " was expected" surround ;
-M: inference-error error.
- [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
+M: literal-expected error. summary print ;
-M: literal-expected error.
- "Got a computed value where a " write what>> write " was expected" print ;
+M: unbalanced-branches-error summary
+ drop "Unbalanced branches" ;
M: unbalanced-branches-error error.
- "Unbalanced branches:" print
+ dup summary print
[ quots>> ] [ branches>> [ length <effect> ] { } assoc>map ] bi zip
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
M: too-many->r summary
- drop
- "Quotation pushes elements on retain stack without popping them" ;
+ drop "Quotation pushes elements on retain stack without popping them" ;
M: too-many-r> summary
- drop
- "Quotation pops retain stack elements which it did not push" ;
+ drop "Quotation pops retain stack elements which it did not push" ;
-M: missing-effect error.
- "The word " write
- word>> pprint
- " must declare a stack effect" print ;
+M: missing-effect summary
+ drop "Missing stack effect declaration" ;
-M: effect-error error.
- "Stack effects of the word " write
- [ word>> pprint " do not match." print ]
- [ "Inferred: " write inferred>> . ]
- [ "Declared: " write declared>> . ] tri ;
+M: effect-error summary
+ drop "Stack effect declaration is wrong" ;
-M: recursive-quotation-error error.
- "The quotation " write
- quot>> pprint
- " calls itself." print
- "Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
+M: recursive-quotation-error summary
+ drop "Recursive quotation" ;
-M: undeclared-recursion-error error.
- "The inline recursive word " write
- word>> pprint
- " must be declared recursive" print ;
+M: undeclared-recursion-error summary
+ word>> name>>
+ "The inline recursive word " " must be declared recursive" surround ;
-M: diverging-recursion-error error.
- "The recursive word " write
- word>> pprint
- " digs arbitrarily deep into the stack" print ;
+M: diverging-recursion-error summary
+ word>> name>>
+ "The recursive word " " digs arbitrarily deep into the stack" surround ;
-M: unbalanced-recursion-error error.
- "The recursive word " write
- word>> pprint
- " leaves with the stack having the wrong height" print ;
+M: unbalanced-recursion-error summary
+ word>> name>>
+ "The recursive word " " leaves with the stack having the wrong height" surround ;
-M: inconsistent-recursive-call-error error.
- "The recursive word " write
- word>> pprint
- " calls itself with a different set of quotation parameters than were input" print ;
+M: inconsistent-recursive-call-error summary
+ word>> name>>
+ "The recursive word "
+ " calls itself with a different set of quotation parameters than were input" surround ;
-M: unknown-primitive-error error.
- drop
- "Cannot determine stack effect statically" print ;
+M: unknown-primitive-error summary
+ word>> name>> "The " " word cannot be called from optimized words" surround ;
+
+M: transform-expansion-error summary
+ word>> name>> "Macro expansion of " " threw an error" surround ;
+
+M: transform-expansion-error error.
+ [ summary print ] [ error>> error. ] bi ;
+
+M: do-not-compile summary
+ word>> name>> "Cannot compile call to " prepend ;
\ No newline at end of file
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index c55e69a8a2..f6f94bf20d 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -1,17 +1,18 @@
! 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
-words.private assocs summary compiler.units system.private
-combinators locals locals.backend locals.types words.private
+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
stack-checker.alien
stack-checker.state
@@ -57,8 +58,12 @@ IN: stack-checker.known-words
: infer-shuffle-word ( word -- )
"shuffle" word-prop infer-shuffle ;
+: check-declaration ( declaration -- declaration )
+ dup { [ array? ] [ [ class? ] all? ] } 1&&
+ [ bad-declaration-error ] unless ;
+
: infer-declare ( -- )
- pop-literal nip
+ pop-literal nip check-declaration
[ length ensure-d ] keep zip
#declare, ;
@@ -142,7 +147,7 @@ M: object infer-call*
apply-word/effect ;
: infer-execute-effect-unsafe ( -- )
- \ execute infer-effect-unsafe ;
+ \ (execute) infer-effect-unsafe ;
: infer-call-effect-unsafe ( -- )
\ call infer-effect-unsafe ;
@@ -216,10 +221,19 @@ M: object infer-call*
dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
alien-callback
-} [ t "special" set-word-prop ] each
+} [
+ [ t "special" set-word-prop ]
+ [ t "no-compile" set-word-prop ] bi
+] each
-{ call execute dispatch load-locals get-local drop-locals }
-[ t "no-compile" set-word-prop ] each
+! Exceptions to the above
+\ curry f "no-compile" set-word-prop
+\ compose f "no-compile" set-word-prop
+
+! More words not to compile
+\ call t "no-compile" set-word-prop
+\ execute t "no-compile" set-word-prop
+\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
dup called-dependency depends-on
@@ -229,14 +243,11 @@ M: object infer-call*
{ [ dup "primitive" word-prop ] [ infer-primitive ] }
{ [ dup "transform-quot" word-prop ] [ apply-transform ] }
{ [ dup "macro" word-prop ] [ apply-macro ] }
- { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
- { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
{ [ dup local? ] [ infer-local-reader ] }
{ [ dup local-reader? ] [ infer-local-reader ] }
{ [ dup local-writer? ] [ infer-local-writer ] }
{ [ dup local-word? ] [ infer-local-word ] }
- { [ dup recursive-word? ] [ call-recursive-word ] }
- [ dup infer-word apply-word/effect ]
+ [ infer-word ]
} cond ;
: define-primitive ( word inputs outputs -- )
@@ -279,14 +290,11 @@ M: object infer-call*
\ bignum>float { bignum } { float } define-primitive
\ bignum>float make-foldable
-\ <ratio> { integer integer } { ratio } define-primitive
-\ <ratio> make-foldable
+\ (string>float) { byte-array } { float } define-primitive
+\ (string>float) make-foldable
-\ string>float { string } { 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
@@ -300,9 +308,6 @@ M: object infer-call*
\ bits>double { integer } { float } define-primitive
\ bits>double make-foldable
-\ <complex> { real real } { complex } define-primitive
-\ <complex> make-foldable
-
\ both-fixnums? { object object } { object } define-primitive
\ fixnum+ { fixnum fixnum } { integer } define-primitive
@@ -460,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
@@ -476,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
@@ -593,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
@@ -663,3 +668,12 @@ M: object infer-call*
\ gc-stats { } { array } define-primitive
\ jit-compile { quotation } { } define-primitive
+
+\ lookup-method { object array } { word } define-primitive
+
+\ reset-dispatch-stats { } { } define-primitive
+\ dispatch-stats { } { array } define-primitive
+\ reset-inline-cache-stats { } { } define-primitive
+\ inline-cache-stats { } { array } define-primitive
+
+\ optimized? { word } { object } define-primitive
\ No newline at end of file
diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor
index 9abfb1fcd5..345e69e653 100644
--- a/basis/stack-checker/recursive-state/recursive-state.factor
+++ b/basis/stack-checker/recursive-state/recursive-state.factor
@@ -1,38 +1,19 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays sequences kernel sequences assocs
-namespaces stack-checker.recursive-state.tree ;
+USING: accessors kernel namespaces stack-checker.recursive-state.tree ;
IN: stack-checker.recursive-state
-TUPLE: recursive-state word words quotations inline-words ;
+TUPLE: recursive-state quotations inline-words ;
-: prepare-recursive-state ( word rstate -- rstate )
- swap >>word
- f >>quotations
- f >>inline-words ; inline
+: <recursive-state> ( -- state ) recursive-state new ; inline
-: initial-recursive-state ( word -- state )
- recursive-state new
- f >>words
- prepare-recursive-state ; inline
+<recursive-state> recursive-state set-global
-f initial-recursive-state recursive-state set-global
-
-: add-recursive-state ( word -- rstate )
- recursive-state get clone
- [ word>> dup ] keep [ store ] change-words
- prepare-recursive-state ;
-
-: add-local-quotation ( recursive-state quot -- rstate )
+: add-local-quotation ( rstate quot -- rstate )
swap clone [ dupd store ] change-quotations ;
: add-inline-word ( word label -- rstate )
- swap recursive-state get clone
- [ store ] change-inline-words ;
-
-: recursive-word? ( word -- ? )
- recursive-state get 2dup word>> eq?
- [ 2drop t ] [ words>> lookup ] if ;
+ swap recursive-state get clone [ store ] change-inline-words ;
: inline-recursive-label ( word -- label/f )
recursive-state get inline-words>> lookup ;
diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor
index 28090918bb..7d18482bff 100644
--- a/basis/stack-checker/stack-checker-docs.factor
+++ b/basis/stack-checker/stack-checker-docs.factor
@@ -4,38 +4,54 @@ stack-checker.backend
stack-checker.branches
stack-checker.errors
stack-checker.transforms
-stack-checker.state ;
+stack-checker.state
+continuations ;
IN: stack-checker
ARTICLE: "inference-simple" "Straight-line stack effects"
-"The simplest case to look at is that of a quotation which does not have any branches or recursion, and just pushes literals and calls words, each of which has a known stack effect."
+"The simplest case is when a piece of code does not have any branches or recursion, and just pushes literals and calls words."
$nl
-"Stack effect inference works by stepping through the quotation, while maintaining a \"shadow stack\" which tracks stack height at the current position in the quotation. Initially, the shadow stack is empty. If a word is encountered which expects more values than there are on the shadow stack, a global counter is incremented. This counter keeps track of the number of inputs the quotation expects on the stack. When inference is done, this counter, together with the final height of the shadow stack, gives the inferred stack effect."
-{ $subsection d-in }
-{ $subsection meta-d }
-"When a literal is encountered, it is simply pushed on the shadow stack. For example, the stack effect of the following quotation is inferred by pushing all three literals on the shadow stack, then taking the value of " { $link d-in } " and the length of " { $link meta-d } ":"
+"Pushing a literal has stack effect " { $snippet "( -- object )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "."
+$nl
+"The stack effect of each element in a code snippet is composed. The result is then the stack effect of the snippet."
+$nl
+"An example:"
{ $example "[ 1 2 3 ] infer." "( -- object object object )" }
-"In the following example, the call to " { $link + } " expects two values on the shadow stack, but only one value is present, the literal which was pushed previously. This increments the " { $link d-in } " counter by one:"
-{ $example "[ 2 + ] infer." "( object -- object )" }
-"After the call to " { $link + } ", the shadow stack contains a \"computed value placeholder\", since the inferencer has no way to know what the resulting value actually is (in fact it is arbitrary)." ;
+"Another example:"
+{ $example "[ 2 + ] infer." "( object -- object )" } ;
ARTICLE: "inference-combinators" "Combinator stack effects"
-"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
-{ $example "[ dup call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
-"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:"
-{ $example "[ [ 2 + ] call ] infer." "( object -- object )" }
-"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:"
-{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" }
-"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":"
-{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object )" }
-"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred."
+"If a word, call it " { $snippet "W" } ", calls a combinator, one of the following two conditions must hold:"
+{ $list
+ { "The combinator may be called with a quotation that is either a literal, or built from literals, " { $link curry } " and " { $link compose } "." }
+ { "The combinator must be called on an input parameter, or be built from input parameters, literals, " { $link curry } " and " { $link compose } ", " { $strong "if" } " the word " { $snippet "W" } " must be declared " { $link POSTPONE: inline } ". Then " { $snippet "W" } " is itself considered to be a combinator, and its callers must satisfy one of these two conditions." }
+}
+"If neither condition holds, the stack checker throws a " { $link literal-expected } " error, and an escape hatch such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by currying the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "."
+{ $heading "Examples" }
+{ $subheading "Calling a combinator" }
+"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":"
+{ $example "[ [ + ] curry map ] infer." "( object object -- object )" }
+{ $subheading "Defining an inline combinator" }
+"The following word calls a quotation twice; the word is declared " { $link POSTPONE: inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:"
+{ $code ": twice ( value quot -- result ) dup compose call ; inline" }
+"The following code now passes the stack checker; it would fail were " { $snippet "twice" } " not declared " { $link POSTPONE: inline } ":"
+{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( object -- object )" }
+{ $subheading "Defining a combinator for unknown quotations" }
+"In the next example, " { $link POSTPONE: call( } " must be used because the quotation the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:"
+{ $code
+ "TUPLE: action name quot ;"
+ ": perform ( value action -- result ) quot>> call( value -- result ) ;"
+}
+{ $subheading "Passing an unknown quotation to an inline combinator" }
+"Suppose we want to write :"
+{ $code ": perform ( values action -- results ) quot>> map ;" }
+"However this fails to pass the stack checker since there is no guarantee the quotation has the right stack effect for " { $link map } ". It can be wrapped in a new quotation with a declaration:"
+{ $code ": perform ( values action -- results )" " quot>> [ call( value -- result ) ] curry map ;" }
+{ $heading "Explanation" }
+"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised."
$nl
-"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "."
-$nl
-"Here is an example where the stack effect cannot be inferred:"
-{ $code ": foo ( -- n quot ) 0 [ + ] ;" "[ foo reduce ] infer." }
-"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":"
-{ $example ": foo ( -- n quot ) 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" }
+"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point."
+{ $heading "Limitations" }
"Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:"
{ $example
"[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help."
@@ -46,30 +62,25 @@ $nl
} ;
ARTICLE: "inference-branches" "Branch stack effects"
-"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "."
+"Conditionals such as " { $link if } " and combinators built on top have the same restrictions as " { $link POSTPONE: inline } " combinators (see " { $link "inference-combinators" } ") with the additional requirement that all branches leave the stack at the same height. If this is not the case, the stack checker throws a " { $link unbalanced-branches-error } "."
$nl
"If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example,"
{ $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" }
"The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ;
-ARTICLE: "inference-recursive" "Stack effects of recursive words"
-"When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect."
+ARTICLE: "inference-recursive-combinators" "Recursive combinator stack effects"
+"Most combinators do not call themselves recursively directly; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } ". In these cases, the rules outlined in " { $link "inference-combinators" } " apply."
$nl
-"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":"
-{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." }
-"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ;
-
-ARTICLE: "inference-recursive-combinators" "Recursive combinator inference"
-"Most combinators are not explicitly recursive; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } "."
-$nl
-"Combinators which are recursive require additional care."
-$nl
-"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "."
-$nl
-"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:"
+"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:"
+{ $heading "Input quotation declaration" }
+"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:"
{ $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"The following is correct:"
{ $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" }
+"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter."
+{ $heading "Data flow restrictions" }
+"The stack checker does not trace data flow in two instances."
+$nl
"An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:"
{ $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." }
"However a small change can be made:"
@@ -80,23 +91,48 @@ $nl
"[ [ 5 ] t foo ] infer."
} ;
-ARTICLE: "inference" "Stack effect inference"
-"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")."
-$nl
-"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:"
-{ $subsection infer. }
-"Instead of printing the inferred information, it can be returned as objects on the stack:"
+ARTICLE: "tools.inference" "Stack effect tools"
+{ $link "inference" } " can be used interactively to print stack effects of quotations without running them. It can also be used from " { $link "combinators.smart" } "."
{ $subsection infer }
-"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "."
+{ $subsection infer. }
+"There are also some words for working with " { $link effect } " instances. Getting a word's declared stack effect:"
+{ $subsection stack-effect }
+"Converting a stack effect to a string form:"
+{ $subsection effect>string }
+"Comparing effects:"
+{ $subsection effect-height }
+{ $subsection effect<= }
+{ $subsection effect= }
+"The class of stack effects:"
+{ $subsection effect }
+{ $subsection effect? } ;
+
+ARTICLE: "inference-escape" "Stack effect checking escape hatches"
+"In a static checking regime, sometimes it is necessary to step outside the boundaries and run some code which cannot be statically checked; perhaps this code is constructed at run-time. There are two ways to get around the static stack checker."
$nl
-"The following articles describe the implementation of the stack effect inference algorithm:"
+"If the stack effect of a word or quotation is known, but the word or quotation itself is not, " { $link POSTPONE: execute( } " or " { $link POSTPONE: call( } " can be used. See " { $link "call" } " for details."
+$nl
+"If the stack effect is not known, the code being called cannot manipulate the datastack directly. Instead, it must reflect the datastack into an array:"
+{ $subsection with-datastack }
+"The surrounding code has a static stack effect since " { $link with-datastack } " has one. However, the array passed in as input may be transformed arbitrarily by calling this combinator." ;
+
+ARTICLE: "inference" "Stack effect checking"
+"The " { $link "compiler" } " checks the " { $link "effects" } " of words before they can be run. This ensures that words take exactly the number of inputs and outputs that the programmer declares in source."
+$nl
+"Words that do not pass the stack checker are rejected and cannot be run, and so essentially this defines a very simple and permissive type system that nevertheless catches some invalid programs and enables compiler optimizations."
+$nl
+"If a word's stack effect cannot be inferred, a compile error is reported. See " { $link "compiler-errors" } "."
+$nl
+"The following articles describe how different control structures are handled by the stack checker."
{ $subsection "inference-simple" }
-{ $subsection "inference-recursive" }
{ $subsection "inference-combinators" }
{ $subsection "inference-recursive-combinators" }
{ $subsection "inference-branches" }
+"Stack checking catches several classes of errors."
{ $subsection "inference-errors" }
-{ $see-also "effects" } ;
+"Sometimes code with a dynamic stack effect has to be run."
+{ $subsection "inference-escape" }
+{ $see-also "effects" "tools.inference" "tools.errors" } ;
ABOUT: "inference"
@@ -109,7 +145,6 @@ HELP: inference-error
"The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "."
} ;
-
HELP: infer
{ $values { "quot" "a quotation" } { "effect" "an instance of " { $link effect } } }
{ $description "Attempts to infer the quotation's stack effect. For interactive testing, the " { $link infer. } " word should be called instead since it presents the output in a nicely formatted manner." }
@@ -121,11 +156,3 @@ HELP: infer.
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
{ infer infer. } related-words
-
-HELP: forget-errors
-{ $description "Removes markers indicating which words do not have stack effects."
-$nl
-"The stack effect inference code remembers which words failed to infer as an optimization, so that it does not try to infer the stack effect of words which do not have one over and over again." }
-{ $notes "Usually this word does not need to be called directly; if a word failed to compile because of a stack effect error, fixing the word definition clears the flag automatically. However, if words failed to compile due to external factors which were subsequently rectified, such as an unavailable C library or a missing or broken compiler transform, this flag can be cleared for all words:"
-{ $code "forget-errors" }
-"Subsequent invocations of the compiler will consider all words for compilation." } ;
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index 117b6845b8..919cd098f6 100644
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -10,7 +10,7 @@ sequences.private destructors combinators eval locals.backend
system compiler.units ;
IN: stack-checker.tests
-\ infer. must-infer
+[ 1234 infer ] must-fail
{ 0 2 } [ 2 "Hello" ] must-infer-as
{ 1 2 } [ dup ] must-infer-as
@@ -65,11 +65,6 @@ IN: stack-checker.tests
{ 1 1 } [ simple-recursion-2 ] must-infer-as
-: bad-recursion-2 ( obj -- obj )
- dup [ dup first swap second bad-recursion-2 ] [ ] if ;
-
-[ [ bad-recursion-2 ] infer ] must-fail
-
: funny-recursion ( obj -- obj )
dup [ funny-recursion 1 ] [ 2 ] if drop ;
@@ -196,94 +191,11 @@ DEFER: blah4
over string? [ 2array throw ] unless
] must-infer-as
-! Regression
-
-! This order of branches works
-DEFER: do-crap
-: more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ;
-: do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ;
-[ [ do-crap ] infer ] must-fail
-
-! This one does not
-DEFER: do-crap*
-: more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ;
-: do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ;
-[ [ do-crap* ] infer ] must-fail
-
! Regression
: too-deep ( a b -- c )
dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline recursive
{ 2 1 } [ too-deep ] must-infer-as
-! Error reporting is wrong
-MATH: xyz ( a b -- c )
-M: fixnum xyz 2array ;
-M: float xyz
- [ 3 ] bi@ swapd [ 2array swap ] dip 2array swap ;
-
-[ [ xyz ] infer ] [ inference-error? ] must-fail-with
-
-! Doug Coleman discovered this one while working on the
-! calendar library
-DEFER: A
-DEFER: B
-DEFER: C
-
-: A ( a -- )
- dup {
- [ drop ]
- [ A ]
- [ \ A no-method ]
- [ dup C A ]
- } dispatch ;
-
-: B ( b -- )
- dup {
- [ C ]
- [ B ]
- [ \ B no-method ]
- [ dup B B ]
- } dispatch ;
-
-: C ( c -- )
- dup {
- [ A ]
- [ C ]
- [ \ C no-method ]
- [ dup B C ]
- } dispatch ;
-
-{ 1 0 } [ A ] must-infer-as
-{ 1 0 } [ B ] must-infer-as
-{ 1 0 } [ C ] must-infer-as
-
-! I found this bug by thinking hard about the previous one
-DEFER: Y
-: X ( a b -- c d ) dup [ swap Y ] [ ] if ;
-: Y ( a b -- c d ) X ;
-
-{ 2 2 } [ X ] must-infer-as
-{ 2 2 } [ Y ] must-infer-as
-
-! This one comes from UI code
-DEFER: #1
-: #2 ( a b: ( -- ) -- ) dup [ call ] [ 2drop ] if ; inline
-: #3 ( a -- ) [ #1 ] #2 ;
-: #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ;
-: #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ;
-
-[ \ #4 def>> infer ] must-fail
-[ [ #1 ] infer ] must-fail
-
-! Similar
-DEFER: bar
-: foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ;
-: bar ( a b -- ) [ 2 2 + ] t foo drop call drop ;
-
-[ [ foo ] infer ] must-fail
-
-[ 1234 infer ] must-fail
-
! This used to hang
[ [ [ dup call ] dup call ] infer ]
[ inference-error? ] must-fail-with
@@ -311,16 +223,6 @@ DEFER: bar
[ [ [ [ drop 3 ] swap call ] dup call ] infer ]
[ inference-error? ] must-fail-with
-! This form should not have a stack effect
-
-: bad-recursion-1 ( a -- b )
- dup [ drop bad-recursion-1 5 ] [ ] if ;
-
-[ [ bad-recursion-1 ] infer ] must-fail
-
-: bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ;
-[ [ bad-bin ] infer ] must-fail
-
[ [ 1 drop-locals ] infer ] [ inference-error? ] must-fail-with
! Regression
@@ -333,114 +235,14 @@ DEFER: bar
[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail
-! Test number protocol
-\ bitor must-infer
-\ bitand must-infer
-\ bitxor must-infer
-\ mod must-infer
-\ /i must-infer
-\ /f must-infer
-\ /mod must-infer
-\ + must-infer
-\ - must-infer
-\ * must-infer
-\ / must-infer
-\ < must-infer
-\ <= must-infer
-\ > must-infer
-\ >= must-infer
-\ number= must-infer
-
-! Test object protocol
-\ = must-infer
-\ clone must-infer
-\ hashcode* must-infer
-
-! Test sequence protocol
-\ length must-infer
-\ nth must-infer
-\ set-length must-infer
-\ set-nth must-infer
-\ new must-infer
-\ new-resizable must-infer
-\ like must-infer
-\ lengthen must-infer
-
-! Test assoc protocol
-\ at* must-infer
-\ set-at must-infer
-\ new-assoc must-infer
-\ delete-at must-infer
-\ clear-assoc must-infer
-\ assoc-size must-infer
-\ assoc-like must-infer
-\ assoc-clone-like must-infer
-\ >alist must-infer
{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as
-! Test some random library words
-\ 1quotation must-infer
-\ string>number must-infer
-\ get must-infer
-
-\ push must-infer
-\ append must-infer
-\ peek must-infer
-
-\ reverse must-infer
-\ member? must-infer
-\ remove must-infer
-\ natural-sort must-infer
-
-\ forget must-infer
-\ define-class must-infer
-\ define-tuple-class must-infer
-\ define-union-class must-infer
-\ define-predicate-class must-infer
-\ instance? must-infer
-\ next-method-quot must-infer
-
! Test words with continuations
{ 0 0 } [ [ drop ] callcc0 ] must-infer-as
{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as
{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as
{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as
-\ dispose must-infer
-
-! Test stream protocol
-\ set-timeout must-infer
-\ stream-read must-infer
-\ stream-read1 must-infer
-\ stream-readln must-infer
-\ stream-read-until must-infer
-\ stream-write must-infer
-\ stream-write1 must-infer
-\ stream-nl must-infer
-\ stream-flush must-infer
-
-! Test stream utilities
-\ lines must-infer
-\ contents must-infer
-
-! Test prettyprinting
-\ . must-infer
-\ short. must-infer
-\ unparse must-infer
-
-\ describe must-infer
-\ error. must-infer
-
-! Test odds and ends
-\ io-thread must-infer
-
-! Incorrect stack declarations on inline recursive words should
-! be caught
-: fooxxx ( a b -- c ) over [ foo ] when ; inline
-: barxxx ( a b -- c ) fooxxx ;
-
-[ [ barxxx ] infer ] must-fail
-
! A typo
{ 1 0 } [ { [ ] } dispatch ] must-infer-as
@@ -463,7 +265,6 @@ DEFER: deferred-word
{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
-
DEFER: an-inline-word
: normal-word-3 ( -- )
@@ -503,9 +304,7 @@ ERROR: custom-error ;
] unit-test
! Regression
-: missing->r-check ( a -- ) 1 load-locals ;
-
-[ [ missing->r-check ] infer ] must-fail
+[ [ 1 load-locals ] infer ] must-fail
! Corner case
[ [ [ f dup ] [ dup ] produce ] infer ] must-fail
@@ -513,35 +312,12 @@ ERROR: custom-error ;
[ [ [ f dup ] [ ] while ] infer ] must-fail
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline recursive
-
[ [ erg's-inference-bug ] infer ] must-fail
-
-: inference-invalidation-a ( -- ) ;
-: inference-invalidation-b ( quot -- ) [ inference-invalidation-a ] dip call ; inline
-: inference-invalidation-c ( a b -- c ) [ + ] inference-invalidation-b ; inline
-
-[ 7 ] [ 4 3 inference-invalidation-c ] unit-test
-
-{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
-
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test
-
-[ 3 ] [ inference-invalidation-c ] unit-test
-
-{ 0 1 } [ inference-invalidation-c ] must-infer-as
-
-GENERIC: inference-invalidation-d ( obj -- )
-
-M: object inference-invalidation-d inference-invalidation-c 2drop ;
-
-\ inference-invalidation-d must-infer
-
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test
-
-[ [ inference-invalidation-d ] infer ] must-fail
+FORGET: erg's-inference-bug
: bad-recursion-3 ( -- ) dup [ [ bad-recursion-3 ] dip ] when ; inline recursive
[ [ bad-recursion-3 ] infer ] must-fail
+FORGET: bad-recursion-3
: bad-recursion-4 ( -- ) 4 [ dup call roll ] times ; inline recursive
[ [ [ ] [ 1 2 3 ] over dup bad-recursion-4 ] infer ] must-fail
@@ -562,6 +338,8 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
[ [ unbalanced-retain-usage ] infer ] [ inference-error? ] must-fail-with
+FORGET: unbalanced-retain-usage
+
DEFER: eee'
: ddd' ( ? -- ) [ f eee' ] when ; inline recursive
: eee' ( ? -- ) [ swap [ ] ] dip ddd' call ; inline recursive
@@ -587,4 +365,10 @@ DEFER: eee'
[ forget-test ] must-infer
[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
-[ forget-test ] must-infer
\ No newline at end of file
+[ forget-test ] must-infer
+
+[ [ cond ] infer ] must-fail
+[ [ bi ] infer ] must-fail
+[ at ] must-infer
+
+[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer
\ No newline at end of file
diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor
index e18a6f0840..759988a61f 100644
--- a/basis/stack-checker/stack-checker.factor
+++ b/basis/stack-checker/stack-checker.factor
@@ -16,17 +16,4 @@ M: callable infer ( quot -- effect )
#! Safe to call from inference transforms.
infer effect>string print ;
-: forget-errors ( -- )
- all-words [
- dup subwords [ f "cannot-infer" set-word-prop ] each
- f "cannot-infer" set-word-prop
- ] each ;
-
-: forget-effects ( -- )
- forget-errors
- all-words [
- dup subwords [ f "inferred-effect" set-word-prop ] each
- f "inferred-effect" set-word-prop
- ] each ;
-
"stack-checker.call-effect" require
\ No newline at end of file
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index 6ae12dbd0c..a76d302a7e 100644
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -64,6 +64,3 @@ SYMBOL: generic-dependencies
: depends-on-generic ( generic class -- )
generic-dependencies get dup
[ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
-
-! Words we've inferred the stack effect of, for rollback
-SYMBOL: recorded
diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor
index 0aa3876907..fe0fa08356 100644
--- a/basis/stack-checker/transforms/transforms-tests.factor
+++ b/basis/stack-checker/transforms/transforms-tests.factor
@@ -1,11 +1,16 @@
IN: stack-checker.transforms.tests
USING: sequences stack-checker.transforms tools.test math kernel
-quotations stack-checker accessors combinators words arrays
+quotations stack-checker stack-checker.errors accessors combinators words arrays
classes classes.tuple ;
+: compose-n ( quot n -- ) "OOPS" throw ;
+
+<<
: compose-n-quot ( word n -- quot' ) <repetition> >quotation ;
-: compose-n ( quot n -- ) compose-n-quot call ;
\ compose-n [ compose-n-quot ] 2 define-transform
+\ compose-n t "no-compile" set-word-prop
+>>
+
: compose-n-test ( a b c -- x ) 2 \ + compose-n ;
[ 6 ] [ 1 2 3 compose-n-test ] unit-test
@@ -70,4 +75,11 @@ DEFER: curry-folding-test ( quot -- )
: member?-test ( a -- ? ) { 1 2 3 10 7 58 } member? ;
[ f ] [ 1.0 member?-test ] unit-test
-[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test
\ No newline at end of file
+[ t ] [ \ member?-test def>> first [ member?-test ] all? ] unit-test
+
+! Macro expansion should throw its own type of error
+: bad-macro ( -- ) ;
+
+\ bad-macro [ "OOPS" throw ] 0 define-transform
+
+[ [ bad-macro ] infer ] [ inference-error? ] must-fail-with
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index c2b348f5f1..8113a662d6 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -1,30 +1,27 @@
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors arrays kernel kernel.private combinators.private
-words sequences generic math math.order namespaces make quotations assocs
-combinators combinators.short-circuit classes.tuple
+words sequences generic math math.order namespaces quotations
+assocs combinators combinators.short-circuit classes.tuple
classes.tuple.private effects summary hashtables classes generic sets
definitions generic.standard slots.private continuations locals
-generalizations stack-checker.backend stack-checker.state
-stack-checker.visitor stack-checker.errors stack-checker.values
-stack-checker.recursive-state ;
+sequences.private generalizations stack-checker.backend
+stack-checker.state stack-checker.visitor stack-checker.errors
+stack-checker.values stack-checker.recursive-state ;
IN: stack-checker.transforms
-: give-up-transform ( word -- )
- {
- { [ dup "inferred-effect" word-prop ] [ cached-infer ] }
- { [ dup recursive-word? ] [ call-recursive-word ] }
- [ dup infer-word apply-word/effect ]
- } cond ;
+: call-transformer ( word stack quot -- newquot )
+ '[ _ _ with-datastack [ length 1 assert= ] [ first ] bi nip ]
+ [ transform-expansion-error ]
+ recover ;
:: ((apply-transform)) ( word quot values stack rstate -- )
rstate recursive-state
- [ stack quot with-datastack first ] with-variable
+ [ word stack quot call-transformer ] with-variable
[
- word inlined-dependency depends-on
values [ length meta-d shorten-by ] [ #drop, ] bi
rstate infer-quot
- ] [ word give-up-transform ] if* ;
+ ] [ word infer-word ] if* ;
: literals? ( values -- ? ) [ literal-value? ] all? ;
@@ -36,7 +33,7 @@ IN: stack-checker.transforms
[ first literal recursion>> ] tri
] if
((apply-transform))
- ] [ 2drop give-up-transform ] if ;
+ ] [ 2drop infer-word ] if ;
: apply-transform ( word -- )
[ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri
@@ -54,6 +51,8 @@ IN: stack-checker.transforms
! Combinators
\ cond [ cond>quot ] 1 define-transform
+\ cond t "no-compile" set-word-prop
+
\ case [
[
[ no-case ]
@@ -66,14 +65,24 @@ IN: stack-checker.transforms
] if-empty
] 1 define-transform
+\ case t "no-compile" set-word-prop
+
\ cleave [ cleave>quot ] 1 define-transform
+\ cleave t "no-compile" set-word-prop
+
\ 2cleave [ 2cleave>quot ] 1 define-transform
+\ 2cleave t "no-compile" set-word-prop
+
\ 3cleave [ 3cleave>quot ] 1 define-transform
+\ 3cleave t "no-compile" set-word-prop
+
\ spread [ spread>quot ] 1 define-transform
+\ spread t "no-compile" set-word-prop
+
\ (call-next-method) [
[
[ "method-class" word-prop ]
@@ -85,6 +94,8 @@ IN: stack-checker.transforms
] bi
] 1 define-transform
+\ (call-next-method) t "no-compile" set-word-prop
+
! Constructors
\ boa [
dup tuple-class? [
@@ -95,51 +106,79 @@ IN: stack-checker.transforms
] [ drop f ] if
] 1 define-transform
+\ boa t "no-compile" set-word-prop
+
\ new [
dup tuple-class? [
dup inlined-dependency depends-on
- [
- [ all-slots [ initial>> literalize , ] each ]
- [ literalize , ] bi
- \ boa ,
- ] [ ] make
+ [ all-slots [ initial>> literalize ] map ]
+ [ tuple-layout '[ _ <tuple-boa> ] ]
+ bi append
] [ drop f ] if
] 1 define-transform
-! Membership testing
-CONSTANT: bit-member-max 256
+! Fast at for integer maps
+CONSTANT: lookup-table-at-max 256
-: bit-member? ( seq -- ? )
+: lookup-table-at? ( assoc -- ? )
#! Can we use a fast byte array test here?
{
- [ length 4 > ]
- [ [ integer? ] all? ]
- [ [ 0 bit-member-max between? ] any? ]
+ [ assoc-size 4 > ]
+ [ values [ ] all? ]
+ [ keys [ integer? ] all? ]
+ [ keys [ 0 lookup-table-at-max between? ] all? ]
} 1&& ;
-: bit-member-seq ( seq -- flags )
- [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ;
+: lookup-table-seq ( assoc -- table )
+ [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
-: bit-member-quot ( seq -- newquot )
- bit-member-seq
+: lookup-table-quot ( seq -- newquot )
+ lookup-table-seq
'[
- _ {
- { [ over fixnum? ] [ ?nth 1 eq? ] }
- { [ over bignum? ] [ ?nth 1 eq? ] }
- [ 2drop f ]
- } cond
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup >boolean
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
] ;
-: member-quot ( seq -- newquot )
- dup bit-member? [
- bit-member-quot
- ] [
- dup length 4 <= [
- [ drop f ] swap
- [ literalize [ t ] ] { } map>assoc linear-case-quot
+: fast-lookup-table-at? ( assoc -- ? )
+ values {
+ [ [ integer? ] all? ]
+ [ [ 0 254 between? ] all? ]
+ } 1&& ;
+
+: fast-lookup-table-seq ( assoc -- table )
+ lookup-table-seq [ 255 or ] B{ } map-as ;
+
+: fast-lookup-table-quot ( seq -- newquot )
+ fast-lookup-table-seq
+ '[
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
+ ] ;
+
+: at-quot ( assoc -- quot )
+ dup lookup-table-at? [
+ dup fast-lookup-table-at? [
+ fast-lookup-table-quot
] [
- unique [ key? ] curry
+ lookup-table-quot
] if
+ ] [ drop f ] if ;
+
+\ at* [ at-quot ] 1 define-transform
+
+! Membership testing
+: member-quot ( seq -- newquot )
+ dup length 4 <= [
+ [ drop f ] swap
+ [ literalize [ t ] ] { } map>assoc linear-case-quot
+ ] [
+ unique [ key? ] curry
] if ;
\ member? [
@@ -170,4 +209,4 @@ CONSTANT: bit-member-max 256
\ shuffle [
shuffle-mapping nths-quot
-] 1 define-transform
\ No newline at end of file
+] 1 define-transform
diff --git a/basis/strings/tables/tables-tests.factor b/basis/strings/tables/tables-tests.factor
index a77312897a..9429772f4a 100644
--- a/basis/strings/tables/tables-tests.factor
+++ b/basis/strings/tables/tables-tests.factor
@@ -2,3 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test strings.tables ;
IN: strings.tables.tests
+
+[ { "A BB" "CC D" } ] [ { { "A" "BB" } { "CC" "D" } } format-table ] unit-test
+
+[ { "A C" "B " "D E" } ] [ { { "A\nB" "C" } { "D" "E" } } format-table ] unit-test
\ No newline at end of file
diff --git a/basis/strings/tables/tables.factor b/basis/strings/tables/tables.factor
index c6ccba5a78..51032264c7 100644
--- a/basis/strings/tables/tables.factor
+++ b/basis/strings/tables/tables.factor
@@ -1,21 +1,30 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences fry math.order ;
+USING: kernel sequences fry math.order splitting ;
IN: strings.tables
<PRIVATE
-: format-column ( seq ? -- seq )
- [
- dup [ length ] [ max ] map-reduce
- '[ _ CHAR: \s pad-tail ] map
- ] unless ;
-
: map-last ( seq quot -- seq )
[ dup length <reversed> ] dip '[ 0 = @ ] 2map ; inline
+: max-length ( seq -- n )
+ [ length ] [ max ] map-reduce ;
+
+: format-row ( seq ? -- seq )
+ [
+ dup max-length
+ '[ _ "" pad-tail ] map
+ ] unless ;
+
+: format-column ( seq ? -- seq )
+ [
+ dup max-length
+ '[ _ CHAR: \s pad-tail ] map
+ ] unless ;
+
PRIVATE>
: format-table ( table -- seq )
- flip [ format-column ] map-last
- flip [ " " join ] map ;
\ No newline at end of file
+ [ [ [ string-lines ] map ] dip format-row flip ] map-last concat
+ flip [ format-column ] map-last flip [ " " join ] map ;
\ No newline at end of file
diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor
index 3ea037352c..b0bd5a2ff5 100644
--- a/basis/syndication/syndication-tests.factor
+++ b/basis/syndication/syndication-tests.factor
@@ -2,9 +2,6 @@ USING: syndication io kernel io.files tools.test io.encodings.binary
calendar urls xml.writer ;
IN: syndication.tests
-\ download-feed must-infer
-\ feed>xml must-infer
-
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor
index a1d7e50594..dbdb69b3e9 100644
--- a/basis/threads/threads-docs.factor
+++ b/basis/threads/threads-docs.factor
@@ -48,7 +48,7 @@ ARTICLE: "thread-impl" "Thread implementation"
{ $subsection sleep-queue } ;
ARTICLE: "threads" "Lightweight co-operative threads"
-"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested."
+"Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested."
$nl
"Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads."
$nl
diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor
index adac84338d..610a664c7b 100644
--- a/basis/threads/threads-tests.factor
+++ b/basis/threads/threads-tests.factor
@@ -31,7 +31,7 @@ yield
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
-:: spawn-namespace-test ( -- )
+:: spawn-namespace-test ( -- ? )
[let | p [ <promise> ] g [ gensym ] |
[
g "x" set
diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor
index f47852aca7..bbd2ac2ca8 100644
--- a/basis/tools/annotations/annotations-tests.factor
+++ b/basis/tools/annotations/annotations-tests.factor
@@ -18,7 +18,7 @@ M: integer some-generic 1+ ;
[ 4 ] [ 3 some-generic ] unit-test
-[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test
+[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test
[ 2 ] [ 3 some-generic ] unit-test
@@ -33,7 +33,7 @@ M: object another-generic ;
\ another-generic watch
-[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval ] unit-test
+[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval( -- ) ] unit-test
[ ] [ \ another-generic reset ] unit-test
@@ -43,6 +43,6 @@ GENERIC: blah-generic ( a -- b )
M: string blah-generic ;
-{ string blah-generic } watch
+[ ] [ M\ string blah-generic watch ] unit-test
[ "hi" ] [ "hi" blah-generic ] unit-test
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index 8c3d95f2b8..2639d48be2 100644
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -3,7 +3,7 @@
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
definitions compiler.units namespaces assocs tools.walker
-tools.time generic inspector fry ;
+tools.time generic inspector fry tools.continuations ;
IN: tools.annotations
GENERIC: reset ( word -- )
@@ -20,9 +20,6 @@ M: word reset
f "unannotated-def" set-word-prop
] [ drop ] if ;
-M: method-spec reset
- first2 method reset ;
-
ERROR: cannot-annotate-twice word ;
<PRIVATE
@@ -32,9 +29,6 @@ ERROR: cannot-annotate-twice word ;
cannot-annotate-twice
] when ;
-: method-spec>word ( obj -- word )
- dup method-spec? [ first2 method ] when ;
-
: save-unannotated-def ( word -- )
dup def>> "unannotated-def" set-word-prop ;
@@ -44,7 +38,7 @@ ERROR: cannot-annotate-twice word ;
PRIVATE>
: annotate ( word quot -- )
- [ method-spec>word check-annotate-twice ] dip
+ [ check-annotate-twice ] dip
[ over save-unannotated-def (annotate) ] with-compilation-unit ;
<PRIVATE
@@ -103,9 +97,6 @@ M: generic annotate-methods
M: word annotate-methods
annotate ;
-M: method-spec annotate-methods
- annotate ;
-
: breakpoint ( word -- )
[ add-breakpoint ] annotate-methods ;
diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor
index 14cec8e85f..00d86a1608 100644
--- a/basis/tools/completion/completion.factor
+++ b/basis/tools/completion/completion.factor
@@ -1,22 +1,22 @@
! 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 ;
+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 ch i full -- accum i ? )
- index-from
- [
- [ swap push ] 2keep 1+ t
+:: (fuzzy) ( accum i full ch -- accum i full ? )
+ ch i full index-from [
+ :> i i accum push
+ accum i 1+ full t
] [
- drop f -1 f
+ f -1 full f
] if* ;
: fuzzy ( full short -- indices )
- dup length <vector> -rot 0 -rot
- [ -rot [ (fuzzy) ] keep swap ] all? 3drop ;
+ dup [ length <vector> 0 ] curry 2dip
+ [ (fuzzy) ] all? 3drop ;
: (runs) ( runs n seq -- runs n )
[
diff --git a/basis/tools/continuations/authors.txt b/basis/tools/continuations/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/tools/continuations/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/tools/continuations/continuations.factor b/basis/tools/continuations/continuations.factor
new file mode 100644
index 0000000000..8c572f4ae3
--- /dev/null
+++ b/basis/tools/continuations/continuations.factor
@@ -0,0 +1,156 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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 ;
+IN: tools.continuations
+
+<PRIVATE
+
+: after-break ( object -- )
+ {
+ { [ dup continuation? ] [ (continue) ] }
+ { [ dup not ] [ "Single stepping abandoned" rethrow ] }
+ } cond ;
+
+PRIVATE>
+
+SYMBOL: break-hook
+
+: break ( -- )
+ continuation callstack >>call
+ break-hook get call( continuation -- continuation' )
+ after-break ;
+
+\ break t "break?" set-word-prop
+
+GENERIC: add-breakpoint ( quot -- quot' )
+
+<PRIVATE
+
+M: callable add-breakpoint
+ dup [ break ] head? [ \ break prefix ] unless ;
+
+M: array add-breakpoint
+ [ add-breakpoint ] map ;
+
+M: object add-breakpoint ;
+
+: (step-into-quot) ( quot -- ) add-breakpoint call ;
+
+: (step-into-dip) ( quot -- ) add-breakpoint dip ;
+
+: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
+
+: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
+
+: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
+
+: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
+
+: (step-into-execute) ( word -- )
+ {
+ { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
+ { [ dup single-generic? ] [ effective-method (step-into-execute) ] }
+ { [ dup uses \ suspend swap member? ] [ execute break ] }
+ { [ dup primitive? ] [ execute break ] }
+ [ def>> (step-into-quot) ]
+ } cond ;
+
+\ (step-into-execute) t "step-into?" set-word-prop
+
+: (step-into-continuation) ( -- )
+ continuation callstack >>call break ;
+
+: (step-into-call-next-method) ( method -- )
+ next-method-quot (step-into-quot) ;
+
+<< {
+ (step-into-quot)
+ (step-into-dip)
+ (step-into-2dip)
+ (step-into-3dip)
+ (step-into-if)
+ (step-into-dispatch)
+ (step-into-execute)
+ (step-into-continuation)
+ (step-into-call-next-method)
+} [ t "no-compile" set-word-prop ] each >>
+
+: 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
+
+PRIVATE>
+
+: continuation-step ( continuation -- continuation' )
+ [
+ 2dup length = [ nip [ break ] append ] [
+ 2dup nth \ break = [ nip ] [
+ swap 1+ cut [ break ] glue
+ ] if
+ ] if
+ ] change-frame ;
+
+: continuation-step-out ( continuation -- continuation' )
+ [ nip \ break suffix ] change-frame ;
+
+
+{
+ { call [ (step-into-quot) ] }
+ { dip [ (step-into-dip) ] }
+ { 2dip [ (step-into-2dip) ] }
+ { 3dip [ (step-into-3dip) ] }
+ { execute [ (step-into-execute) ] }
+ { if [ (step-into-if) ] }
+ { dispatch [ (step-into-dispatch) ] }
+ { continuation [ (step-into-continuation) ] }
+ { (call-next-method) [ (step-into-call-next-method) ] }
+} [ "step-into" set-word-prop ] assoc-each
+
+! Never step into these words
+: don't-step-into ( word -- )
+ dup [ execute break ] curry "step-into" set-word-prop ;
+
+{
+ >n ndrop >c c>
+ continue continue-with
+ stop suspend (spawn)
+} [ don't-step-into ] each
+
+\ break [ break ] "step-into" set-word-prop
+
+: continuation-step-into ( continuation -- continuation' )
+ [
+ swap cut [
+ swap %
+ [ \ break , ] [
+ unclip {
+ { [ dup \ break eq? ] [ , ] }
+ { [ dup quotation? ] [ add-breakpoint , \ break , ] }
+ { [ dup array? ] [ add-breakpoint , \ break , ] }
+ { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
+ [ , \ break , ]
+ } cond %
+ ] if-empty
+ ] [ ] make
+ ] change-frame ;
+
+: continuation-current ( continuation -- obj )
+ call>>
+ [ innermost-frame-scan 1+ ]
+ [ innermost-frame-quot ] bi ?nth ;
diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor
index f49ac7ea76..9108777554 100644
--- a/basis/tools/crossref/crossref-docs.factor
+++ b/basis/tools/crossref/crossref-docs.factor
@@ -1,15 +1,57 @@
-USING: help.markup help.syntax words definitions prettyprint ;
+USING: help.markup help.syntax words definitions prettyprint
+tools.crossref.private math quotations assocs kernel ;
IN: tools.crossref
-ARTICLE: "tools.crossref" "Cross-referencing tools"
+ARTICLE: "tools.crossref" "Definition cross referencing"
+"Definitions can answer a sequence of definitions they directly depend on:"
+{ $subsection uses }
+"An inverted index of the above:"
+{ $subsection get-crossref }
+"Words to access it:"
+{ $subsection usage }
+{ $subsection smart-usage }
+"Tools for interactive use:"
{ $subsection usage. }
+{ $subsection vocab-uses. }
+{ $subsection vocab-usage. }
{ $see-also "definitions" "words" "see" } ;
ABOUT: "tools.crossref"
+HELP: uses
+{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
+{ $description "Outputs a sequence of definitions directory called by the given definition." }
+{ $notes "The sequence might include the definition itself, if it is a recursive word." }
+{ $examples
+ "We can ask the " { $link sq } " word to produce a list of words it calls:"
+ { $unchecked-example "\ sq uses ." "{ dup * }" }
+} ;
+
+HELP: crossref
+{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } ". This variable is reset to " { $link f } " every time a definition is added or removed. Call " { $link get-crossref } " to lazily construct the graph instead of using this variable directly." } ;
+
+HELP: get-crossref
+{ $values { "crossref" assoc } }
+{ $description "Outputs the cross-referencing index, mapping definitions to usages, building it first if necessary." }
+{ $notes "This word is used to implement " { $link usage } " and " { $link usage. } "." } ;
+
+HELP: crossref-def
+{ $values { "defspec" "a definition specifier" } }
+{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." }
+$low-level-note ;
+
+HELP: usage
+{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
+{ $description "Outputs a sequence of definitions that directly call the given definition." }
+{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
+
HELP: usage.
{ $values { "word" "a word" } }
{ $description "Prints an list of all callers of a word. This may include the word itself, if it is recursive." }
{ $examples { $code "\\ reverse usage." } } ;
+HELP: quot-uses
+{ $values { "obj" object } { "assoc" "an assoc with words as keys" } }
+{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ;
+
{ usage usage. } related-words
diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor
index d08a17fd02..80f5367fb6 100755
--- a/basis/tools/crossref/crossref-tests.factor
+++ b/basis/tools/crossref/crossref-tests.factor
@@ -1,6 +1,6 @@
USING: math kernel sequences io.files io.pathnames
tools.crossref tools.test parser namespaces source-files generic
-definitions ;
+definitions words accessors compiler.units ;
IN: tools.crossref.tests
GENERIC: foo ( a b -- c )
@@ -11,3 +11,40 @@ M: integer foo + ;
[ t ] [ integer \ foo method \ + usage member? ] unit-test
[ t ] [ \ foo usage [ pathname? ] any? ] unit-test
+
+! Issues with forget
+GENERIC: generic-forget-test-1 ( a b -- c )
+
+M: integer generic-forget-test-1 / ;
+
+[ t ] [
+ \ / usage [ word? ] filter
+ [ name>> "integer=>generic-forget-test-1" = ] any?
+] unit-test
+
+[ ] [
+ [ \ generic-forget-test-1 forget ] with-compilation-unit
+] unit-test
+
+[ f ] [
+ \ / usage [ word? ] filter
+ [ name>> "integer=>generic-forget-test-1" = ] any?
+] unit-test
+
+GENERIC: generic-forget-test-2 ( a b -- c )
+
+M: sequence generic-forget-test-2 = ;
+
+[ t ] [
+ \ = usage [ word? ] filter
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
+] unit-test
+
+[ ] [
+ [ M\ sequence generic-forget-test-2 forget ] with-compilation-unit
+] unit-test
+
+[ f ] [
+ \ = usage [ word? ] filter
+ [ name>> "sequence=>generic-forget-test-2" = ] any?
+] unit-test
\ No newline at end of file
diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor
index 36ccaadc98..6082933bcb 100644
--- a/basis/tools/crossref/crossref.factor
+++ b/basis/tools/crossref/crossref.factor
@@ -1,9 +1,100 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs definitions io io.styles kernel prettyprint
-sorting see ;
+USING: words assocs definitions io io.pathnames io.styles kernel
+prettyprint sorting see sets sequences arrays hashtables help.crossref
+help.topics help.markup quotations accessors source-files namespaces
+graphs vocabs generic generic.single threads compiler.units init ;
IN: tools.crossref
+SYMBOL: crossref
+
+GENERIC: uses ( defspec -- seq )
+
+<PRIVATE
+
+SYMBOL: visited
+
+GENERIC# quot-uses 1 ( obj assoc -- )
+
+M: object quot-uses 2drop ;
+
+M: word quot-uses over crossref? [ conjoin ] [ 2drop ] if ;
+
+: (seq-uses) ( seq assoc -- )
+ [ quot-uses ] curry each ;
+
+: seq-uses ( seq assoc -- )
+ over visited get memq? [ 2drop ] [
+ over visited get push
+ (seq-uses)
+ ] if ;
+
+: assoc-uses ( assoc' assoc -- )
+ over visited get memq? [ 2drop ] [
+ over visited get push
+ [ >alist ] dip (seq-uses)
+ ] if ;
+
+M: array quot-uses seq-uses ;
+
+M: hashtable quot-uses assoc-uses ;
+
+M: callable quot-uses seq-uses ;
+
+M: wrapper quot-uses [ wrapped>> ] dip quot-uses ;
+
+M: callable uses ( quot -- assoc )
+ V{ } clone visited [
+ H{ } clone [ quot-uses ] keep keys
+ ] with-variable ;
+
+M: word uses def>> uses ;
+
+M: link uses { $subsection $link $see-also } article-links ;
+
+M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ;
+
+GENERIC: crossref-def ( defspec -- )
+
+M: object crossref-def
+ dup uses crossref get add-vertex ;
+
+M: word crossref-def
+ [ call-next-method ] [ subwords [ crossref-def ] each ] bi ;
+
+: build-crossref ( -- crossref )
+ "Computing usage index... " write flush yield
+ H{ } clone crossref [
+ all-words
+ source-files get keys [ <pathname> ] map
+ [ [ crossref-def ] each ] bi@
+ crossref get
+ ] with-variable
+ "done" print flush ;
+
+: get-crossref ( -- crossref )
+ crossref global [ drop build-crossref ] cache ;
+
+GENERIC: irrelevant? ( defspec -- ? )
+
+M: object irrelevant? drop f ;
+
+M: default-method irrelevant? drop t ;
+
+M: predicate-engine irrelevant? drop t ;
+
+PRIVATE>
+
+: usage ( defspec -- seq ) get-crossref at keys ;
+
+GENERIC: smart-usage ( defspec -- seq )
+
+M: object smart-usage usage [ irrelevant? not ] filter ;
+
+M: method-body smart-usage "method-generic" word-prop smart-usage ;
+
+M: f smart-usage drop \ f smart-usage ;
+
: synopsis-alist ( definitions -- alist )
[ [ synopsis ] keep ] { } map>assoc ;
@@ -15,3 +106,34 @@ IN: tools.crossref
: usage. ( word -- )
smart-usage sorted-definitions. ;
+
+: vocab-xref ( vocab quot -- vocabs )
+ [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
+ [
+ [ [ word? ] [ generic? not ] bi and ] filter [
+ dup method-body?
+ [ "method-generic" word-prop ] when
+ vocabulary>>
+ ] map
+ ] gather natural-sort remove sift ; inline
+
+: vocabs. ( seq -- )
+ [ dup >vocab-link write-object nl ] each ;
+
+: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
+
+: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;
+
+: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
+
+: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;
+
+<PRIVATE
+
+SINGLETON: invalidate-crossref
+
+M: invalidate-crossref definitions-changed 2drop crossref global delete-at ;
+
+[ invalidate-crossref add-definition-observer ] "tools.crossref" add-init-hook
+
+PRIVATE>
\ No newline at end of file
diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor
index 28a32790dc..b74548a65f 100755
--- a/basis/tools/deploy/backend/backend.factor
+++ b/basis/tools/deploy/backend/backend.factor
@@ -3,12 +3,11 @@
USING: namespaces make continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
continuations math definitions mirrors splitting parser classes
-summary layouts vocabs.loader prettyprint.config prettyprint
-debugger io.streams.c io.files io.files.temp io.pathnames
-io.directories io.directories.hierarchy io.backend quotations
-io.launcher words.private tools.deploy.config
-tools.deploy.config.editor bootstrap.image io.encodings.utf8
-destructors accessors ;
+summary layouts vocabs.loader prettyprint.config prettyprint debugger
+io.streams.c io.files io.files.temp io.pathnames io.directories
+io.directories.hierarchy io.backend quotations io.launcher
+tools.deploy.config tools.deploy.config.editor bootstrap.image
+io.encodings.utf8 destructors accessors hashtables ;
IN: tools.deploy.backend
: copy-vm ( executable bundle-name -- vm )
@@ -88,7 +87,7 @@ DEFER: ?make-staging-image
[ drop ] [ make-staging-image ] if ;
: make-deploy-config ( vocab -- file )
- [ deploy-config unparse-use ]
+ [ deploy-config vocab-roots get vocab-roots associate assoc-union unparse-use ]
[ "deploy-config-" prepend temp-file ] bi
[ utf8 set-file-contents ] keep ;
diff --git a/basis/tools/deploy/config/editor/editor.factor b/basis/tools/deploy/config/editor/editor.factor
index ac89e3290b..78d86a4707 100644
--- a/basis/tools/deploy/config/editor/editor.factor
+++ b/basis/tools/deploy/config/editor/editor.factor
@@ -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 )
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 79335fd032..fd43d1ccc9 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io.backend io.streams.c init fry
namespaces make assocs kernel parser lexer strings.parser vocabs
-sequences words words.private memory kernel.private
+sequences words memory kernel.private
continuations io vocabs.loader system strings sets
vectors quotations byte-arrays sorting compiler.units
definitions generic generic.standard tools.deploy.config ;
@@ -15,6 +15,7 @@ QUALIFIED: definitions
QUALIFIED: init
QUALIFIED: layouts
QUALIFIED: source-files
+QUALIFIED: source-files.errors
QUALIFIED: vocabs
IN: tools.deploy.shaker
@@ -36,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 ( -- )
@@ -96,14 +97,13 @@ IN: tools.deploy.shaker
{
"alias"
"boa-check"
- "cannot-infer"
"coercer"
"combination"
- "compiled-status"
"compiled-generic-uses"
"compiled-uses"
"constraints"
"custom-inlining"
+ "decision-tree"
"declared-effect"
"default"
"default-method"
@@ -113,15 +113,12 @@ IN: tools.deploy.shaker
"engines"
"forgotten"
"identities"
- "if-intrinsics"
- "infer"
- "inferred-effect"
"inline"
"inlined-block"
"input-classes"
"instances"
"interval"
- "intrinsics"
+ "intrinsic"
"lambda"
"loc"
"local-reader"
@@ -138,7 +135,7 @@ IN: tools.deploy.shaker
"method-generic"
"modular-arithmetic"
"no-compile"
- "optimizer-hooks"
+ "owner-generic"
"outputs"
"participants"
"predicate"
@@ -151,17 +148,13 @@ IN: tools.deploy.shaker
"register"
"register-size"
"shuffle"
- "slot-names"
"slots"
"special"
"specializer"
- "step-into"
- "step-into?"
! UI needs this
! "superclass"
"transform-n"
"transform-quot"
- "tuple-dispatch-generic"
"type"
"writer"
"writing"
@@ -170,8 +163,6 @@ IN: tools.deploy.shaker
strip-prettyprint? [
{
- "break-before"
- "break-after"
"delimiter"
"flushable"
"foldable"
@@ -266,8 +257,8 @@ IN: tools.deploy.shaker
compiled-crossref
compiled-generic-crossref
compiler-impl
+ compiler.errors:compiler-errors
definition-observers
- definitions:crossref
interactive-vocabs
layouts:num-tags
layouts:num-types
@@ -277,6 +268,7 @@ IN: tools.deploy.shaker
lexer-factory
print-use-hook
root-cache
+ source-files.errors:error-types
vocabs:dictionary
vocabs:load-vocab-hook
word
@@ -356,12 +348,10 @@ IN: tools.deploy.shaker
: finish-deploy ( final-image -- )
"Finishing up" show
- [ { } set-datastack ] dip
- { } set-retainstack
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
- [ save-image-and-exit ] call-clear ;
+ save-image-and-exit ;
SYMBOL: deploy-vocab
@@ -378,9 +368,9 @@ SYMBOL: deploy-vocab
[:c]
[print-error]
'[
- [ _ execute ] [
- _ execute nl
- _ execute
+ [ _ execute( obj -- ) ] [
+ _ execute( obj -- ) nl
+ _ execute( obj -- )
] recover
] %
] if
@@ -425,10 +415,10 @@ SYMBOL: deploy-vocab
: deploy-error-handler ( quot -- )
[
strip-debugger?
- [ error-continuation get call>> callstack>array die ]
+ [ error-continuation get call>> callstack>array die 1 exit ]
! Don't reference these words literally, if we're stripping the
! debugger out we don't want to load the prettyprinter at all
- [ [:c] execute nl [print-error] execute flush ] if
+ [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
1 exit
] recover ; inline
diff --git a/basis/tools/deploy/test/11/11.factor b/basis/tools/deploy/test/11/11.factor
index b4f8622627..3310686f05 100644
--- a/basis/tools/deploy/test/11/11.factor
+++ b/basis/tools/deploy/test/11/11.factor
@@ -3,6 +3,6 @@
USING: eval ;
IN: tools.deploy.test.11
-: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval ;
+: foo ( -- ) "USING: math prettyprint ; 2 2 + ." eval( -- ) ;
MAIN: foo
\ No newline at end of file
diff --git a/basis/tools/deploy/test/7/7.factor b/basis/tools/deploy/test/7/7.factor
index a16e3c82c5..5d6816121d 100644
--- a/basis/tools/deploy/test/7/7.factor
+++ b/basis/tools/deploy/test/7/7.factor
@@ -9,7 +9,7 @@ GENERIC: my-generic ( x -- b )
M: integer my-generic sq ;
-M: fixnum my-generic call-next-method my-var get call ;
+M: fixnum my-generic call-next-method my-var get call( a -- b ) ;
: test-7 ( -- )
[ 1 + ] my-var set-global
diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor
index eb780e40cc..f997a6eb3a 100644
--- a/basis/tools/deploy/test/test.factor
+++ b/basis/tools/deploy/test/test.factor
@@ -16,4 +16,5 @@ IN: tools.deploy.test
: run-temp-image ( -- )
vm
"-i=" "test.image" temp-file append
- 2array try-process ;
\ No newline at end of file
+ 2array
+ <process> swap >>command +closed+ >>stdin try-process ;
\ No newline at end of file
diff --git a/basis/tools/disassembler/disassembler-tests.factor b/basis/tools/disassembler/disassembler-tests.factor
index 96f5a04378..89ca265bf6 100644
--- a/basis/tools/disassembler/disassembler-tests.factor
+++ b/basis/tools/disassembler/disassembler-tests.factor
@@ -1,6 +1,4 @@
IN: tools.disassembler.tests
-USING: math classes.tuple prettyprint.custom
-tools.disassembler tools.test strings ;
+USING: kernel fry vocabs tools.disassembler tools.test sequences ;
-[ ] [ \ + disassemble ] unit-test
-[ ] [ { string pprint* } disassemble ] unit-test
+"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each
\ No newline at end of file
diff --git a/basis/tools/disassembler/disassembler.factor b/basis/tools/disassembler/disassembler.factor
index 83b7dfef81..744318a0a4 100755
--- a/basis/tools/disassembler/disassembler.factor
+++ b/basis/tools/disassembler/disassembler.factor
@@ -16,8 +16,6 @@ M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
M: word disassemble word-xt 2array disassemble ;
-M: method-spec disassemble first2 method disassemble ;
-
cpu x86?
"tools.disassembler.udis"
"tools.disassembler.gdb" ?
diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor
index 51e399c1c3..cd9dd9cf4b 100755
--- a/basis/tools/disassembler/udis/udis.factor
+++ b/basis/tools/disassembler/udis/udis.factor
@@ -3,7 +3,7 @@
USING: tools.disassembler namespaces combinators
alien alien.syntax alien.c-types lexer parser kernel
sequences layouts math math.order alien.libraries
-math.parser system make fry arrays ;
+math.parser system make fry arrays libc destructors ;
IN: tools.disassembler.udis
<<
@@ -47,11 +47,14 @@ FUNCTION: uint ud_insn_len ( ud* u ) ;
FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
: <ud> ( -- ud )
- "ud" <c-object>
+ "ud" malloc-object &free
dup ud_init
dup cell-bits ud_set_mode
dup UD_SYN_INTEL ud_set_syntax ;
+: with-ud ( quot: ( ud -- ) -- )
+ [ [ <ud> ] dip call ] with-destructors ; inline
+
SINGLETON: udis-disassembler
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
@@ -82,10 +85,12 @@ SINGLETON: udis-disassembler
] { } make ;
M: udis-disassembler disassemble* ( from to -- buffer )
- [ <ud> ] 2dip {
+ '[
+ _ _
[ drop ud_set_pc ]
[ buf/len ud_set_input_buffer ]
[ 2drop (disassemble) format-disassembly ]
- } 3cleave ;
+ 3tri
+ ] with-ud ;
udis-disassembler disassembler-backend set-global
diff --git a/basis/tools/errors/authors.txt b/basis/tools/errors/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/tools/errors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor
new file mode 100644
index 0000000000..4eb9115d05
--- /dev/null
+++ b/basis/tools/errors/errors-docs.factor
@@ -0,0 +1,48 @@
+IN: tools.errors
+USING: help.markup help.syntax source-files.errors words io
+compiler.errors classes ;
+
+ARTICLE: "compiler-errors" "Compiler errors"
+"After loading a vocabulary, you might see a message like:"
+{ $code
+ ":errors - print 2 compiler errors"
+}
+"This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "."
+$nl
+"Words to view errors:"
+{ $subsection :errors }
+{ $subsection :linkage }
+"Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ;
+
+HELP: compiler-error
+{ $values { "error" compiler-error } }
+{ $description "Saves the error for viewing with " { $link :errors } "." } ;
+
+HELP: linkage-error
+{ $values { "error" linkage-error } { "word" word } { "class" class } }
+{ $description "Saves the error for viewing with " { $link :linkage } "." } ;
+
+HELP: :errors
+{ $description "Prints all compiler errors." } ;
+
+HELP: :linkage
+{ $description "Prints all C library interface linkage errors." } ;
+
+{ :errors :linkage } related-words
+
+HELP: errors.
+{ $values { "errors" "a sequence of " { $link source-file-error } " instances" } }
+{ $description "Prints a list of errors, grouped by source file." } ;
+
+ARTICLE: "tools.errors" "Batch error reporting"
+"Some tools, such as the " { $link "compiler" } ", " { $link "tools.test" } " and " { $link "help.lint" } " need to report multiple errors at a time. Each error is associated with a source file, line number, and optionally, a definition. " { $link "errors" } " cannot be used for this purpose, so the " { $vocab-link "source-files.errors" } " vocabulary provides an alternative mechanism. Note that the words in this vocabulary are used for implementation only; to actually list errors, consult the documentation for the relevant tools."
+$nl
+"Source file errors inherit from a class:"
+{ $subsection source-file-error }
+"Printing an error summary:"
+{ $subsection error-summary }
+"Printing a list of errors:"
+{ $subsection errors. }
+"Batch errors are reported in the " { $link "ui.tools.error-list" } "." ;
+
+ABOUT: "tools.errors"
\ No newline at end of file
diff --git a/basis/tools/errors/errors-tests.factor b/basis/tools/errors/errors-tests.factor
new file mode 100644
index 0000000000..709adafb4e
--- /dev/null
+++ b/basis/tools/errors/errors-tests.factor
@@ -0,0 +1,13 @@
+USING: compiler.errors stack-checker.errors tools.test words ;
+IN: tools.errors
+
+DEFER: blah
+
+[ ] [
+ {
+ T{ compiler-error
+ { error T{ do-not-compile f blah } }
+ { asset blah }
+ }
+ } errors.
+] unit-test
\ No newline at end of file
diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor
new file mode 100644
index 0000000000..b53d4ef7a2
--- /dev/null
+++ b/basis/tools/errors/errors.factor
@@ -0,0 +1,45 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs debugger io kernel sequences source-files.errors
+summary accessors continuations make math.parser io.styles namespaces
+compiler.errors prettyprint ;
+IN: tools.errors
+
+#! Tools for source-files.errors. Used by tools.tests and others
+#! for error reporting
+
+M: source-file-error compute-restarts error>> compute-restarts ;
+
+M: source-file-error error-help error>> error-help ;
+
+CONSTANT: +listener-input+ "<Listener input>"
+
+M: source-file-error summary
+ [
+ [ file>> [ % ": " % ] [ +listener-input+ % ] if* ]
+ [ line#>> [ # ] when* ] bi
+ ] "" make ;
+
+M: source-file-error error.
+ [ summary print nl ]
+ [ asset>> [ "Asset: " write short. nl ] when* ]
+ [ error>> error. ]
+ tri ;
+
+: errors. ( errors -- )
+ group-by-source-file sort-errors
+ [
+ [ nl "==== " write +listener-input+ or print nl ]
+ [ [ nl ] [ error. ] interleave ]
+ bi*
+ ] assoc-each ;
+
+: :errors ( -- ) compiler-errors get values errors. ;
+
+: :linkage ( -- ) linkage-errors get values errors. ;
+
+M: not-compiled summary
+ word>> name>> "The word " " cannot be executed because it failed to compile" surround ;
+
+M: not-compiled error.
+ [ summary print nl ] [ error>> error. ] bi ;
\ No newline at end of file
diff --git a/basis/tools/errors/model/authors.txt b/basis/tools/errors/model/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/tools/errors/model/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/tools/errors/model/model.factor b/basis/tools/errors/model/model.factor
new file mode 100644
index 0000000000..c874363fe6
--- /dev/null
+++ b/basis/tools/errors/model/model.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: models source-files.errors namespaces models.delay init
+kernel calendar ;
+IN: tools.errors.model
+
+SYMBOLS: (error-list-model) error-list-model ;
+
+(error-list-model) [ f <model> ] initialize
+
+error-list-model [ (error-list-model) get-global 100 milliseconds <delay> ] initialize
+
+SINGLETON: updater
+
+M: updater errors-changed drop f (error-list-model) get-global set-model ;
+
+[ updater add-error-observer ] "ui.tools.error-list" add-init-hook
+
diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor
index 8d882099de..146a119a63 100755
--- a/basis/tools/files/files.factor
+++ b/basis/tools/files/files.factor
@@ -75,7 +75,7 @@ M: object file-spec>string ( file-listing spec -- string )
: list-files-slow ( listing-tool -- array )
[ path>> ] [ sort>> ] [ specs>> ] tri '[
[ dup name>> file-info file-listing boa ] map
- _ [ sort-by-slots ] when*
+ _ [ sort-by ] when*
[ _ [ file-spec>string ] with map ] map
] with-directory-entries ; inline
diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor
index 63b55729fb..666e051088 100644
--- a/basis/tools/hexdump/hexdump.factor
+++ b/basis/tools/hexdump/hexdump.factor
@@ -16,10 +16,11 @@ IN: tools.hexdump
16 * >hex 8 CHAR: 0 pad-head write "h: " write ;
: >hex-digit ( digit -- str )
- >hex 2 CHAR: 0 pad-head " " append ;
+ >hex 2 CHAR: 0 pad-head ;
: >hex-digits ( bytes -- str )
- [ >hex-digit ] { } map-as concat 48 CHAR: \s pad-tail ;
+ [ >hex-digit " " append ] { } map-as concat
+ 48 CHAR: \s pad-tail ;
: >ascii ( bytes -- str )
[ [ printable? ] keep CHAR: . ? ] "" map-as ;
diff --git a/basis/tools/memory/memory-tests.factor b/basis/tools/memory/memory-tests.factor
index 60b54c2a0d..4b75cf0bfa 100644
--- a/basis/tools/memory/memory-tests.factor
+++ b/basis/tools/memory/memory-tests.factor
@@ -1,8 +1,5 @@
USING: tools.test tools.memory ;
IN: tools.memory.tests
-\ room. must-infer
[ ] [ room. ] unit-test
-
-\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test
diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor
index a786cdfef1..efd2e164a3 100644
--- a/basis/tools/profiler/profiler-docs.factor
+++ b/basis/tools/profiler/profiler-docs.factor
@@ -1,5 +1,5 @@
-USING: tools.profiler.private tools.time help.markup help.syntax
-quotations io strings words definitions ;
+USING: tools.profiler.private tools.time tools.crossref
+help.markup help.syntax quotations io strings words definitions ;
IN: tools.profiler
ARTICLE: "profiler-limitations" "Profiler limitations"
@@ -23,7 +23,7 @@ $nl
{ $subsection vocabs-profile. }
{ $subsection method-profile. }
{ $subsection "profiler-limitations" }
-{ $see-also "ui-profiler" } ;
+{ $see-also "ui.tools.profiler" } ;
ABOUT: "profiling"
diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor
index 0bd3663729..d2e605ecdc 100644
--- a/basis/tools/profiler/profiler-tests.factor
+++ b/basis/tools/profiler/profiler-tests.factor
@@ -34,7 +34,7 @@ words ;
[ 1 ] [ \ foobar counter>> ] unit-test
-: fooblah ( -- ) { } [ ] like call ;
+: fooblah ( -- ) { } [ ] like call( -- ) ;
: foobaz ( -- ) fooblah fooblah ;
diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor
index 864a637096..219344db3b 100644
--- a/basis/tools/profiler/profiler.factor
+++ b/basis/tools/profiler/profiler.factor
@@ -3,11 +3,11 @@
USING: accessors words sequences math prettyprint kernel arrays io
io.styles namespaces assocs kernel.private strings combinators
sorting math.parser vocabs definitions tools.profiler.private
-continuations generic compiler.units sets classes fry ;
+tools.crossref continuations generic compiler.units sets classes fry ;
IN: tools.profiler
: profile ( quot -- )
- [ t profiling call ] [ f profiling ] [ ] cleanup ;
+ [ t profiling call ] [ f profiling ] [ ] cleanup ; inline
: filter-counts ( alist -- alist' )
[ second 0 > ] filter ;
diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor
index 73e896d5ff..5c8b868483 100755
--- a/basis/tools/scaffold/scaffold.factor
+++ b/basis/tools/scaffold/scaffold.factor
@@ -5,7 +5,8 @@ io.encodings.utf8 hashtables kernel namespaces sequences
vocabs.loader io combinators calendar accessors math.parser
io.streams.string ui.tools.operations quotations strings arrays
prettyprint words vocabs sorting sets classes math alien urls
-splitting ascii combinators.short-circuit alarms words.symbol ;
+splitting ascii combinators.short-circuit alarms words.symbol
+system summary ;
IN: tools.scaffold
SYMBOL: developer-name
@@ -15,6 +16,10 @@ ERROR: not-a-vocab-root string ;
ERROR: vocab-name-contains-separator path ;
ERROR: vocab-name-contains-dot path ;
ERROR: no-vocab vocab ;
+ERROR: bad-developer-name name ;
+
+M: bad-developer-name summary
+ drop "Developer name must be a string." ;
<PRIVATE
@@ -24,6 +29,9 @@ ERROR: no-vocab vocab ;
: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
+: ensure-vocab-exists ( string -- string )
+ dup vocabs member? [ no-vocab ] unless ;
+
: check-vocab-name ( string -- string )
[ ]
[ contains-dot? [ vocab-name-contains-dot ] when ]
@@ -97,10 +105,14 @@ ERROR: no-vocab vocab ;
] if ;
: scaffold-authors ( vocab-root vocab -- )
- "authors.txt" vocab-root/vocab/file>path scaffolding? [
- [ developer-name get ] dip utf8 set-file-contents
+ developer-name get [
+ "authors.txt" vocab-root/vocab/file>path scaffolding? [
+ developer-name get swap utf8 set-file-contents
+ ] [
+ drop
+ ] if
] [
- drop
+ 2drop
] if ;
: lookup-type ( string -- object/string ? )
@@ -234,6 +246,7 @@ PRIVATE>
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
: scaffold-help ( vocab -- )
+ ensure-vocab-exists
[
dup "-docs.factor" vocab/suffix>path scaffolding? [
set-scaffold-docs-file
@@ -268,6 +281,7 @@ PRIVATE>
PRIVATE>
: scaffold-tests ( vocab -- )
+ ensure-vocab-exists
dup "-tests.factor" vocab/suffix>path
scaffolding? [
set-scaffold-tests-file
@@ -292,12 +306,20 @@ SYMBOL: examples-flag
"}" print
] with-variable ;
+: touch. ( path -- )
+ [ touch-file ]
+ [ "Click to edit: " write <pathname> . ] bi ;
+
: scaffold-rc ( path -- )
- [ home ] dip append-path
- [ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
+ [ home ] dip append-path touch. ;
-: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ;
+: scaffold-factor-boot-rc ( -- )
+ os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ;
-: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ;
+: scaffold-factor-rc ( -- )
+ os windows? "factor-rc" ".factor-rc" ? scaffold-rc ;
-: scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
+
+HOOK: scaffold-emacs os ( -- )
+
+M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
diff --git a/extra/lint/authors.txt b/basis/tools/scaffold/windows/authors.txt
old mode 100644
new mode 100755
similarity index 100%
rename from extra/lint/authors.txt
rename to basis/tools/scaffold/windows/authors.txt
diff --git a/basis/tools/scaffold/windows/tags.txt b/basis/tools/scaffold/windows/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/tools/scaffold/windows/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/tools/scaffold/windows/windows.factor b/basis/tools/scaffold/windows/windows.factor
new file mode 100755
index 0000000000..fef6121717
--- /dev/null
+++ b/basis/tools/scaffold/windows/windows.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.pathnames system tools.scaffold windows.shell32 ;
+IN: tools.scaffold.windows
+
+M: windows scaffold-emacs ( -- )
+ application-data ".emacs" append-path touch. ;
diff --git a/basis/tools/test/test-docs.factor b/basis/tools/test/test-docs.factor
index 3cabff457f..ac7b33d41e 100644
--- a/basis/tools/test/test-docs.factor
+++ b/basis/tools/test/test-docs.factor
@@ -3,33 +3,26 @@ IN: tools.test
ARTICLE: "tools.test.write" "Writing unit tests"
"Assert that a quotation outputs a specific set of values:"
-{ $subsection unit-test }
+{ $subsection POSTPONE: unit-test }
"Assert that a quotation throws an error:"
-{ $subsection must-fail }
-{ $subsection must-fail-with }
+{ $subsection POSTPONE: must-fail }
+{ $subsection POSTPONE: must-fail-with }
"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):"
-{ $subsection must-infer }
-{ $subsection must-infer-as } ;
+{ $subsection POSTPONE: must-infer }
+{ $subsection POSTPONE: must-infer-as }
+"All of the above are used like ordinary words but are actually parsing words. This ensures that parse-time state, namely the line number, can be associated with the test in question, and reported in test failures." ;
ARTICLE: "tools.test.run" "Running unit tests"
"The following words run test harness files; any test failures are collected and printed at the end:"
{ $subsection test }
-{ $subsection test-all } ;
-
-ARTICLE: "tools.test.failure" "Handling test failures"
-"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Some tools inspect the test failures and takes some kind of action instead, for example, " { $vocab-link "mason" } "."
-$nl
-"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:"
-{ $list
- { { $snippet "error" } " - the error thrown by the unit test" }
- { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" }
- { { $snippet "continuation" } " - the traceback at the point of the error" }
-}
-"The following words run test harness files and output failures:"
-{ $subsection run-tests }
-{ $subsection run-all-tests }
+{ $subsection test-all }
"The following word prints failures:"
-{ $subsection test-failures. } ;
+{ $subsection :test-failures }
+"Test failures are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "."
+$nl
+"Unit test failures are instances of a class, and are stored in a global variable:"
+{ $subsection test-failure }
+{ $subsection test-failures } ;
ARTICLE: "tools.test" "Unit testing"
"A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract."
@@ -45,12 +38,12 @@ $nl
$nl
"If the test harness needs to define words, they should be placed in a vocabulary named " { $snippet { $emphasis "vocab" } ".tests" } " where " { $emphasis "vocab" } " is the vocab being tested."
{ $subsection "tools.test.write" }
-{ $subsection "tools.test.run" }
-{ $subsection "tools.test.failure" } ;
+{ $subsection "tools.test.run" } ;
ABOUT: "tools.test"
HELP: unit-test
+{ $syntax "[ output ] [ input ] unit-test" }
{ $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } }
{ $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ;
@@ -65,8 +58,8 @@ HELP: must-fail-with
{ $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ;
HELP: must-infer
-{ $values { "word/quot" "a quotation or a word" } }
-{ $description "Ensures that the quotation or word has a static stack effect without running it." }
+{ $values { "quot" quotation } }
+{ $description "Ensures that the quotation has a static stack effect without running it." }
{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ;
HELP: must-infer-as
@@ -78,17 +71,8 @@ HELP: test
{ $values { "prefix" "a vocabulary name" } }
{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ;
-HELP: run-tests
-{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } }
-{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
-
HELP: test-all
{ $description "Runs unit tests for all loaded vocabularies." } ;
-HELP: run-all-tests
-{ $values { "failures" "an association list of unit test failures" } }
-{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ;
-
-HELP: test-failures.
-{ $values { "assoc" "an association list of unit test failures" } }
-{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to " { $link output-stream } "." } ;
+HELP: :test-failures
+{ $description "Prints all pending unit test failures." } ;
diff --git a/basis/tools/test/test-tests.factor b/basis/tools/test/test-tests.factor
index 473335645f..c8ce3e01c7 100644
--- a/basis/tools/test/test-tests.factor
+++ b/basis/tools/test/test-tests.factor
@@ -1,4 +1,16 @@
IN: tools.test.tests
-USING: tools.test ;
+USING: tools.test tools.test.private namespaces kernel sequences ;
-\ test-all must-infer
+: fake-unit-test ( quot -- )
+ [
+ "fake" file set
+ V{ } clone test-failures set
+ call
+ test-failures get
+ ] with-scope ; inline
+
+[ 1 ] [
+ [
+ [ "OOPS" ] must-fail
+ ] fake-unit-test length
+] unit-test
\ No newline at end of file
diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor
index c6dea08d18..3dc7b8740b 100644
--- a/basis/tools/test/test.factor
+++ b/basis/tools/test/test.factor
@@ -1,95 +1,144 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces arrays prettyprint sequences kernel
-vectors quotations words parser assocs combinators continuations
-debugger io io.styles io.files vocabs vocabs.loader source-files
-compiler.units summary stack-checker effects tools.vocabs fry ;
+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
+vocabs.files words tools.errors source-files.errors
+io.streams.string make compiler.errors ;
IN: tools.test
-SYMBOL: failures
+TUPLE: test-failure < source-file-error continuation ;
-: <failure> ( error what -- triple )
- error-continuation get 3array ;
+SYMBOL: +test-failure+
-: failure ( error what -- )
+M: test-failure error-type drop +test-failure+ ;
+
+SYMBOL: test-failures
+
+test-failures [ V{ } clone ] initialize
+
+T{ error-type
+ { type +test-failure+ }
+ { word ":test-failures" }
+ { plural "unit test failures" }
+ { icon "vocab:ui/tools/error-list/icons/unit-test-error.tiff" }
+ { quot [ test-failures get ] }
+} define-error-type
+
+<PRIVATE
+
+: <test-failure> ( error experiment file line# -- triple )
+ test-failure new
+ swap >>line#
+ swap >>file
+ swap >>asset
+ swap >>error
+ error-continuation get >>continuation ;
+
+: failure ( error experiment file line# -- )
"--> test failed!" print
- <failure> failures get push ;
+ <test-failure> test-failures get push
+ notify-error-observers ;
-SYMBOL: this-test
+SYMBOL: file
-: (unit-test) ( what quot -- )
- swap dup . flush this-test set
- failures get [
- [ this-test get failure ] recover
- ] [
- call
- ] if ; inline
+: file-failure ( error -- )
+ f file get f failure ;
-: unit-test ( output input -- )
- [ 2array ] 2keep '[
- _ { } _ with-datastack swap >array assert=
- ] (unit-test) ;
+:: (unit-test) ( output input -- error ? )
+ [ { } input with-datastack output assert-sequence= f f ] [ t ] recover ;
: short-effect ( effect -- pair )
[ in>> length ] [ out>> length ] bi 2array ;
-: must-infer-as ( effect quot -- )
- [ 1quotation ] dip '[ _ infer short-effect ] unit-test ;
+:: (must-infer-as) ( effect quot -- error ? )
+ [ quot infer short-effect effect assert= f f ] [ t ] recover ;
-: must-infer ( word/quot -- )
- dup word? [ 1quotation ] when
- '[ _ infer drop ] [ ] swap unit-test ;
+:: (must-infer) ( quot -- error ? )
+ [ quot infer drop f f ] [ t ] recover ;
-: must-fail-with ( quot pred -- )
- [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
+TUPLE: did-not-fail ;
+CONSTANT: did-not-fail T{ did-not-fail }
-: must-fail ( quot -- )
- [ drop t ] must-fail-with ;
+M: did-not-fail summary drop "Did not fail" ;
-: (run-test) ( vocab -- )
+:: (must-fail-with) ( quot pred -- error ? )
+ [ { } quot with-datastack drop did-not-fail t ]
+ [ dup pred call( error -- ? ) [ drop f f ] [ t ] if ] recover ;
+
+:: (must-fail) ( quot -- error ? )
+ [ { } quot with-datastack drop did-not-fail t ] [ drop f f ] recover ;
+
+: experiment-title ( word -- string )
+ "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;
+
+MACRO: <experiment> ( word -- )
+ [ stack-effect in>> length dup ]
+ [ name>> experiment-title ] bi
+ '[ _ ndup _ narray _ prefix ] ;
+
+: experiment. ( seq -- )
+ [ first write ": " write ] [ rest . ] bi ;
+
+:: experiment ( word: ( -- error ? ) line# -- )
+ word <experiment> :> e
+ e experiment.
+ word execute [
+ file get [
+ e file get line# failure
+ ] [ rethrow ] if
+ ] [ drop ] if ; inline
+
+: parse-test ( accum word -- accum )
+ literalize parsed
+ lexer get line>> parsed
+ \ experiment parsed ; inline
+
+<<
+
+SYNTAX: TEST:
+ scan
+ [ create-in ]
+ [ "(" ")" surround search '[ _ parse-test ] ] bi
+ define-syntax ;
+
+>>
+
+: run-test-file ( path -- )
+ dup file [
+ test-failures get file get +test-failure+ delete-file-errors
+ '[ _ run-file ] [ file-failure ] recover
+ ] with-variable ;
+
+: run-vocab-tests ( vocab -- )
dup vocab source-loaded?>> [
- vocab-tests [ run-file ] each
+ vocab-tests [ run-test-file ] each
] [ drop ] if ;
-: run-test ( vocab -- failures )
- V{ } clone [
- failures [
- [ (run-test) ] [ swap failure ] recover
- ] with-variable
- ] keep ;
+: traceback-button. ( failure -- )
+ "[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
-: failure. ( triple -- )
- dup second .
- dup first print-error
- "Traceback" swap third write-object ;
+PRIVATE>
-: test-failures. ( assoc -- )
- [
- nl
- [
- "==== ALL TESTS PASSED" print
- ] [
- "==== FAILING TESTS:" print
- [
- swap vocab-heading.
- [ failure. nl ] each
- ] assoc-each
- ] if-empty
- ] [
- "==== NOTHING TO TEST" print
- ] if* ;
+TEST: unit-test
+TEST: must-infer-as
+TEST: must-infer
+TEST: must-fail-with
+TEST: must-fail
-: run-tests ( prefix -- failures )
- child-vocabs [ f ] [
- [ dup run-test ] { } map>assoc
- [ second empty? not ] filter
- ] if-empty ;
+M: test-failure error. ( error -- )
+ {
+ [ summary print nl ]
+ [ asset>> [ experiment. nl ] when* ]
+ [ error>> error. ]
+ [ traceback-button. ]
+ } cleave ;
+
+: :test-failures ( -- ) test-failures get errors. ;
: test ( prefix -- )
- run-tests test-failures. ;
+ child-vocabs [ run-vocab-tests ] each ;
-: run-all-tests ( -- failures )
- "" run-tests ;
-
-: test-all ( -- )
- run-all-tests test-failures. ;
+: test-all ( -- ) "" test ;
diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor
index 58fc531623..65e87f976f 100644
--- a/basis/tools/time/time.factor
+++ b/basis/tools/time/time.factor
@@ -1,24 +1,27 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.vectors memory io io.styles prettyprint
-namespaces system sequences splitting grouping assocs strings ;
+namespaces system sequences splitting grouping assocs strings
+generic.single combinators ;
IN: tools.time
: benchmark ( quot -- runtime )
micros [ call micros ] dip - ; inline
-: time. ( data -- )
- unclip
- "==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl
- 4 cut*
- "==== GARBAGE COLLECTION" print nl
+: time. ( time -- )
+ "== Running time ==" print nl 1000000 /f pprint " seconds" print ;
+
+: gc-stats. ( stats -- )
+ 5 cut*
+ "== Garbage collection ==" print nl
+ "Times are in microseconds." print nl
[
6 group
{
"GC count:"
- "Cumulative GC time (us):"
- "Longest GC pause (us):"
- "Average GC pause (us):"
+ "Total GC time:"
+ "Longest GC pause:"
+ "Average GC pause:"
"Objects copied:"
"Bytes copied:"
} prefix
@@ -29,12 +32,43 @@ IN: tools.time
[
nl
{
- "Total GC time (us):"
+ "Total GC time:"
"Cards scanned:"
"Decks scanned:"
+ "Card scan time:"
"Code heap literal scans:"
} swap zip simple-table.
] bi* ;
+: dispatch-stats. ( stats -- )
+ "== Megamorphic caches ==" print nl
+ { "Hits" "Misses" } swap zip simple-table. ;
+
+: inline-cache-stats. ( stats -- )
+ nl "== Polymorphic inline caches ==" print nl
+ 3 cut
+ [
+ "Transitions:" print
+ { "Cold to monomorphic" "Mono to polymorphic" "Poly to megamorphic" } swap zip
+ simple-table. nl
+ ] [
+ "Type check stubs:" print
+ { "Tag only" "Hi-tag" "Tuple" "Hi-tag and tuple" } swap zip
+ simple-table.
+ ] bi* ;
+
: time ( quot -- )
- gc-reset micros [ call gc-stats micros ] dip - prefix time. ; inline
+ gc-reset
+ reset-dispatch-stats
+ reset-inline-cache-stats
+ benchmark gc-stats dispatch-stats inline-cache-stats
+ H{ { table-gap { 20 20 } } } [
+ [
+ [ [ time. ] 3dip ] with-cell
+ [ ] with-cell
+ ] with-row
+ [
+ [ [ gc-stats. ] 2dip ] with-cell
+ [ [ dispatch-stats. ] [ inline-cache-stats. ] bi* ] with-cell
+ ] with-row
+ ] tabular-output nl ; inline
diff --git a/basis/tools/trace/authors.txt b/basis/tools/trace/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/tools/trace/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/tools/trace/trace-tests.factor b/basis/tools/trace/trace-tests.factor
new file mode 100644
index 0000000000..74f7c40943
--- /dev/null
+++ b/basis/tools/trace/trace-tests.factor
@@ -0,0 +1,4 @@
+IN: tools.trace.tests
+USING: tools.trace tools.test sequences ;
+
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
\ No newline at end of file
diff --git a/basis/tools/trace/trace.factor b/basis/tools/trace/trace.factor
new file mode 100644
index 0000000000..e2c6bf864b
--- /dev/null
+++ b/basis/tools/trace/trace.factor
@@ -0,0 +1,83 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.promises models tools.continuations kernel
+sequences concurrency.messaging locals continuations threads
+namespaces namespaces.private make assocs accessors io strings
+prettyprint math math.parser words effects summary io.styles classes
+generic.math combinators.short-circuit ;
+IN: tools.trace
+
+: callstack-depth ( callstack -- n )
+ callstack>array length 2/ ;
+
+SYMBOL: end
+
+SYMBOL: exclude-vocabs
+SYMBOL: include-vocabs
+
+exclude-vocabs { "math" "accessors" } swap set-global
+
+: include? ( vocab -- ? )
+ include-vocabs get dup [ member? ] [ 2drop t ] if ;
+
+: exclude? ( vocab -- ? )
+ exclude-vocabs get dup [ member? ] [ 2drop f ] if ;
+
+: into? ( obj -- ? )
+ {
+ [ word? ]
+ [ predicate? not ]
+ [ math-generic? not ]
+ [
+ {
+ [ inline? ]
+ [
+ {
+ [ vocabulary>> include? ]
+ [ vocabulary>> exclude? not ]
+ } 1&&
+ ]
+ } 1||
+ ]
+ } 1&& ;
+
+TUPLE: trace-step word inputs ;
+
+M: trace-step summary
+ [
+ [ "Word: " % word>> name>> % ]
+ [ " -- inputs: " % inputs>> unparse-short % ] bi
+ ] "" make ;
+
+: <trace-step> ( continuation word -- trace-step )
+ [ nip ] [ [ data>> ] [ stack-effect in>> length ] bi* short tail* ] 2bi
+ \ trace-step boa ;
+
+: print-step ( continuation -- )
+ dup continuation-current dup word? [
+ [ nip name>> ] [ <trace-step> ] 2bi write-object nl
+ ] [
+ nip short.
+ ] if ;
+
+: print-depth ( continuation -- )
+ call>> callstack-depth
+ [ CHAR: \s <string> write ]
+ [ number>string write ": " write ] bi ;
+
+: trace-step ( continuation -- continuation' )
+ dup continuation-current end eq? [
+ [ print-depth ]
+ [ print-step ]
+ [
+ dup continuation-current into?
+ [ continuation-step-into ] [ continuation-step ] if
+ ] tri
+ ] unless ;
+
+: trace ( quot -- data )
+ [ [ trace-step ] break-hook ] dip
+ [ break ] [ end drop ] surround
+ with-variable ;
+
+<< \ trace t "no-compile" set-word-prop >>
\ No newline at end of file
diff --git a/basis/tools/vocabs/summary.txt b/basis/tools/vocabs/summary.txt
deleted file mode 100644
index 1ae5f43784..0000000000
--- a/basis/tools/vocabs/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Reloading vocabularies and cross-referencing vocabularies
diff --git a/basis/tools/vocabs/vocabs-docs.factor b/basis/tools/vocabs/vocabs-docs.factor
deleted file mode 100644
index 33f197d0ea..0000000000
--- a/basis/tools/vocabs/vocabs-docs.factor
+++ /dev/null
@@ -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." } ;
diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor
deleted file mode 100644
index 6167a5be23..0000000000
--- a/basis/tools/vocabs/vocabs.factor
+++ /dev/null
@@ -1,310 +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-xref ( vocab quot -- vocabs )
- [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
- [
- [ [ word? ] [ generic? not ] bi and ] filter [
- dup method-body?
- [ "method-generic" word-prop ] when
- vocabulary>>
- ] map
- ] gather natural-sort remove sift ; inline
-
-: vocabs. ( seq -- )
- [ dup >vocab-link write-object nl ] each ;
-
-: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
-
-: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;
-
-: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
-
-: vocab-usage. ( vocab -- ) vocab-usage 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-compiler-errors ;
-
-: 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
-
-[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
-
-: 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 ;
diff --git a/basis/tools/walker/debug/debug.factor b/basis/tools/walker/debug/debug.factor
index f2155ec125..80113607d4 100644
--- a/basis/tools/walker/debug/debug.factor
+++ b/basis/tools/walker/debug/debug.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: concurrency.promises models tools.walker kernel
-sequences concurrency.messaging locals continuations
-threads namespaces namespaces.private assocs accessors ;
+USING: concurrency.promises models tools.walker tools.continuations
+kernel sequences concurrency.messaging locals continuations threads
+namespaces namespaces.private assocs accessors ;
IN: tools.walker.debug
:: test-walker ( quot -- data )
diff --git a/basis/tools/walker/walker-tests.factor b/basis/tools/walker/walker-tests.factor
index 3a5877c286..6f87792faa 100644
--- a/basis/tools/walker/walker-tests.factor
+++ b/basis/tools/walker/walker-tests.factor
@@ -1,7 +1,8 @@
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.standard sequences.private kernel.private ;
+generic.single sequences.private kernel.private
+tools.continuations accessors words ;
IN: tools.walker.tests
[ { } ] [
@@ -112,3 +113,22 @@ IN: tools.walker.tests
[ { } ] [
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
] unit-test
+
+: breakpoint-test ( -- x ) break 1 2 + ;
+
+\ breakpoint-test don't-step-into
+
+[ f ] [ \ breakpoint-test optimized? ] unit-test
+
+[ { 3 } ] [ [ breakpoint-test ] test-walker ] unit-test
+
+GENERIC: method-breakpoint-test ( x -- y )
+
+TUPLE: method-breakpoint-tuple ;
+
+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
\ No newline at end of file
diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor
index b4ace6b770..4208c4420f 100644
--- a/basis/tools/walker/walker.factor
+++ b/basis/tools/walker/walker.factor
@@ -1,10 +1,11 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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.standard definitions make sbufs ;
+generic generic.standard definitions make sbufs
+tools.continuations parser ;
IN: tools.walker
SYMBOL: show-walker-hook ! ( status continuation thread -- )
@@ -31,66 +32,18 @@ DEFER: start-walker-thread
2dup start-walker-thread
] if* ;
-: show-walker ( -- thread )
- get-walker-thread
- [ show-walker-hook get call ] keep ;
-
-: after-break ( object -- )
- {
- { [ dup continuation? ] [ (continue) ] }
- { [ dup quotation? ] [ call ] }
- { [ dup not ] [ "Single stepping abandoned" rethrow ] }
- } cond ;
-
-: break ( -- )
- continuation callstack >>call
- show-walker send-synchronous
- after-break ;
-
-\ break t "break?" set-word-prop
-
: walk ( quot -- quot' )
\ break prefix [ break rethrow ] recover ;
-GENERIC: add-breakpoint ( quot -- quot' )
+<< \ walk t "no-compile" set-word-prop >>
-M: callable add-breakpoint
- dup [ break ] head? [ \ break prefix ] unless ;
-
-M: array add-breakpoint
- [ add-breakpoint ] map ;
-
-M: object add-breakpoint ;
-
-: (step-into-quot) ( quot -- ) add-breakpoint call ;
-
-: (step-into-dip) ( quot -- ) add-breakpoint dip ;
-
-: (step-into-2dip) ( quot -- ) add-breakpoint 2dip ;
-
-: (step-into-3dip) ( quot -- ) add-breakpoint 3dip ;
-
-: (step-into-if) ( true false ? -- ) ? (step-into-quot) ;
-
-: (step-into-dispatch) ( array n -- ) nth (step-into-quot) ;
-
-: (step-into-execute) ( word -- )
- {
- { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
- { [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
- { [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
- { [ dup uses \ suspend swap member? ] [ execute break ] }
- { [ dup primitive? ] [ execute break ] }
- [ def>> (step-into-quot) ]
- } cond ;
-
-\ (step-into-execute) t "step-into?" set-word-prop
-
-: (step-into-continuation) ( -- )
- continuation callstack >>call break ;
-
-: (step-into-call-next-method) ( method -- )
- next-method-quot (step-into-quot) ;
+break-hook [
+ [
+ get-walker-thread
+ [ show-walker-hook get call ] keep
+ send-synchronous
+ ]
+] initialize
! Messages sent to walker thread
SYMBOL: step
@@ -106,74 +59,6 @@ SYMBOL: +running+
SYMBOL: +suspended+
SYMBOL: +stopped+
-: 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
-
-: step-msg ( continuation -- continuation' ) USE: io
- [
- 2dup length = [ nip [ break ] append ] [
- 2dup nth \ break = [ nip ] [
- swap 1+ cut [ break ] glue
- ] if
- ] if
- ] change-frame ;
-
-: step-out-msg ( continuation -- continuation' )
- [ nip \ break suffix ] change-frame ;
-
-{
- { call [ (step-into-quot) ] }
- { dip [ (step-into-dip) ] }
- { 2dip [ (step-into-2dip) ] }
- { 3dip [ (step-into-3dip) ] }
- { execute [ (step-into-execute) ] }
- { if [ (step-into-if) ] }
- { dispatch [ (step-into-dispatch) ] }
- { continuation [ (step-into-continuation) ] }
- { (call-next-method) [ (step-into-call-next-method) ] }
-} [ "step-into" set-word-prop ] assoc-each
-
-! Never step into these words
-{
- >n ndrop >c c>
- continue continue-with
- stop suspend (spawn)
-} [
- dup [ execute break ] curry
- "step-into" set-word-prop
-] each
-
-\ break [ break ] "step-into" set-word-prop
-
-: step-into-msg ( continuation -- continuation' )
- [
- swap cut [
- swap %
- [ \ break , ] [
- unclip {
- { [ dup \ break eq? ] [ , ] }
- { [ dup quotation? ] [ add-breakpoint , \ break , ] }
- { [ dup array? ] [ add-breakpoint , \ break , ] }
- { [ dup word? ] [ literalize , \ (step-into-execute) , ] }
- [ , \ break , ]
- } cond %
- ] if-empty
- ] [ ] make
- ] change-frame ;
-
: status ( -- symbol )
walker-status tget value>> ;
@@ -200,13 +85,13 @@ SYMBOL: +stopped+
{ f [ +stopped+ set-status f ] }
[
[ walker-continuation tget set-model ]
- [ step-into-msg ] bi
+ [ continuation-step-into ] bi
]
} case
] handle-synchronous
] while ;
-: step-back-msg ( continuation -- continuation' )
+: continuation-step-back ( continuation -- continuation' )
walker-history tget
[ pop* ]
[ [ nip pop ] unless-empty ] bi ;
@@ -220,20 +105,20 @@ SYMBOL: +stopped+
{
! These are sent by the walker tool. We reply
! and keep cycling.
- { step [ step-msg keep-running ] }
- { step-out [ step-out-msg keep-running ] }
- { step-into [ step-into-msg keep-running ] }
+ { step [ continuation-step keep-running ] }
+ { step-out [ continuation-step-out keep-running ] }
+ { step-into [ continuation-step-into keep-running ] }
{ step-all [ keep-running ] }
{ step-into-all [ step-into-all-loop ] }
{ abandon [ drop f keep-running ] }
! Pass quotation to debugged thread
{ call-in [ keep-running ] }
! Pass previous continuation to debugged thread
- { step-back [ step-back-msg ] }
+ { step-back [ continuation-step-back ] }
} case f
] handle-synchronous
] while ;
-
+
: walker-loop ( -- )
+running+ set-status
[ status +stopped+ eq? ] [
@@ -276,4 +161,4 @@ SYMBOL: +stopped+
! For convenience
IN: syntax
-: B ( -- ) break ;
+SYNTAX: B \ break parsed ;
diff --git a/basis/tuple-arrays/authors.txt b/basis/tuple-arrays/authors.txt
index f990dd0ed2..d4f5d6b3ae 100644
--- a/basis/tuple-arrays/authors.txt
+++ b/basis/tuple-arrays/authors.txt
@@ -1 +1 @@
-Daniel Ehrenberg
+Slava Pestov
\ No newline at end of file
diff --git a/basis/tuple-arrays/summary.txt b/basis/tuple-arrays/summary.txt
old mode 100644
new mode 100755
index ac05ae9bcc..6f5c8b7244
--- a/basis/tuple-arrays/summary.txt
+++ b/basis/tuple-arrays/summary.txt
@@ -1 +1 @@
-Packed homogeneous tuple arrays
+Efficient arrays of tuples with value semantics for elements
diff --git a/basis/tuple-arrays/tags.txt b/basis/tuple-arrays/tags.txt
old mode 100644
new mode 100755
diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor
deleted file mode 100644
index 18f5547e7f..0000000000
--- a/basis/tuple-arrays/tuple-arrays-docs.factor
+++ /dev/null
@@ -1,13 +0,0 @@
-USING: help.syntax help.markup splitting kernel sequences ;
-IN: tuple-arrays
-
-HELP: tuple-array
-{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link <tuple-array> } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ;
-
-HELP: <tuple-array>
-{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } }
-{ $description "Creates an instance of the " { $link <tuple-array> } " class with the given length and containing the given tuple class." } ;
-
-HELP: >tuple-array
-{ $values { "seq" sequence } { "tuple-array" tuple-array } }
-{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ;
diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor
index 7aa49b880f..2eeae20aa1 100644
--- a/basis/tuple-arrays/tuple-arrays-tests.factor
+++ b/basis/tuple-arrays/tuple-arrays-tests.factor
@@ -5,17 +5,28 @@ IN: tuple-arrays.tests
SYMBOL: mat
TUPLE: foo bar ;
C: <foo> foo
-[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
+TUPLE-ARRAY: foo
+
+[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test
-[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
+[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test
[ T{ foo f 3 } t ]
-[ mat get [ bar>> 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test
+[ mat get [ bar>> 2 + <foo> ] map [ first ] keep foo-array? ] unit-test
-[ 2 ] [ 2 foo <tuple-array> dup mat set length ] unit-test
+[ 2 ] [ 2 <foo-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
TUPLE: baz { bing integer } bong ;
-[ 0 ] [ 1 baz <tuple-array> first bing>> ] unit-test
-[ f ] [ 1 baz <tuple-array> first bong>> ] unit-test
+TUPLE-ARRAY: baz
+
+[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
+[ f ] [ 1 <baz-array> first bong>> ] unit-test
+
+TUPLE: broken x ;
+: broken ( -- ) ;
+
+TUPLE-ARRAY: broken
+
+[ 100 ] [ 100 <broken-array> length ] unit-test
\ No newline at end of file
diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor
index af62c0b0d7..35d771416c 100644
--- a/basis/tuple-arrays/tuple-arrays.factor
+++ b/basis/tuple-arrays/tuple-arrays.factor
@@ -1,34 +1,73 @@
-! Copyright (C) 2007 Daniel Ehrenberg.
+! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: splitting grouping classes.tuple classes math kernel
-sequences arrays accessors ;
+USING: accessors arrays combinators.smart fry functors kernel
+kernel.private macros sequences combinators sequences.private
+stack-checker parser math classes.tuple.private ;
+FROM: inverse => undo ;
IN: tuple-arrays
-TUPLE: tuple-array { seq read-only } { class read-only } ;
+<PRIVATE
-: <tuple-array> ( length class -- tuple-array )
- [
- new tuple>array 1 tail
- [ <repetition> concat ] [ length ] bi <sliced-groups>
- ] [ ] bi tuple-array boa ;
+MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
-M: tuple-array nth
- [ seq>> nth ] [ class>> ] bi prefix >tuple ;
+MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
-M: tuple-array set-nth ( elt n seq -- )
- [ tuple>array 1 tail ] 2dip seq>> set-nth ;
+: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
-M: tuple-array new-sequence
- class>> <tuple-array> ;
+: smart-tuple>array ( tuple class -- array )
+ '[ [ _ boa ] undo ] output>array ; inline
-: >tuple-array ( seq -- tuple-array )
- dup empty? [
- 0 over first class <tuple-array> clone-like
- ] unless ;
+: tuple-prototype ( class -- array )
+ [ new ] [ smart-tuple>array ] bi ; inline
-M: tuple-array like
- drop dup tuple-array? [ >tuple-array ] unless ;
+: tuple-slice ( n seq -- slice )
+ [ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline
-M: tuple-array length seq>> length ;
+: read-tuple ( slice class -- tuple )
+ '[ _ boa-unsafe ] input<sequence-unsafe ; inline
-INSTANCE: tuple-array sequence
+MACRO: write-tuple ( class -- quot )
+ [ '[ [ _ boa ] undo ] ]
+ [ tuple-arity <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
+ bi '[ _ dip @ ] ;
+
+PRIVATE>
+
+FUNCTOR: define-tuple-array ( CLASS -- )
+
+CLASS IS ${CLASS}
+
+CLASS-array DEFINES-CLASS ${CLASS}-array
+CLASS-array? IS ${CLASS-array}?
+
+<CLASS-array> DEFINES <${CLASS}-array>
+>CLASS-array DEFINES >${CLASS}-array
+
+WHERE
+
+TUPLE: CLASS-array
+{ seq array read-only }
+{ n array-capacity read-only }
+{ length array-capacity read-only } ;
+
+: <CLASS-array> ( length -- tuple-array )
+ [ \ CLASS [ tuple-prototype <repetition> concat ] [ tuple-arity ] bi ] keep
+ \ CLASS-array boa ; inline
+
+M: CLASS-array length length>> ;
+
+M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ;
+
+M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ;
+
+M: CLASS-array new-sequence drop <CLASS-array> ;
+
+: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> clone-like ;
+
+M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ;
+
+INSTANCE: CLASS-array sequence
+
+;FUNCTOR
+
+SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ;
diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor
index 76fbc7286b..9c844d3663 100755
--- a/basis/ui/backend/backend.factor
+++ b/basis/ui/backend/backend.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces opengl opengl.gl ;
+USING: kernel namespaces opengl opengl.gl fry ;
IN: ui.backend
SYMBOL: ui-backend
@@ -28,7 +28,7 @@ GENERIC: flush-gl-context ( handle -- )
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
: with-gl-context ( handle quot -- )
- swap [ select-gl-context call ] keep
- glFlush flush-gl-context gl-error ; inline
+ '[ select-gl-context @ ]
+ [ flush-gl-context gl-error ] bi ; inline
HOOK: (with-ui) ui-backend ( quot -- )
\ No newline at end of file
diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor
index fc392c595d..5b1b4b0c2a 100755
--- a/basis/ui/backend/cocoa/cocoa.factor
+++ b/basis/ui/backend/cocoa/cocoa.factor
@@ -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
@@ -39,13 +77,16 @@ M: pasteboard set-clipboard-contents
[ 0 0 ] dip dim>> first2 <CGRect> ;
: auto-position ( window loc -- )
+ #! Note: if this is the initial window, the length of the windows
+ #! vector should be 1, since (open-window) calls auto-position
+ #! after register-window.
dup { 0 0 } = [
drop
- windows get [ -> center ] [
- peek second window-loc>>
+ windows get length 1 <= [ -> center ] [
+ windows get peek second window-loc>>
dupd first2 <CGPoint> -> cascadeTopLeftFromPoint:
-> setFrameTopLeftPoint:
- ] if-empty
+ ] if
] [ first2 <CGPoint> -> setFrameTopLeftPoint: ] if ;
M: cocoa-ui-backend set-title ( string world -- )
@@ -67,11 +108,12 @@ 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
- window world window-loc>> auto-position
world view register-window
+ window world window-loc>> auto-position
world window save-position
window install-window-delegate
view window <window-handle> world (>>handle)
@@ -94,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 ;
diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor
index 46ecc1a37f..cf5493f33d 100644
--- a/basis/ui/backend/cocoa/tools/tools.factor
+++ b/basis/ui/backend/cocoa/tools/tools.factor
@@ -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 -- )
@@ -70,7 +71,7 @@ CLASS: {
! Service support; evaluate Factor code from other apps
:: do-service ( pboard error quot -- )
pboard error ?pasteboard-string
- dup [ quot call ] when
+ dup [ quot call( string -- result/f ) ] when
[ pboard set-pasteboard-string ] when* ;
CLASS: {
diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor
index b59848260d..aab851c783 100644
--- a/basis/ui/backend/cocoa/views/views.factor
+++ b/basis/ui/backend/cocoa/views/views.factor
@@ -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
@@ -336,7 +336,7 @@ CLASS: {
! Initialization
{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
- [ 2drop dup view-dim swap window (>>dim) yield ]
+ [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
}
{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
@@ -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 ;
diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index e405efb540..24ae72740f 100755
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -6,15 +6,169 @@ ui.gadgets ui.gadgets.private ui.backend ui.clipboards
ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
math.vectors namespaces make sequences strings vectors words
windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
-windows.messages windows.types windows.offscreen windows.nt windows
+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 ;
+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 ;
+
: crlf>lf ( str -- str' )
CHAR: \r swap remove ;
@@ -69,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
@@ -286,8 +434,6 @@ SYMBOL: nc-buttons
message>button nc-buttons get
swap [ push ] [ delete ] if ;
-: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
-
: mouse-wheel ( wParam -- array ) >lo-hi [ sgn neg ] map ;
: mouse-event>gesture ( uMsg -- button )
@@ -475,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
@@ -502,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 ]
@@ -553,6 +698,54 @@ M: windows-ui-backend (with-ui)
M: windows-ui-backend beep ( -- )
0 MessageBeep drop ;
+: fullscreen-RECT ( hwnd -- RECT )
+ MONITOR_DEFAULTTONEAREST MonitorFromWindow
+ "MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
+ [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
+
+: hwnd>RECT ( hwnd -- RECT )
+ "RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
+
+: fullscreen-flags ( -- n )
+ { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
+
+: enter-fullscreen ( world -- )
+ handle>> hWnd>>
+ {
+ [
+ GWL_STYLE GetWindowLong
+ fullscreen-flags unmask
+ ]
+ [ GWL_STYLE rot SetWindowLong win32-error=0/f ]
+ [
+ HWND_TOP
+ over hwnd>RECT get-RECT-dimensions
+ SWP_FRAMECHANGED
+ SetWindowPos win32-error=0/f
+ ]
+ [ SW_MAXIMIZE ShowWindow win32-error=0/f ]
+ } cleave ;
+
+: exit-fullscreen ( world -- )
+ handle>> hWnd>>
+ {
+ [
+ GWL_STYLE GetWindowLong
+ fullscreen-flags bitor
+ ]
+ [ GWL_STYLE rot SetWindowLong win32-error=0/f ]
+ [
+ f
+ over hwnd>RECT get-RECT-dimensions
+ { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags
+ SetWindowPos win32-error=0/f
+ ]
+ [ SW_RESTORE ShowWindow win32-error=0/f ]
+ } cleave ;
+
+M: windows-ui-backend set-fullscreen* ( ? world -- )
+ swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+
windows-ui-backend ui-backend set-global
[ "ui.tools" ] main-vocab-hook set-global
diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor
index 422efbd188..76fd9fa30c 100755
--- a/basis/ui/backend/x11/x11.factor
+++ b/basis/ui/backend/x11/x11.factor
@@ -3,11 +3,12 @@
USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
ui.gadgets.private ui.gestures ui.backend ui.clipboards
ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
-namespaces opengl sequences strings x11.xlib x11.events x11.xim
-x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
-io.encodings.ascii io.encodings.utf8 combinators command-line
-math.vectors classes.tuple opengl.gl threads math.rectangles
-environment ascii ;
+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 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 ;
@@ -196,7 +232,7 @@ M: world client-event
QueuedAfterFlush events-queued 0 > [
next-event dup
None XFilterEvent 0 = [ drop wait-event ] unless
- ] [ ui-wait wait-event ] if ;
+ ] [ wait-for-display wait-event ] if ;
M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup
@@ -224,6 +260,10 @@ M: x-clipboard paste-clipboard
[ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
utf8 encode dup length XChangeProperty drop ;
+: set-class ( dpy window -- )
+ XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor"
+ utf8 encode dup length XChangeProperty drop ;
+
M: x11-ui-backend set-title ( string world -- )
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
@@ -242,11 +282,15 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
- handle>> window>> dup set-closable map-window ;
+ handle>> window>>
+ [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
M: x11-ui-backend raise-window* ( world -- )
handle>> [
- dpy get swap window>> XRaiseWindow drop
+ dpy get swap window>>
+ [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
+ [ XRaiseWindow drop ]
+ 2bi
] when* ;
M: x11-handle select-gl-context ( handle -- )
@@ -266,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 ]
diff --git a/basis/ui/baseline-alignment/baseline-alignment.factor b/basis/ui/baseline-alignment/baseline-alignment.factor
index e02c6188f5..f7f7a757f5 100644
--- a/basis/ui/baseline-alignment/baseline-alignment.factor
+++ b/basis/ui/baseline-alignment/baseline-alignment.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel locals math math.order math.vectors
+USING: arrays kernel locals math math.functions math.order math.vectors
sequences ui.gadgets accessors combinators ;
IN: ui.baseline-alignment
@@ -24,35 +24,47 @@ TUPLE: gadget-metrics height ascent descent cap-height ;
[ dup [ 2dup - ] [ f ] if ] dip
gadget-metrics boa ; inline
+: ?supremum ( seq -- n/f )
+ sift [ f ] [ supremum ] if-empty ;
+
: max-ascent ( seq -- n )
- 0 [ ascent>> [ max ] when* ] reduce ; inline
+ [ ascent>> ] map ?supremum ;
: max-cap-height ( seq -- n )
- 0 [ cap-height>> [ max ] when* ] reduce ; inline
+ [ cap-height>> ] map ?supremum ;
: max-descent ( seq -- n )
- 0 [ descent>> [ max ] when* ] reduce ; inline
+ [ descent>> ] map ?supremum ;
: max-text-height ( seq -- y )
- 0 [ [ height>> ] [ ascent>> ] bi [ max ] [ drop ] if ] reduce ;
+ [ ascent>> ] filter [ height>> ] map ?supremum ;
: max-graphics-height ( seq -- y )
- 0 [ [ height>> ] [ ascent>> ] bi [ drop ] [ max ] if ] reduce ;
-
-: (align-baselines) ( y max leading -- y' ) [ swap - ] dip + ;
+ [ ascent>> not ] filter [ height>> ] map ?supremum 0 or ;
:: combine-metrics ( graphics-height ascent descent cap-height -- ascent' descent' )
- cap-height 2 / :> mid-line
- graphics-height 2 /
- [ ascent mid-line - max mid-line + >integer ]
- [ descent mid-line + max mid-line - >integer ] bi ;
+ ascent [
+ cap-height 2 / :> mid-line
+ graphics-height 2 /
+ [ ascent mid-line - max mid-line + floor >integer ]
+ [ descent mid-line + max mid-line - ceiling >integer ] bi
+ ] [ f f ] if ;
+
+: (measure-metrics) ( children sizes -- graphics-height ascent descent cap-height )
+ [ <gadget-metrics> ] 2map
+ {
+ [ max-graphics-height ]
+ [ max-ascent ]
+ [ max-descent ]
+ [ max-cap-height ]
+ } cleave ;
PRIVATE>
:: align-baselines ( gadgets -- ys )
gadgets [ dup pref-dim <gadget-metrics> ] map
- dup max-ascent :> max-ascent
- dup max-cap-height :> max-cap-height
+ dup max-ascent 0 or :> max-ascent
+ dup max-cap-height 0 or :> max-cap-height
dup max-graphics-height :> max-graphics-height
max-cap-height max-graphics-height + 2 /i :> critical-line
@@ -61,20 +73,12 @@ PRIVATE>
[
dup ascent>>
- [ ascent>> max-ascent text-leading ]
- [ height>> max-graphics-height graphics-leading ] if
- (align-baselines)
+ [ ascent>> max-ascent swap - text-leading ]
+ [ height>> max-graphics-height swap - 2/ graphics-leading ] if +
] map ;
: measure-metrics ( children sizes -- ascent descent )
- [ <gadget-metrics> ] 2map
- {
- [ max-graphics-height ]
- [ max-ascent ]
- [ max-descent ]
- [ max-cap-height ]
- } cleave
- combine-metrics ;
+ (measure-metrics) combine-metrics ;
: measure-height ( children sizes -- height )
- measure-metrics + ;
\ No newline at end of file
+ (measure-metrics) dup [ combine-metrics + ] [ 3drop ] if ;
\ No newline at end of file
diff --git a/basis/ui/event-loop/event-loop-tests.factor b/basis/ui/event-loop/event-loop-tests.factor
index ae1d7ec8bc..ac263cb79c 100644
--- a/basis/ui/event-loop/event-loop-tests.factor
+++ b/basis/ui/event-loop/event-loop-tests.factor
@@ -1,4 +1,2 @@
IN: ui.event-loop.tests
USING: ui.event-loop tools.test ;
-
-\ event-loop must-infer
diff --git a/basis/ui/gadgets/books/books-tests.factor b/basis/ui/gadgets/books/books-tests.factor
index dab9ef5acf..3076ffc004 100644
--- a/basis/ui/gadgets/books/books-tests.factor
+++ b/basis/ui/gadgets/books/books-tests.factor
@@ -1,4 +1,2 @@
IN: ui.gadgets.books.tests
USING: tools.test ui.gadgets.books ;
-
-\ <book> must-infer
diff --git a/basis/ui/gadgets/buttons/buttons-docs.factor b/basis/ui/gadgets/buttons/buttons-docs.factor
index 6042a39886..a28a6aef84 100644
--- a/basis/ui/gadgets/buttons/buttons-docs.factor
+++ b/basis/ui/gadgets/buttons/buttons-docs.factor
@@ -26,7 +26,7 @@ HELP: <repeat-button>
{ $description "Creates a new " { $link button } " derived from a " { $link <border-button> } " which calls the quotation every 100 milliseconds as long as the mouse button is held down." } ;
HELP: button-pen
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " gneeric words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words by delegating to an object in one of four slots which depend on the state of the button being drawn:"
{ $list
{ { $snippet "plain" } " - the button is inactive" }
{ { $snippet "rollover" } " - the button is under the mouse" }
diff --git a/basis/ui/gadgets/buttons/buttons-tests.factor b/basis/ui/gadgets/buttons/buttons-tests.factor
index 0aa12f7279..f7c73b2438 100644
--- a/basis/ui/gadgets/buttons/buttons-tests.factor
+++ b/basis/ui/gadgets/buttons/buttons-tests.factor
@@ -28,10 +28,6 @@ T{ foo-gadget } <toolbar> "t" set
} <radio-buttons> "religion" set
] unit-test
-\ <radio-buttons> must-infer
-
-\ <checkbox> must-infer
-
[ 0 ] [
"religion" get gadget-child value>>
] unit-test
diff --git a/basis/ui/gadgets/editors/editors-tests.factor b/basis/ui/gadgets/editors/editors-tests.factor
index bd610ba53b..3ba32dc3c2 100644
--- a/basis/ui/gadgets/editors/editors-tests.factor
+++ b/basis/ui/gadgets/editors/editors-tests.factor
@@ -42,8 +42,6 @@ IN: ui.gadgets.editors.tests
] with-grafted-gadget
] unit-test
-\ <editor> must-infer
-
"hello" <model> <model-field> "field" set
"field" get [
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 3eb40a5135..9461b2348f 100755
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -452,6 +452,7 @@ editor "caret-motion" f {
editor "selection" f {
{ T{ button-down f { S+ } 1 } extend-selection }
+ { T{ button-up f { S+ } 1 } com-copy-selection }
{ T{ drag } drag-selection }
{ gain-focus focus-editor }
{ lose-focus unfocus-editor }
diff --git a/basis/ui/gadgets/gadgets-tests.factor b/basis/ui/gadgets/gadgets-tests.factor
index 03219c66fd..77860ba5b5 100644
--- a/basis/ui/gadgets/gadgets-tests.factor
+++ b/basis/ui/gadgets/gadgets-tests.factor
@@ -152,16 +152,3 @@ M: mock-gadget ungraft*
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
] with-string-writer print
-
-\ <gadget> must-infer
-\ unparent must-infer
-\ add-gadget must-infer
-\ add-gadgets must-infer
-\ clear-gadget must-infer
-
-\ relayout must-infer
-\ relayout-1 must-infer
-\ pref-dim must-infer
-
-\ graft* must-infer
-\ ungraft* must-infer
\ No newline at end of file
diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
index bc07006d62..f9f397d46f 100644
--- a/basis/ui/gadgets/gadgets.factor
+++ b/basis/ui/gadgets/gadgets.factor
@@ -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 ;
+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>> ;
@@ -66,8 +70,8 @@ M: gadget children-on nip children>> ;
: ((fast-children-on)) ( gadget dim axis -- <=> )
[ swap loc>> v- ] dip v. 0 <=> ;
-: (fast-children-on) ( dim axis children -- i )
- -rot '[ _ _ ((fast-children-on)) ] search drop ;
+:: (fast-children-on) ( dim axis children -- i )
+ children [ dim axis ((fast-children-on)) ] search drop ;
PRIVATE>
diff --git a/basis/ui/gadgets/glass/glass-tests.factor b/basis/ui/gadgets/glass/glass-tests.factor
index d4e4306656..e95803d336 100644
--- a/basis/ui/gadgets/glass/glass-tests.factor
+++ b/basis/ui/gadgets/glass/glass-tests.factor
@@ -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
diff --git a/basis/ui/gadgets/icons/icons.factor b/basis/ui/gadgets/icons/icons.factor
index ddadb6b99e..123f7a540d 100644
--- a/basis/ui/gadgets/icons/icons.factor
+++ b/basis/ui/gadgets/icons/icons.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ui.images ui.pens
-ui.pens.image ui.gadgets ;
+ui.pens.image ui.gadgets ui.gadgets.labels ;
IN: ui.gadgets.icons
TUPLE: icon < gadget ;
@@ -9,4 +9,6 @@ TUPLE: icon < gadget ;
: <icon> ( image-name -- icon )
icon new swap <image-pen> t >>fill? >>interior ;
-M: icon pref-dim* dup interior>> pen-pref-dim ;
\ No newline at end of file
+M: icon pref-dim* dup interior>> pen-pref-dim ;
+
+M: image-name >label <icon> ;
\ No newline at end of file
diff --git a/basis/ui/gadgets/packs/packs-tests.factor b/basis/ui/gadgets/packs/packs-tests.factor
index cae7d12dc3..b49f46c05a 100644
--- a/basis/ui/gadgets/packs/packs-tests.factor
+++ b/basis/ui/gadgets/packs/packs-tests.factor
@@ -90,4 +90,50 @@ IN: ui.gadgets.packs.tests
[ ] [ "g" get prefer ] unit-test
-[ ] [ "g" get layout ] unit-test
\ No newline at end of file
+[ ] [ "g" get layout ] unit-test
+
+! Baseline alignment without any text gadgets should behave like align=1/2
+<shelf> +baseline+ >>align
+ <gadget> { 30 30 } >>dim add-gadget
+ <gadget> { 30 20 } >>dim add-gadget
+"g" set
+
+[ { 60 30 } ] [ "g" get pref-dim ] unit-test
+
+[ ] [ "g" get prefer ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 30 5 } } ]
+[ "g" get children>> [ loc>> ] map ] unit-test
+
+<shelf> +baseline+ >>align
+<gadget> { 30 30 } >>dim add-gadget
+10 10 { 10 10 } <baseline-gadget> add-gadget
+"g" set
+
+[ ] [ "g" get prefer ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 30 10 } } ]
+[ "g" get children>> [ loc>> ] map ] unit-test
+
+<shelf> +baseline+ >>align
+<shelf> <gadget> { 30 30 } >>dim add-gadget add-gadget
+10 10 { 10 10 } <baseline-gadget> add-gadget
+"g" set
+
+[ ] [ "g" get prefer ] unit-test
+
+[ ] [ "g" get layout ] unit-test
+
+[ V{ { 0 0 } { 30 10 } } ]
+[ "g" get children>> [ loc>> ] map ] unit-test
+
+<shelf> +baseline+ >>align
+<gadget> { 24 24 } >>dim add-gadget
+12 9 { 15 15 } <baseline-gadget> add-gadget
+"g" set
+
+[ { 39 24 } ] [ "g" get pref-dim ] unit-test
\ No newline at end of file
diff --git a/basis/ui/gadgets/packs/packs.factor b/basis/ui/gadgets/packs/packs.factor
index 95f04dfe4d..f47b374aeb 100644
--- a/basis/ui/gadgets/packs/packs.factor
+++ b/basis/ui/gadgets/packs/packs.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences ui.gadgets ui.baseline-alignment kernel math
-math.functions math.vectors math.order math.rectangles namespaces
-accessors fry combinators arrays ;
+USING: sequences ui.gadgets ui.baseline-alignment
+ui.baseline-alignment.private kernel math math.functions math.vectors
+math.order math.rectangles namespaces accessors fry combinators arrays ;
IN: ui.gadgets.packs
TUPLE: pack < gadget
@@ -84,8 +84,7 @@ M: pack pref-dim*
children>> dup pref-dims measure-metrics drop ;
: pack-cap-height ( pack -- n )
- children>> [ cap-height ] map sift
- [ f ] [ supremum ] if-empty ;
+ children>> [ cap-height ] map ?supremum ;
PRIVATE>
diff --git a/basis/ui/gadgets/panes/panes-tests.factor b/basis/ui/gadgets/panes/panes-tests.factor
index 0529437a76..01abe8b3d9 100644
--- a/basis/ui/gadgets/panes/panes-tests.factor
+++ b/basis/ui/gadgets/panes/panes-tests.factor
@@ -2,7 +2,7 @@ USING: alien ui.gadgets.panes ui.gadgets namespaces
kernel sequences io io.styles io.streams.string tools.test
prettyprint definitions help help.syntax help.markup
help.stylesheet splitting ui.gadgets.debug models math summary
-inspector accessors help.topics see ;
+inspector accessors help.topics see fry ;
IN: ui.gadgets.panes.tests
: #children ( -- n ) "pane" get children>> length ;
@@ -18,8 +18,9 @@ IN: ui.gadgets.panes.tests
[ t ] [ #children "num-children" get = ] unit-test
: test-gadget-text ( quot -- ? )
- dup make-pane gadget-text dup print "======" print
- swap with-string-writer dup print = ;
+ '[ _ call( -- ) ]
+ [ make-pane gadget-text dup print "======" print ]
+ [ with-string-writer dup print ] bi = ;
[ t ] [ [ "hello" write ] test-gadget-text ] unit-test
[ t ] [ [ "hello" pprint ] test-gadget-text ] unit-test
diff --git a/basis/ui/gadgets/paragraphs/paragraphs-tests.factor b/basis/ui/gadgets/paragraphs/paragraphs-tests.factor
index fcc121e584..c8494216b4 100644
--- a/basis/ui/gadgets/paragraphs/paragraphs-tests.factor
+++ b/basis/ui/gadgets/paragraphs/paragraphs-tests.factor
@@ -27,7 +27,7 @@ INSTANCE: fake-break word-break
[ { 0 0 } ] [ "a" get loc>> ] unit-test
-[ { 45 15 } ] [ "b" get loc>> ] unit-test
+[ { 45 7 } ] [ "b" get loc>> ] unit-test
[ { 0 30 } ] [ "c" get loc>> ] unit-test
diff --git a/basis/ui/gadgets/presentations/presentations.factor b/basis/ui/gadgets/presentations/presentations.factor
index 621e7006c9..a0799c7b86 100644
--- a/basis/ui/gadgets/presentations/presentations.factor
+++ b/basis/ui/gadgets/presentations/presentations.factor
@@ -10,7 +10,7 @@ IN: ui.gadgets.presentations
TUPLE: presentation < button object hook ;
: invoke-presentation ( presentation command -- )
- [ [ dup hook>> call ] [ object>> ] bi ] dip
+ [ [ dup hook>> call( presentation -- ) ] [ object>> ] bi ] dip
invoke-command ;
: invoke-primary ( presentation -- )
diff --git a/basis/ui/gadgets/scrollers/scrollers-docs.factor b/basis/ui/gadgets/scrollers/scrollers-docs.factor
index 8e0131ec31..011afa5c97 100644
--- a/basis/ui/gadgets/scrollers/scrollers-docs.factor
+++ b/basis/ui/gadgets/scrollers/scrollers-docs.factor
@@ -11,11 +11,11 @@ HELP: find-scroller
{ $values { "gadget" gadget } { "scroller/f" { $maybe scroller } } }
{ $description "Finds the first parent of " { $snippet "gadget" } " which is a " { $link scroller } ". Outputs " { $link f } " if the gadget is not contained in a " { $link scroller } "." } ;
-HELP: scroller-value
+HELP: scroll-position
{ $values { "scroller" scroller } { "loc" "a pair of integers" } }
{ $description "Outputs the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
-{ scroller-value scroll scroll>bottom scroll>top scroll>rect } related-words
+{ scroll-position set-scroll-position scroll>bottom scroll>top scroll>rect } related-words
HELP: <scroller>
{ $values { "gadget" gadget } { "scroller" "a new " { $link scroller } } }
@@ -23,7 +23,7 @@ HELP: <scroller>
{ <viewport> <scroller> } related-words
-HELP: scroll
+HELP: set-scroll-position
{ $values { "scroller" scroller } { "value" "a pair of integers" } }
{ $description "Sets the offset of the top-left corner of the scroller's " { $link viewport } "'s child." } ;
@@ -48,8 +48,8 @@ ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets"
{ $subsection scroller }
{ $subsection <scroller> }
"Getting and setting the scroll position:"
-{ $subsection scroller-value }
-{ $subsection scroll }
+{ $subsection scroll-position }
+{ $subsection set-scroll-position }
"Writing scrolling-aware gadgets:"
{ $subsection scroll>bottom }
{ $subsection scroll>top }
diff --git a/basis/ui/gadgets/scrollers/scrollers-tests.factor b/basis/ui/gadgets/scrollers/scrollers-tests.factor
index d4cdc95daf..4002c8b40e 100644
--- a/basis/ui/gadgets/scrollers/scrollers-tests.factor
+++ b/basis/ui/gadgets/scrollers/scrollers-tests.factor
@@ -45,13 +45,13 @@ IN: ui.gadgets.scrollers.tests
[ { 100 100 } ] [ "s" get viewport>> gadget-child pref-dim ] unit-test
- [ ] [ { 0 0 } "s" get scroll ] unit-test
+ [ ] [ { 0 0 } "s" get set-scroll-position ] unit-test
[ { 0 0 } ] [ "s" get model>> range-min-value ] unit-test
[ { 100 100 } ] [ "s" get model>> range-max-value ] unit-test
- [ ] [ { 10 20 } "s" get scroll ] unit-test
+ [ ] [ { 10 20 } "s" get set-scroll-position ] unit-test
[ { 10 20 } ] [ "s" get model>> range-value ] unit-test
@@ -74,7 +74,7 @@ dup layout
drop
"g2" get scroll>gadget
"s" get layout
- "s" get scroller-value
+ "s" get scroll-position
] map [ { 0 0 } = ] all?
] unit-test
@@ -104,5 +104,3 @@ dup layout
model>> dependencies>> [ range-max value>> ] map
{ 0 0 } =
] unit-test
-
-\ <scroller> must-infer
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index a526cc618b..0852a6fe5d 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -29,6 +29,13 @@ M: gadget viewport-column-header drop f ;
: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
+: set-scroll-position ( value scroller -- )
+ [
+ viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
+ 4array flip
+ ] keep
+ 2dup control-value = [ 2drop ] [ set-control-value ] if ;
+
<PRIVATE
: do-mouse-scroll ( scroller -- )
@@ -46,21 +53,14 @@ scroller H{
M: viewport pref-dim* gadget-child pref-viewport-dim ;
-: scroll ( value scroller -- )
- [
- viewport>> [ dim>> { 0 0 } ] [ gadget-child pref-dim ] bi
- 4array flip
- ] keep
- 2dup control-value = [ 2drop ] [ set-control-value ] if ;
-
: (scroll>rect) ( rect scroller -- )
{
- [ scroller-value vneg offset-rect ]
+ [ scroll-position vneg offset-rect ]
[ viewport>> dim>> rect-min ]
[ viewport>> loc>> offset-rect ]
[ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
- [ scroller-value v+ ]
- [ scroll ]
+ [ scroll-position v+ ]
+ [ set-scroll-position ]
} cleave ;
: relative-scroll-rect ( rect gadget scroller -- newrect )
@@ -72,7 +72,7 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
2&& ;
: (update-scroller) ( scroller -- )
- [ scroller-value ] keep scroll ;
+ [ scroll-position ] keep set-scroll-position ;
: (scroll>gadget) ( gadget scroller -- )
2dup swap child? [
@@ -82,7 +82,8 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
] [ f >>follows (update-scroller) drop ] if ;
: (scroll>bottom) ( scroller -- )
- [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep scroll ;
+ [ viewport>> gadget-child pref-dim { 0 1 } v* ] keep
+ set-scroll-position ;
GENERIC: update-scroller ( scroller follows -- )
diff --git a/basis/ui/gadgets/search-tables/search-tables-tests.factor b/basis/ui/gadgets/search-tables/search-tables-tests.factor
new file mode 100644
index 0000000000..5a627286f9
--- /dev/null
+++ b/basis/ui/gadgets/search-tables/search-tables-tests.factor
@@ -0,0 +1,3 @@
+IN: ui.gadgets.search-tables.tests
+USING: ui.gadgets.search-tables sequences tools.test ;
+[ [ second ] <search-table> ] must-infer
diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor
index 4a2983bfe0..fc564b6ffe 100644
--- a/basis/ui/gadgets/search-tables/search-tables.factor
+++ b/basis/ui/gadgets/search-tables/search-tables.factor
@@ -28,6 +28,7 @@ TUPLE: search-field < track field ;
: <search-field> ( model -- gadget )
horizontal search-field new-track
+ 0 >>fill
{ 5 5 } >>gap
+baseline+ >>align
swap <model-field> 10 >>min-cols >>field
@@ -73,7 +74,7 @@ CONSULT: table-protocol search-table table>> ;
dup field>> { 2 2 } <filled-border> f track-add
values search 500 milliseconds <delay> quot <string-search>
renderer <table> f >>takes-focus? >>table
- dup table>> <scroller> 1 track-add ;
+ dup table>> <scroller> 1 track-add ; inline
M: search-table model-changed
nip field>> clear-search-field ;
diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor
index 6cfb83a49a..80829d7b66 100644
--- a/basis/ui/gadgets/sliders/sliders.factor
+++ b/basis/ui/gadgets/sliders/sliders.factor
@@ -53,8 +53,8 @@ CONSTANT: min-thumb-dim 30
[ slider-max* 1 max ]
bi / ;
-: slider>screen ( m slider -- n ) slider-scale * elevator-padding + ;
-: screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ;
+: slider>screen ( m slider -- n ) slider-scale * ;
+: screen>slider ( m slider -- n ) slider-scale / ;
M: slider model-changed nip elevator>> relayout-1 ;
@@ -133,7 +133,7 @@ elevator H{
swap >>orientation ;
: thumb-loc ( slider -- loc )
- [ slider-value ] keep slider>screen ;
+ [ slider-value ] keep slider>screen elevator-padding + ;
: layout-thumb-loc ( thumb slider -- )
[ thumb-loc ] [ orientation>> ] bi n*v
diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor
index 592900d0cb..39e42aa723 100644
--- a/basis/ui/gadgets/slots/slots.factor
+++ b/basis/ui/gadgets/slots/slots.factor
@@ -23,14 +23,14 @@ TUPLE: slot-editor < track ref close-hook update-hook text ;
} define-command
: close ( slot-editor -- )
- dup close-hook>> call ;
+ dup close-hook>> call( slot-editor -- ) ;
\ close H{
{ +description+ "Close the slot editor without saving changes." }
} define-command
: close-and-update ( slot-editor -- )
- [ update-hook>> call ] [ close ] bi ;
+ [ update-hook>> call( -- ) ] [ close ] bi ;
: slot-editor-value ( slot-editor -- object )
text>> control-value parse-fresh first ;
@@ -44,11 +44,8 @@ TUPLE: slot-editor < track ref close-hook update-hook text ;
{ +description+ "Parse the object being edited, and store the result back into the edited slot." }
} define-command
-: eval-1 ( string -- object )
- 1array [ eval ] with-datastack first ;
-
: com-eval ( slot-editor -- )
- [ [ text>> editor-string eval-1 ] [ ref>> ] bi set-ref ]
+ [ [ text>> editor-string eval( -- result ) ] [ ref>> ] bi set-ref ]
[ close-and-update ]
bi ;
diff --git a/basis/ui/gadgets/status-bar/status-bar-docs.factor b/basis/ui/gadgets/status-bar/status-bar-docs.factor
index 57c69c2a66..7a68310e36 100644
--- a/basis/ui/gadgets/status-bar/status-bar-docs.factor
+++ b/basis/ui/gadgets/status-bar/status-bar-docs.factor
@@ -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"
\ No newline at end of file
+ABOUT: "ui.gadgets.status-bar"
diff --git a/basis/ui/gadgets/status-bar/status-bar.factor b/basis/ui/gadgets/status-bar/status-bar.factor
index a1c2dca23d..0d3015508e 100644
--- a/basis/ui/gadgets/status-bar/status-bar.factor
+++ b/basis/ui/gadgets/status-bar/status-bar.factor
@@ -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 -- )
diff --git a/basis/ui/gadgets/tables/tables-tests.factor b/basis/ui/gadgets/tables/tables-tests.factor
index 11f080af0a..3191753324 100644
--- a/basis/ui/gadgets/tables/tables-tests.factor
+++ b/basis/ui/gadgets/tables/tables-tests.factor
@@ -1,6 +1,6 @@
IN: ui.gadgets.tables.tests
-USING: ui.gadgets.tables ui.gadgets.scrollers accessors
-models namespaces tools.test kernel ;
+USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors
+models namespaces tools.test kernel combinators ;
SINGLETON: test-renderer
@@ -8,15 +8,40 @@ M: test-renderer row-columns drop ;
M: test-renderer column-titles drop { "First" "Last" } ;
-[ ] [
+: test-table ( -- table )
{
{ "Britney" "Spears" }
{ "Justin" "Timberlake" }
{ "Don" "Stewart" }
- } <model> test-renderer <table>
- "table" set
+ } <model> test-renderer <table> ;
+
+[ ] [
+ test-table "table" set
] unit-test
[ ] [
"table" get <scroller> "scroller" set
+] unit-test
+
+[ { "Justin" "Timberlake" } { "Britney" "Spears" } ] [
+ test-table t >>selection-required? dup [
+ {
+ [ 1 select-row ]
+ [
+ model>> {
+ { "Justin" "Timberlake" }
+ { "Britney" "Spears" }
+ { "Don" "Stewart" }
+ } swap set-model
+ ]
+ [ selected-row drop ]
+ [
+ model>> {
+ { "Britney" "Spears" }
+ { "Don" "Stewart" }
+ } swap set-model
+ ]
+ [ selected-row drop ]
+ } cleave
+ ] with-grafted-gadget
] unit-test
\ No newline at end of file
diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor
index 77249149ae..ba3b5a2f78 100644
--- a/basis/ui/gadgets/tables/tables.factor
+++ b/basis/ui/gadgets/tables/tables.factor
@@ -5,8 +5,8 @@ math.functions math.rectangles math.order math.vectors namespaces
opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text
ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support
-math.rectangles models math.ranges sequences combinators fonts locals
-strings ;
+math.rectangles models math.ranges sequences combinators
+combinators.short-circuit fonts locals strings ;
IN: ui.gadgets.tables
! Row rendererer protocol
@@ -46,27 +46,34 @@ mouse-index
{ takes-focus? initial: t }
focused? ;
-: <table> ( rows renderer -- table )
- table new-line-gadget
+: new-table ( rows renderer class -- table )
+ new-line-gadget
swap >>renderer
swap >>model
f <model> >>selected-value
sans-serif-font >>font
focus-border-color >>focus-border-color
- transparent >>column-line-color ;
+ transparent >>column-line-color ; inline
+
+: <table> ( rows renderer -- table ) table new-table ;
<PRIVATE
GENERIC: cell-width ( font cell -- x )
GENERIC: cell-height ( font cell -- y )
+GENERIC: cell-padding ( cell -- y )
GENERIC: draw-cell ( font cell -- )
M: string cell-width text-width ;
M: string cell-height text-height ceiling ;
+M: string cell-padding drop 0 ;
M: string draw-cell draw-text ;
+CONSTANT: image-padding 2
+
M: image-name cell-width nip image-dim first ;
M: image-name cell-height nip image-dim second ;
+M: image-name cell-padding drop image-padding ;
M: image-name draw-cell nip draw-image ;
: table-rows ( table -- rows )
@@ -87,7 +94,7 @@ CONSTANT: column-title-background COLOR: light-gray
if ;
: row-column-widths ( table row -- widths )
- [ font>> ] dip [ cell-width ] with map ;
+ [ font>> ] dip [ [ cell-width ] [ cell-padding ] bi + ] with map ;
: compute-total-width ( gap widths -- total )
swap [ column-offsets drop ] keep - ;
@@ -162,9 +169,10 @@ M: table layout*
'[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
] bi ;
-: column-loc ( font column width align -- loc )
- [ [ cell-width ] dip swap - ] dip
- * >integer 0 2array ;
+:: column-loc ( font column width align -- loc )
+ font column cell-width width swap - align * column cell-padding 2 / 1 align - * +
+ font column cell-height \ line-height get swap - 2 /
+ [ >integer ] bi@ 2array ;
: translate-column ( width gap -- )
+ 0 2array gl-translate ;
@@ -203,18 +211,21 @@ M: table draw-line ( row index table -- )
M: table draw-gadget*
dup control-value empty? [ drop ] [
- {
- [ draw-selected-row ]
- [ draw-lines ]
- [ draw-column-lines ]
- [ draw-focused-row ]
- [ draw-moused-row ]
- } cleave
+ dup line-height \ line-height [
+ {
+ [ draw-selected-row ]
+ [ draw-lines ]
+ [ draw-column-lines ]
+ [ draw-focused-row ]
+ [ draw-moused-row ]
+ } cleave
+ ] with-variable
] if ;
M: table line-height ( table -- y )
[ font>> ] [ renderer>> prototype-row ] bi
- [ cell-height ] with [ max ] map-reduce ;
+ [ [ cell-height ] [ cell-padding ] bi + ] with
+ [ max ] map-reduce ;
M: table pref-dim*
[ compute-column-widths drop ] keep
@@ -237,9 +248,6 @@ PRIVATE>
: update-selected-value ( table -- )
[ selected-row drop ] [ selected-value>> ] bi set-model ;
-: initial-selected-index ( model table -- n/f )
- [ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ;
-
: show-row-summary ( table n -- )
over nth-row
[ swap [ renderer>> row-value ] keep show-summary ]
@@ -249,8 +257,28 @@ PRIVATE>
: hide-mouse-help ( table -- )
f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
+: find-row-index ( value table -- n/f )
+ [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ;
+
+: initial-selected-index ( table -- n/f )
+ {
+ [ model>> value>> empty? not ]
+ [ selection-required?>> ]
+ [ drop 0 ]
+ } 1&& ;
+
+: (update-selected-index) ( table -- n/f )
+ [ selected-value>> value>> ] keep over
+ [ find-row-index ] [ 2drop f ] if ;
+
+: update-selected-index ( table -- n/f )
+ {
+ [ (update-selected-index) ]
+ [ initial-selected-index ]
+ } 1|| ;
+
M: table model-changed
- [ nip ] [ initial-selected-index ] 2bi {
+ nip dup update-selected-index {
[ >>selected-index f >>mouse-index drop ]
[ show-row-summary ]
[ drop update-selected-value ]
@@ -293,6 +321,8 @@ PRIVATE>
: table-button-up ( table -- )
dup row-action? [ row-action ] [ update-selected-value ] if ;
+PRIVATE>
+
: select-row ( table n -- )
over validate-line
[ (select-row) ]
@@ -300,6 +330,8 @@ PRIVATE>
[ show-row-summary ]
2tri ;
+<PRIVATE
+
: prev/next-row ( table n -- )
[ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
@@ -345,9 +377,9 @@ PRIVATE>
show-operations-menu
] [ drop ] if-mouse-row ;
-: focus-table ( table -- ) t >>focused? drop ;
+: focus-table ( table -- ) t >>focused? relayout-1 ;
-: unfocus-table ( table -- ) f >>focused? drop ;
+: unfocus-table ( table -- ) f >>focused? relayout-1 ;
table "sundry" f {
{ mouse-enter show-mouse-help }
@@ -379,14 +411,16 @@ TUPLE: column-headers < gadget table ;
column-title-background <solid> >>interior ;
: draw-column-titles ( table -- )
- {
- [ renderer>> column-titles ]
- [ column-widths>> ]
- [ table-column-alignment ]
- [ font>> column-title-font ]
- [ gap>> ]
- } cleave
- draw-columns ;
+ dup font>> font-metrics height>> \ line-height [
+ {
+ [ renderer>> column-titles ]
+ [ column-widths>> ]
+ [ table-column-alignment ]
+ [ font>> column-title-font ]
+ [ gap>> ]
+ } cleave
+ draw-columns
+ ] with-variable ;
M: column-headers draw-gadget*
table>> draw-column-titles ;
diff --git a/basis/ui/gadgets/viewports/viewports.factor b/basis/ui/gadgets/viewports/viewports.factor
index c14c7f01fb..b154ef2322 100644
--- a/basis/ui/gadgets/viewports/viewports.factor
+++ b/basis/ui/gadgets/viewports/viewports.factor
@@ -23,7 +23,7 @@ M: viewport layout*
M: viewport focusable-child*
gadget-child ;
-: scroller-value ( scroller -- loc )
+: scroll-position ( scroller -- loc )
model>> range-value [ >integer ] map ;
M: viewport model-changed
@@ -31,7 +31,7 @@ M: viewport model-changed
[ relayout-1 ]
[
[ gadget-child ]
- [ scroller-value vneg ]
+ [ scroll-position vneg ]
[ constraint>> ]
tri v* >>loc drop
] bi ;
diff --git a/basis/ui/gadgets/worlds/worlds-docs.factor b/basis/ui/gadgets/worlds/worlds-docs.factor
old mode 100644
new mode 100755
index e3c1226f22..d4e9790d89
--- a/basis/ui/gadgets/worlds/worlds-docs.factor
+++ b/basis/ui/gadgets/worlds/worlds-docs.factor
@@ -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" } ;
diff --git a/basis/ui/gadgets/worlds/worlds-tests.factor b/basis/ui/gadgets/worlds/worlds-tests.factor
index f738a8cff4..515a0b3aa8 100644
--- a/basis/ui/gadgets/worlds/worlds-tests.factor
+++ b/basis/ui/gadgets/worlds/worlds-tests.factor
@@ -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
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
old mode 100644
new mode 100755
index 655c9ba49d..3568559eac
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -1,17 +1,32 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs continuations kernel math models
-namespaces opengl 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 ;
+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.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 ;
@@ -44,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
@@ -76,16 +96,36 @@ SYMBOL: flush-layout-cache-hook
flush-layout-cache-hook [ [ ] ] initialize
-: (draw-world) ( world -- )
- dup handle>> [
- {
- [ 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.
@@ -106,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
@@ -147,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
+
diff --git a/basis/ui/gestures/gestures-tests.factor b/basis/ui/gestures/gestures-tests.factor
index 402015ee7c..3bcea27819 100644
--- a/basis/ui/gestures/gestures-tests.factor
+++ b/basis/ui/gestures/gestures-tests.factor
@@ -1,5 +1,2 @@
IN: ui.gestures.tests
USING: tools.test ui.gestures ;
-
-\ handle-gesture must-infer
-\ send-queued-gesture must-infer
\ No newline at end of file
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index c7db0839d7..7e038ef2e0 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -310,16 +310,16 @@ HOOK: keysym>string os ( keysym -- string )
M: macosx keysym>string >upper ;
-M: object keysym>string ;
+M: object keysym>string dup length 1 = [ >lower ] when ;
M: key-down gesture>string
[ mods>> ] [ sym>> ] bi
{
{ [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] }
{ [ dup " " = ] [ drop "SPACE" ] }
- [ keysym>string ]
+ [ ]
} cond
- [ modifiers>string ] dip append ;
+ [ modifiers>string ] [ keysym>string ] bi* append ;
M: button-up gesture>string
[
diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor
index 8e36f2a3b1..2b1caa8ab9 100755
--- a/basis/ui/images/images.factor
+++ b/basis/ui/images/images.factor
@@ -20,7 +20,7 @@ PRIVATE>
: rendered-image ( path -- texture )
world get image-texture-cache
- [ cached-image [ { 0 0 } ] keep dim>> <texture> ] cache ;
+ [ cached-image { 0 0 } <texture> ] cache ;
: draw-image ( image-name -- )
rendered-image draw-texture ;
diff --git a/basis/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor
index cfec6613b1..4114a2c3b2 100644
--- a/basis/ui/operations/operations-docs.factor
+++ b/basis/ui/operations/operations-docs.factor
@@ -4,7 +4,7 @@ ui.gestures ;
IN: ui.operations
: $operations ( element -- )
- >quotation call
+ >quotation call( -- obj )
f operations>commands
command-map. ;
diff --git a/basis/ui/operations/operations-tests.factor b/basis/ui/operations/operations-tests.factor
index 4612ea79b0..6e8339a539 100644
--- a/basis/ui/operations/operations-tests.factor
+++ b/basis/ui/operations/operations-tests.factor
@@ -26,5 +26,3 @@ io.streams.string math help help.markup accessors ;
[ ] [
[ { $operations \ + } print-element ] with-string-writer drop
] unit-test
-
-\ object-operations must-infer
\ No newline at end of file
diff --git a/extra/ui/offscreen/authors.txt b/basis/ui/pixel-formats/authors.txt
similarity index 100%
rename from extra/ui/offscreen/authors.txt
rename to basis/ui/pixel-formats/authors.txt
diff --git a/basis/ui/pixel-formats/pixel-formats-docs.factor b/basis/ui/pixel-formats/pixel-formats-docs.factor
new file mode 100644
index 0000000000..003b205c3d
--- /dev/null
+++ b/basis/ui/pixel-formats/pixel-formats-docs.factor
@@ -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"
diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor
new file mode 100644
index 0000000000..52abf44362
--- /dev/null
+++ b/basis/ui/pixel-formats/pixel-formats.factor
@@ -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 -- )
+
diff --git a/basis/ui/pixel-formats/summary.txt b/basis/ui/pixel-formats/summary.txt
new file mode 100644
index 0000000000..517f42458b
--- /dev/null
+++ b/basis/ui/pixel-formats/summary.txt
@@ -0,0 +1 @@
+Cross-platform OpenGL context pixel format specifiers
diff --git a/basis/ui/render/render-tests.factor b/basis/ui/render/render-tests.factor
index 3410560ba9..3ae0082be1 100644
--- a/basis/ui/render/render-tests.factor
+++ b/basis/ui/render/render-tests.factor
@@ -1,4 +1,2 @@
IN: ui.render.tests
USING: ui.render tools.test ;
-
-\ draw-gadget must-infer
\ No newline at end of file
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index 09c26fd271..c4e6f56886 100755
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math.rectangles math.vectors namespaces kernel accessors
-assocs combinators sequences opengl opengl.gl opengl.glu colors
+assocs combinators sequences opengl opengl.gl colors
colors.constants ui.gadgets ui.pens ;
IN: ui.render
@@ -22,7 +22,7 @@ SYMBOL: viewport-translation
dim>>
[ { 0 1 } v* viewport-translation set ]
[ [ { 0 0 } ] dip gl-viewport ]
- [ [ 0 ] dip first2 0 gluOrtho2D ] tri
+ [ [ 0 ] dip first2 0 1 -1 glOrtho ] tri
]
[ clip set ] bi
do-clip ;
diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor
index 404624da95..0d720ac0b1 100755
--- a/basis/ui/text/core-text/core-text.factor
+++ b/basis/ui/text/core-text/core-text.factor
@@ -20,9 +20,7 @@ M: core-text-renderer flush-layout-cache
: rendered-line ( font string -- texture )
world get world-text-handle [
- cached-line
- [ image>> ] [ loc>> ] [ image>> dim>> ] tri
- <texture>
+ cached-line [ image>> ] [ loc>> ] bi <texture>
] 2cache ;
M: core-text-renderer draw-string ( font string -- )
diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor
index 46328d11d5..92c4fe5c75 100755
--- a/basis/ui/text/pango/pango.factor
+++ b/basis/ui/text/pango/pango.factor
@@ -16,9 +16,7 @@ M: pango-renderer flush-layout-cache
: rendered-layout ( font string -- texture )
world get world-text-handle [
- cached-layout
- [ image>> ] [ text-position vneg ] [ image>> dim>> ] tri
- <texture>
+ cached-layout [ image>> ] [ text-position vneg ] bi <texture>
] 2cache ;
M: pango-renderer draw-string ( font string -- )
diff --git a/basis/ui/text/text-docs.factor b/basis/ui/text/text-docs.factor
index 4ac2fbbaa8..c2732754f6 100644
--- a/basis/ui/text/text-docs.factor
+++ b/basis/ui/text/text-docs.factor
@@ -46,7 +46,7 @@ HELP: offset>x
HELP: line-metrics
{ $values { "font" font } { "string" string } { "metrics" line-metrics } }
-{ $contract "Outputs a " { $link line-metrics } " object with text measurements." } ;
+{ $contract "Outputs a " { $link metrics } " object with text measurements." } ;
ARTICLE: "text-rendering" "Rendering text"
"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11."
diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor
index d787fe8ea9..c1f05182e6 100755
--- a/basis/ui/text/text.factor
+++ b/basis/ui/text/text.factor
@@ -66,7 +66,7 @@ M: string draw-text draw-string ;
M: selection draw-text draw-string ;
M: array draw-text
- GL_MODELVIEW [
+ [
[
[ draw-string ]
[ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi
@@ -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
\ No newline at end of file
+{
+ { [ os macosx? ] [ "core-text" ] }
+ { [ os windows? ] [ "uniscribe" ] }
+ { [ os unix? ] [ "pango" ] }
+} cond "ui.text." prepend require
diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor
index dcec4ab17e..d56da86b86 100755
--- a/basis/ui/text/uniscribe/uniscribe.factor
+++ b/basis/ui/text/uniscribe/uniscribe.factor
@@ -16,7 +16,7 @@ M: uniscribe-renderer flush-layout-cache
: rendered-script-string ( font string -- texture )
world get world-text-handle
- [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi <texture> ]
+ [ cached-script-string image>> { 0 0 } <texture> ]
2cache ;
M: uniscribe-renderer draw-string ( font string -- )
diff --git a/basis/ui/tools/browser/browser-tests.factor b/basis/ui/tools/browser/browser-tests.factor
index 3757f392c4..8027babc3f 100644
--- a/basis/ui/tools/browser/browser-tests.factor
+++ b/basis/ui/tools/browser/browser-tests.factor
@@ -1,5 +1,4 @@
IN: ui.tools.browser.tests
USING: tools.test ui.gadgets.debug ui.tools.browser math ;
-\ <browser-gadget> must-infer
[ ] [ \ + <browser-gadget> [ ] with-grafted-gadget ] unit-test
diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor
index e242b743f8..1b8af1dd03 100644
--- a/basis/ui/tools/browser/browser.factor
+++ b/basis/ui/tools/browser/browser.factor
@@ -1,23 +1,36 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: debugger help help.topics help.crossref help.home kernel
-models compiler.units assocs words vocabs accessors fry
-combinators.short-circuit namespaces sequences models
-models.history help.apropos combinators ui.commands ui.gadgets
-ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
-ui.gestures ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar
-ui.gadgets.glass ui.gadgets.borders ui.tools.common
-ui.tools.browser.popups ui ;
+USING: debugger classes help help.topics help.crossref help.home kernel models
+compiler.units assocs words vocabs accessors fry arrays
+combinators.short-circuit namespaces sequences models help.apropos
+combinators ui ui.commands ui.gadgets ui.gadgets.panes
+ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons
+ui.gadgets.packs ui.gadgets.editors ui.gadgets.labels
+ui.gadgets.status-bar ui.gadgets.glass ui.gadgets.borders ui.gadgets.viewports
+ui.tools.common ui.tools.browser.popups ui.tools.browser.history ;
IN: ui.tools.browser
-TUPLE: browser-gadget < tool pane scroller search-field popup ;
+TUPLE: browser-gadget < tool history pane scroller search-field popup ;
{ 650 400 } browser-gadget set-tool-dim
+M: browser-gadget history-value
+ [ control-value ] [ scroller>> scroll-position ]
+ bi 2array ;
+
+M: browser-gadget set-history-value
+ [ first2 ] dip
+ [ set-control-value ] [ scroller>> set-scroll-position ]
+ bi-curry bi* ;
+
: show-help ( link browser-gadget -- )
- [ >link ] [ model>> ] bi*
- [ [ add-recent ] [ add-history ] bi* ] [ set-model ] 2bi ;
+ [ >link ] dip
+ [
+ 2dup model>> value>> =
+ [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if
+ ]
+ [ model>> set-model ]
+ 2bi ;
: <help-pane> ( browser-gadget -- gadget )
model>> [ '[ _ print-topic ] try ] <pane-control> ;
@@ -41,7 +54,8 @@ TUPLE: browser-gadget < tool pane scroller search-field popup ;
: <browser-gadget> ( link -- gadget )
vertical browser-gadget new-track
1 >>fill
- swap >link <history> >>model
+ swap >link <model> >>model
+ dup <history> >>history
dup <search-field> >>search-field
dup <browser-toolbar> { 3 3 } <border> { 1 0 } >>fill f track-add
dup <help-pane> >>pane
@@ -80,6 +94,10 @@ M: browser-gadget focusable-child* search-field>> ;
: browser-window ( -- )
"help.home" (browser-window) ;
+: error-help-window ( error -- )
+ [ error-help ]
+ [ dup tuple? [ class ] [ drop "errors" ] if ] bi or (browser-window) ;
+
\ browser-window H{ { +nullary+ t } } define-command
: com-browse ( link -- )
@@ -93,9 +111,9 @@ M: browser-gadget focusable-child* search-field>> ;
\ show-browser H{ { +nullary+ t } } define-command
-: com-back ( browser -- ) model>> go-back ;
+: com-back ( browser -- ) history>> go-back ;
-: com-forward ( browser -- ) model>> go-forward ;
+: com-forward ( browser -- ) history>> go-forward ;
: com-home ( browser -- ) "help.home" swap show-help ;
diff --git a/basis/ui/tools/browser/history/authors.txt b/basis/ui/tools/browser/history/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/ui/tools/browser/history/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/ui/tools/browser/history/history-tests.factor b/basis/ui/tools/browser/history/history-tests.factor
new file mode 100644
index 0000000000..454e4700a0
--- /dev/null
+++ b/basis/ui/tools/browser/history/history-tests.factor
@@ -0,0 +1,42 @@
+USING: namespaces ui.tools.browser.history sequences tools.test
+accessors kernel ;
+IN: ui.tools.browser.history.tests
+
+TUPLE: dummy obj ;
+
+M: dummy history-value obj>> ;
+M: dummy set-history-value (>>obj) ;
+
+dummy new <history> "history" set
+
+"history" get add-history
+
+[ t ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
+"history" get add-history
+3 "history" get owner>> set-history-value
+
+[ t ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
+"history" get add-history
+4 "history" get owner>> set-history-value
+
+[ f ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
+"history" get go-back
+
+[ 3 ] [ "history" get owner>> history-value ] unit-test
+
+[ t ] [ "history" get back>> empty? ] unit-test
+[ f ] [ "history" get forward>> empty? ] unit-test
+
+"history" get go-forward
+
+[ 4 ] [ "history" get owner>> history-value ] unit-test
+
+[ f ] [ "history" get back>> empty? ] unit-test
+[ t ] [ "history" get forward>> empty? ] unit-test
+
diff --git a/basis/ui/tools/browser/history/history.factor b/basis/ui/tools/browser/history/history.factor
new file mode 100644
index 0000000000..f80189c783
--- /dev/null
+++ b/basis/ui/tools/browser/history/history.factor
@@ -0,0 +1,32 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences locals ;
+IN: ui.tools.browser.history
+
+TUPLE: history owner back forward ;
+
+: <history> ( owner -- history )
+ V{ } clone V{ } clone history boa ;
+
+GENERIC: history-value ( object -- value )
+
+GENERIC: set-history-value ( value object -- )
+
+: (add-history) ( history to -- )
+ swap owner>> history-value dup [ swap push ] [ 2drop ] if ;
+
+:: go-back/forward ( history to from -- )
+ from empty? [
+ history to (add-history)
+ from pop history owner>> set-history-value
+ ] unless ;
+
+: go-back ( history -- )
+ dup [ forward>> ] [ back>> ] bi go-back/forward ;
+
+: go-forward ( history -- )
+ dup [ back>> ] [ forward>> ] bi go-back/forward ;
+
+: add-history ( history -- )
+ dup forward>> delete-all
+ dup back>> (add-history) ;
\ No newline at end of file
diff --git a/basis/ui/tools/browser/popups/popups.factor b/basis/ui/tools/browser/popups/popups.factor
index 05d7779305..2cd90ab335 100644
--- a/basis/ui/tools/browser/popups/popups.factor
+++ b/basis/ui/tools/browser/popups/popups.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs definitions fry help.topics kernel
colors.constants math.rectangles models.arrow namespaces sequences
-sorting definitions.icons ui.gadgets ui.gadgets.glass
+sorting definitions.icons tools.crossref ui.gadgets ui.gadgets.glass
ui.gadgets.labeled ui.gadgets.scrollers ui.gadgets.tables
ui.gadgets.search-tables ui.gadgets.wrappers ui.gestures ui.operations
ui.pens.solid ui.images ;
@@ -46,7 +46,7 @@ SLOT: model
: show-links-popup ( browser-gadget quot title -- )
[ dup model>> ] 2dip <links-popup>
- [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ;
+ [ hand-loc get { 0 0 } <rect> show-glass ] [ request-focus ] bi ; inline
: com-show-outgoing-links ( browser-gadget -- )
[ uses ] "Outgoing links" show-links-popup ;
diff --git a/basis/ui/tools/common/common.factor b/basis/ui/tools/common/common.factor
index e581e72e24..95af20ec72 100644
--- a/basis/ui/tools/common/common.factor
+++ b/basis/ui/tools/common/common.factor
@@ -7,7 +7,7 @@ IN: ui.tools.common
SYMBOL: tool-dims
-tool-dims global [ H{ } clone or ] change-at
+tool-dims [ H{ } clone ] initialize
TUPLE: tool < track ;
diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor
index c3ead4e3f5..42666ab064 100644
--- a/basis/ui/tools/debugger/debugger.factor
+++ b/basis/ui/tools/debugger/debugger.factor
@@ -8,7 +8,7 @@ ui.gadgets.buttons ui.gadgets.labels ui.gadgets.panes
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
-ui.tools.inspector ;
+ui.tools.inspector ui.tools.browser ;
IN: ui.tools.debugger
TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
@@ -86,9 +86,7 @@ debugger "gestures" f {
: com-traceback ( debugger -- ) continuation>> traceback-window ;
-: com-help ( debugger -- ) error>> (:help) ;
-
-\ com-help H{ { +listener+ t } } define-command
+: com-help ( debugger -- ) error>> error-help-window ;
: com-edit ( debugger -- ) error>> (:edit) ;
diff --git a/basis/ui/tools/error-list/authors.txt b/basis/ui/tools/error-list/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/ui/tools/error-list/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/ui/tools/error-list/error-list-docs.factor b/basis/ui/tools/error-list/error-list-docs.factor
new file mode 100644
index 0000000000..5040a13be2
--- /dev/null
+++ b/basis/ui/tools/error-list/error-list-docs.factor
@@ -0,0 +1,19 @@
+IN: ui.tools.error-list
+USING: help.markup help.syntax ui.tools.common ui.commands ;
+
+ARTICLE: "ui.tools.error-list" "UI error list tool"
+"The error list tool displays messages generated by tools which process source files and definitions. To display the error list, press " { $command tool "common" show-error-list } " in any UI tool window."
+$nl
+"The " { $vocab-link "source-files.errors" } " vocabulary contains backend code used by this tool."
+{ $heading "Message icons" }
+{ $table
+ { "Icon" "Message type" "Reference" }
+ ! { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } }
+ ! { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } }
+ { { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } }
+ { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } }
+ { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
+ { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } }
+} ;
+
+ABOUT: "ui.tools.error-list"
diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor
new file mode 100644
index 0000000000..704ae112e5
--- /dev/null
+++ b/basis/ui/tools/error-list/error-list.factor
@@ -0,0 +1,191 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays sequences sorting assocs colors.constants fry
+combinators combinators.smart combinators.short-circuit editors make
+memoize compiler.units fonts kernel io.pathnames prettyprint
+source-files.errors math.parser init math.order models models.arrow
+models.arrow.smart models.search models.mapping debugger
+namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes
+ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures
+ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
+ui.tools.inspector ui.gadgets.status-bar ui.operations
+ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
+ui.gadgets.labels ui.baseline-alignment ui.images
+compiler.errors tools.errors tools.errors.model ;
+IN: ui.tools.error-list
+
+CONSTANT: source-file-icon
+ T{ image-name f "vocab:ui/tools/error-list/icons/source-file.tiff" }
+
+MEMO: error-icon ( type -- image-name )
+ error-icon-path <image-name> ;
+
+: <checkboxes> ( alist -- gadget )
+ [ <shelf> { 15 0 } >>gap ] dip
+ [ swap <checkbox> add-gadget ] assoc-each ;
+
+: <error-toggle> ( -- model gadget )
+ #! Linkage errors are not shown by default.
+ error-types get [ fatal?>> <model> ] assoc-map
+ [ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
+ [ <mapping> ] bi ;
+
+TUPLE: error-list-gadget < tool
+visible-errors source-file error
+error-toggle source-file-table error-table error-display ;
+
+SINGLETON: source-file-renderer
+
+M: source-file-renderer row-columns
+ drop first2 [
+ [ source-file-icon ]
+ [ +listener-input+ or ]
+ [ length number>string ] tri*
+ ] output>array ;
+
+M: source-file-renderer prototype-row
+ drop source-file-icon "" "" 3array ;
+
+M: source-file-renderer row-value
+ drop dup [ first [ <pathname> ] [ f ] if* ] when ;
+
+M: source-file-renderer column-titles
+ drop { "" "File" "Errors" } ;
+
+M: source-file-renderer column-alignment drop { 0 0 1 } ;
+
+M: source-file-renderer filled-column drop 1 ;
+
+: <source-file-model> ( model -- model' )
+ [ group-by-source-file >alist sort-keys ] <arrow> ;
+
+:: <source-file-table> ( error-list -- table )
+ error-list model>> <source-file-model>
+ source-file-renderer
+ <table>
+ [ invoke-primary-operation ] >>action
+ COLOR: dark-gray >>column-line-color
+ 6 >>gap
+ 5 >>min-rows
+ 5 >>max-rows
+ 60 >>min-cols
+ 60 >>max-cols
+ t >>selection-required?
+ error-list source-file>> >>selected-value ;
+
+SINGLETON: error-renderer
+
+M: error-renderer row-columns
+ drop [
+ {
+ [ error-type error-icon ]
+ [ line#>> [ number>string ] [ "" ] if* ]
+ [ asset>> [ unparse-short ] [ "" ] if* ]
+ [ error>> summary ]
+ } cleave
+ ] output>array ;
+
+M: error-renderer prototype-row
+ drop [ +compiler-error+ error-icon "" "" "" ] output>array ;
+
+M: error-renderer row-value
+ drop ;
+
+M: error-renderer column-titles
+ drop { "" "Line" "Asset" "Error" } ;
+
+M: error-renderer column-alignment drop { 0 1 0 0 } ;
+
+: sort-errors ( seq -- seq' )
+ [ [ [ line#>> ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc
+ sort-keys values ;
+
+: file-matches? ( error pathname/f -- ? )
+ [ file>> ] [ dup [ string>> ] when ] bi* = ;
+
+: <error-table-model> ( error-list -- model )
+ [ model>> ] [ source-file>> ] bi
+ [ file-matches? ] <search>
+ [ sort-errors ] <arrow> ;
+
+:: <error-table> ( error-list -- table )
+ error-list <error-table-model>
+ error-renderer
+ <table>
+ [ invoke-primary-operation ] >>action
+ COLOR: dark-gray >>column-line-color
+ 6 >>gap
+ 5 >>min-rows
+ 5 >>max-rows
+ 60 >>min-cols
+ 60 >>max-cols
+ t >>selection-required?
+ error-list error>> >>selected-value ;
+
+TUPLE: error-display < track ;
+
+: <error-display> ( error-list -- gadget )
+ vertical error-display new-track
+ add-toolbar
+ swap error>> >>model
+ dup model>> [ [ print-error ] when* ] <pane-control> <scroller> 1 track-add ;
+
+: com-inspect ( error-display -- )
+ model>> value>> [ inspector ] when* ;
+
+: com-help ( error-display -- )
+ model>> value>> [ error>> error-help-window ] when* ;
+
+: com-edit ( error-display -- )
+ model>> value>> [ edit-error ] when* ;
+
+error-display "toolbar" f {
+ { f com-inspect }
+ { f com-help }
+ { f com-edit }
+} define-command-map
+
+: <error-list-toolbar> ( error-list -- toolbar )
+ [ <toolbar> ] [ error-toggle>> "Show errors:" label-on-left add-gadget ] bi ;
+
+: <error-model> ( visible-errors model -- model' )
+ [ swap '[ error-type _ at ] filter ] <smart-arrow> ;
+
+:: <error-list-gadget> ( model -- gadget )
+ vertical error-list-gadget new-track
+ <error-toggle> [ >>error-toggle ] [ >>visible-errors ] bi*
+ dup visible-errors>> model <error-model> >>model
+ f <model> >>source-file
+ f <model> >>error
+ dup <source-file-table> >>source-file-table
+ dup <error-table> >>error-table
+ dup <error-display> >>error-display
+ :> error-list
+ error-list vertical <track>
+ { 5 5 } >>gap
+ error-list <error-list-toolbar> f track-add
+ error-list source-file-table>> <scroller> "Source files" <labeled-gadget> 1/4 track-add
+ error-list error-table>> <scroller> "Errors" <labeled-gadget> 1/2 track-add
+ error-list error-display>> "Details" <labeled-gadget> 1/4 track-add
+ { 5 5 } <filled-border> 1 track-add ;
+
+M: error-list-gadget focusable-child*
+ source-file-table>> ;
+
+: error-list-help ( -- ) "ui.tools.error-list" com-browse ;
+
+\ error-list-help H{ { +nullary+ t } } define-command
+
+error-list-gadget "toolbar" f {
+ { T{ key-down f f "F1" } error-list-help }
+} define-command-map
+
+: error-list-window ( -- )
+ error-list-model get [ drop all-errors ] <arrow>
+ <error-list-gadget> "Errors" open-status-window ;
+
+: show-error-list ( -- )
+ [ error-list-gadget? ] find-window
+ [ raise-window ] [ error-list-window ] if* ;
+
+\ show-error-list H{ { +nullary+ t } } define-command
diff --git a/basis/ui/tools/error-list/icons/compiler-error.tiff b/basis/ui/tools/error-list/icons/compiler-error.tiff
new file mode 100644
index 0000000000..7a53d578fa
Binary files /dev/null and b/basis/ui/tools/error-list/icons/compiler-error.tiff differ
diff --git a/basis/ui/tools/error-list/icons/help-lint-error.tiff b/basis/ui/tools/error-list/icons/help-lint-error.tiff
new file mode 100644
index 0000000000..464728a70c
Binary files /dev/null and b/basis/ui/tools/error-list/icons/help-lint-error.tiff differ
diff --git a/basis/ui/tools/error-list/icons/linkage-error.tiff b/basis/ui/tools/error-list/icons/linkage-error.tiff
new file mode 100644
index 0000000000..78644fd819
Binary files /dev/null and b/basis/ui/tools/error-list/icons/linkage-error.tiff differ
diff --git a/basis/ui/tools/error-list/icons/note.tiff b/basis/ui/tools/error-list/icons/note.tiff
new file mode 100644
index 0000000000..834dea6b82
Binary files /dev/null and b/basis/ui/tools/error-list/icons/note.tiff differ
diff --git a/basis/ui/tools/error-list/icons/source-file.tiff b/basis/ui/tools/error-list/icons/source-file.tiff
new file mode 100644
index 0000000000..5fb3375520
Binary files /dev/null and b/basis/ui/tools/error-list/icons/source-file.tiff differ
diff --git a/basis/ui/tools/error-list/icons/syntax-error.tiff b/basis/ui/tools/error-list/icons/syntax-error.tiff
new file mode 100644
index 0000000000..5446c80e15
Binary files /dev/null and b/basis/ui/tools/error-list/icons/syntax-error.tiff differ
diff --git a/basis/ui/tools/error-list/icons/unit-test-error.tiff b/basis/ui/tools/error-list/icons/unit-test-error.tiff
new file mode 100644
index 0000000000..b6ea439f5a
Binary files /dev/null and b/basis/ui/tools/error-list/icons/unit-test-error.tiff differ
diff --git a/basis/ui/tools/inspector/inspector-docs.factor b/basis/ui/tools/inspector/inspector-docs.factor
index c329f037e1..72f4e1fe66 100644
--- a/basis/ui/tools/inspector/inspector-docs.factor
+++ b/basis/ui/tools/inspector/inspector-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax ui.commands ui.gadgets.slots
-ui.gadgets.editors ;
+ui.gadgets.editors kernel ;
IN: ui.tools.inspector
ARTICLE: "ui-inspector-edit" "Editing slot values in the inspector"
@@ -21,4 +21,8 @@ $nl
"The UI inspector is an instance of " { $link inspector-gadget } "."
{ $subsection "ui-inspector-edit" } ;
+HELP: inspector
+{ $values { "obj" object } }
+{ $description "Opens a new inspector window displaying the slots of " { $snippet "obj" } "." } ;
+
ABOUT: "ui-inspector"
\ No newline at end of file
diff --git a/basis/ui/tools/inspector/inspector-tests.factor b/basis/ui/tools/inspector/inspector-tests.factor
index 44e20fb0fd..2971b1e8cb 100644
--- a/basis/ui/tools/inspector/inspector-tests.factor
+++ b/basis/ui/tools/inspector/inspector-tests.factor
@@ -1,6 +1,4 @@
IN: ui.tools.inspector.tests
USING: tools.test ui.tools.inspector math models ;
-\ <inspector-gadget> must-infer
-
[ ] [ \ + <model> <inspector-gadget> com-edit-slot ] unit-test
\ No newline at end of file
diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor
index ba66121bc2..fdba400c3d 100644
--- a/basis/ui/tools/listener/completion/completion.factor
+++ b/basis/ui/tools/listener/completion/completion.factor
@@ -3,11 +3,10 @@
USING: accessors arrays assocs calendar colors colors.constants
documents documents.elements fry kernel words sets splitting math
math.vectors models.delay models.arrow combinators.short-circuit
-parser present sequences tools.completion help.vocabs generic
-generic.standard.engines.tuple fonts definitions.icons ui.images
-ui.commands ui.operations ui.gadgets ui.gadgets.editors
-ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables
-ui.gadgets.tracks ui.gadgets.labeled
+parser present sequences tools.completion help.vocabs generic fonts
+definitions.icons ui.images ui.commands ui.operations ui.gadgets
+ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers
+ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled
ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid
ui.tools.listener.history combinators vocabs ui.tools.listener.popups ;
IN: ui.tools.listener.completion
@@ -40,7 +39,7 @@ M: history-completion completion-quot drop '[ drop _ history-list ] ;
GENERIC: completion-element ( completion-mode -- element )
-M: object completion-element drop one-word-elt ;
+M: object completion-element drop word-start-elt ;
M: history-completion completion-element drop one-line-elt ;
GENERIC: completion-banner ( completion-mode -- string )
@@ -73,13 +72,13 @@ M: vocab-completion row-color
drop vocab? COLOR: black COLOR: dark-gray ? ;
: complete-IN:/USE:? ( tokens -- ? )
- 2 short tail* { "IN:" "USE:" } intersects? ;
+ 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ;
: chop-; ( seq -- seq' )
{ ";" } split1-last [ ] [ ] ?if ;
: complete-USING:? ( tokens -- ? )
- chop-; { "USING:" } intersects? ;
+ chop-; 1 short head* { "USING:" } intersects? ;
: complete-CHAR:? ( tokens -- ? )
2 short tail* "CHAR:" swap member? ;
@@ -120,8 +119,6 @@ M: object completion-string present ;
M: method-body completion-string method-completion-string ;
-M: engine-word completion-string method-completion-string ;
-
GENERIC# accept-completion-hook 1 ( item popup -- )
: insert-completion ( item popup -- )
diff --git a/basis/ui/tools/listener/listener-docs.factor b/basis/ui/tools/listener/listener-docs.factor
index afe890b9c5..998020c9c4 100644
--- a/basis/ui/tools/listener/listener-docs.factor
+++ b/basis/ui/tools/listener/listener-docs.factor
@@ -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
@@ -27,6 +27,8 @@ ARTICLE: "ui-listener" "UI listener"
{ $command-map interactor "quotation" }
{ $heading "Editing commands" }
"The text editing commands are standard; see " { $link "gadgets-editors-commands" } "."
+$nl
+"The listener displays a summary with any outstanding error conditions before every prompt. See " { $link "ui.tools.error-list" } " for details."
{ $heading "Implementation" }
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ;
diff --git a/basis/ui/tools/listener/listener-tests.factor b/basis/ui/tools/listener/listener-tests.factor
index 986e1270eb..e06e17374f 100644
--- a/basis/ui/tools/listener/listener-tests.factor
+++ b/basis/ui/tools/listener/listener-tests.factor
@@ -6,8 +6,6 @@ threads arrays generic threads accessors listener math
calendar concurrency.promises io ui.tools.common ;
IN: ui.tools.listener.tests
-\ <interactor> must-infer
-
[
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
@@ -77,7 +75,7 @@ CONSTANT: text "Hello world.\nThis is a test."
[ ] [
[
"interactor" get register-self
- "interactor" get contents "promise" get fulfill
+ "interactor" get stream-contents "promise" get fulfill
] in-thread
] unit-test
@@ -152,4 +150,4 @@ CONSTANT: text "Hello world.\nThis is a test."
[ ] [ <listener-gadget> "l" set ] unit-test
[ ] [ "l" get com-scroll-up ] unit-test
-[ ] [ "l" get com-scroll-down ] unit-test
\ No newline at end of file
+[ ] [ "l" get com-scroll-down ] unit-test
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 7cb3c70cbc..6ed3577a06 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -1,19 +1,21 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs calendar combinators locals
-colors.constants combinators.short-circuit 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
+source-files.errors colors.constants combinators.short-circuit
+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.tools.listener.history ui.images ui.tools.error-list
+tools.errors.model ;
+FROM: source-files.errors => all-errors ;
IN: ui.tools.listener
! If waiting is t, we're waiting for user input, and invoking
@@ -31,9 +33,10 @@ output history flag mailbox thread waiting token-model word-model popup ;
: interactor-busy? ( interactor -- ? )
#! We're busy if there's no thread to resume.
- [ waiting>> ]
- [ thread>> dup [ thread-registered? ] when ]
- bi and not ;
+ {
+ [ waiting>> ]
+ [ thread>> dup [ thread-registered? ] when ]
+ } 1&& not ;
SLOT: vocabs
@@ -170,7 +173,7 @@ M: interactor dispose drop ;
over set-caret
mark>caret ;
-TUPLE: listener-gadget < tool input output scroller ;
+TUPLE: listener-gadget < tool error-summary output scroller input ;
{ 600 700 } listener-gadget set-tool-dim
@@ -180,17 +183,35 @@ TUPLE: listener-gadget < tool input output scroller ;
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
-: init-listener ( listener -- listener )
+: init-input/output ( listener -- listener )
<interactor>
[ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
dup listener-streams >>output drop ;
-: <listener-gadget> ( -- gadget )
+: error-summary. ( -- )
+ error-counts keys [
+ H{ { table-gap { 3 3 } } } [
+ [ [ [ icon>> write-image ] with-cell ] each ] with-row
+ ] tabular-output
+ { "Press " { $command tool "common" show-error-list } " to view errors." }
+ print-element
+ ] unless-empty ;
+
+: <error-summary> ( -- gadget )
+ error-list-model get [ drop error-summary. ] <pane-control>
+ COLOR: light-yellow <solid> >>interior ;
+
+: init-error-summary ( listener -- listener )
+ <error-summary> >>error-summary
+ dup error-summary>> f track-add ;
+
+: <listener-gadget> ( -- listener )
vertical listener-gadget new-track
add-toolbar
- init-listener
+ init-input/output
dup output>> <scroller> >>scroller
- dup scroller>> 1 track-add ;
+ dup scroller>> 1 track-add
+ init-error-summary ;
M: listener-gadget focusable-child*
input>> dup popup>> or ;
@@ -360,6 +381,7 @@ interactor "completion" f {
dup listener-streams [
[ com-browse ] help-hook set
'[ [ _ input>> ] 2dip debugger-popup ] error-hook set
+ error-summary? off
tip-of-the-day. nl
listener
] with-streams* ;
diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor
index c6371ac8aa..650d751ee2 100644
--- a/basis/ui/tools/operations/operations.factor
+++ b/basis/ui/tools/operations/operations.factor
@@ -1,15 +1,15 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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.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 ui.gestures ui.operations
-ui.tools.deploy models help.tips ;
+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 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
+ui.gestures ui.operations ui.tools.deploy models help.tips
+source-files.errors ;
IN: ui.tools.operations
! Objects
@@ -86,6 +86,21 @@ IN: ui.tools.operations
{ +listener+ t }
} define-operation
+! Source file error
+[ source-file-error? ] \ edit-error H{
+ { +primary+ t }
+ { +secondary+ t }
+ { +listener+ t }
+} define-operation
+
+: com-reload ( error -- )
+ file>> run-file ;
+
+[ compiler-error? ] \ com-reload H{
+ { +listener+ t }
+} define-operation
+
+! Definitions
: com-forget ( defspec -- )
[ forget ] with-compilation-unit ;
@@ -173,4 +188,4 @@ interactor
"These commands operate on the entire contents of the input area."
[ ]
[ quot-action ]
-define-operation-map
+define-operation-map
\ No newline at end of file
diff --git a/basis/ui/tools/profiler/profiler-docs.factor b/basis/ui/tools/profiler/profiler-docs.factor
index e2a0ef5f4e..fad2b3614f 100644
--- a/basis/ui/tools/profiler/profiler-docs.factor
+++ b/basis/ui/tools/profiler/profiler-docs.factor
@@ -1,10 +1,14 @@
IN: ui.tools.profiler
-USING: help.markup help.syntax ui.operations help.tips ;
+USING: help.markup help.syntax ui.operations ui.commands help.tips ;
-ARTICLE: "ui.tools.profiler" "UI profiler tool"
+ARTICLE: "ui.tools.profiler" "UI profiler tool"
"The " { $vocab-link "ui.tools.profiler" } " vocabulary implements a graphical tool for viewing profiling results (see " { $link "profiling" } ")."
$nl
-"To use the profiler, enter a piece of code in the listener's input area and press " { $operation com-profile } "." ;
+"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
+$nl
+"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring."
+$nl
+"Consult " { $link "profiling" } " for details about the profiler itself." ;
TIP: "Press " { $operation com-profile } " to run the code in the input field with profiling enabled (" { $link "ui.tools.profiler" } ")." ;
diff --git a/basis/ui/tools/profiler/profiler-tests.factor b/basis/ui/tools/profiler/profiler-tests.factor
new file mode 100644
index 0000000000..c1c8fdbff9
--- /dev/null
+++ b/basis/ui/tools/profiler/profiler-tests.factor
@@ -0,0 +1,3 @@
+USING: ui.tools.profiler tools.test ;
+
+
diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor
index 1c2318a35e..5fef64ea88 100644
--- a/basis/ui/tools/profiler/profiler.factor
+++ b/basis/ui/tools/profiler/profiler.factor
@@ -11,6 +11,7 @@ ui.gadgets.tabbed ui.gadgets.status-bar ui.gadgets.borders
ui.tools.browser ui.tools.common ui.baseline-alignment
ui.operations ui.images ;
FROM: models.arrow => <arrow> ;
+FROM: models.arrow.smart => <smart-arrow> ;
FROM: models.product => <product> ;
IN: ui.tools.profiler
@@ -112,8 +113,8 @@ M: method-renderer column-titles drop { "" "Method" "Count" } ;
: <methods-model> ( profiler -- model )
[
[ method-counters <model> ] dip
- [ generic>> ] [ class>> ] bi 3array <product>
- [ first3 '[ _ _ method-matches? ] filter ] <arrow>
+ [ generic>> ] [ class>> ] bi
+ [ '[ _ _ method-matches? ] filter ] <smart-arrow>
] keep <profiler-model> ;
: sort-by-name ( obj1 obj2 -- <=> )
@@ -208,6 +209,6 @@ profiler-gadget "toolbar" f {
: profiler-window ( -- )
<profiler-gadget> "Profiling results" open-status-window ;
-: com-profile ( quot -- ) profile profiler-window ;
+: com-profile ( quot -- ) profile profiler-window ; inline
MAIN: profiler-window
diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor
index 93f45591a5..7be008f296 100644
--- a/basis/ui/tools/tools-docs.factor
+++ b/basis/ui/tools/tools-docs.factor
@@ -31,17 +31,6 @@ $nl
$nl
"For more about presentation gadgets, see " { $link "ui.gadgets.presentations" } "." ;
-ARTICLE: "ui-profiler" "UI profiler"
-"The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
-$nl
-"To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
-$nl
-"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring."
-$nl
-"Consult " { $link "profiling" } " for details about the profiler itself."
-{ $command-map profiler-gadget "toolbar" }
-"The profiler is an instance of " { $link profiler-gadget } "." ;
-
ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X"
"On Mac OS X, the Factor UI offers additional features which integrate with this operating system."
$nl
@@ -55,7 +44,7 @@ $nl
ARTICLE: "ui-tools" "UI developer tools"
"The " { $vocab-link "ui.tools" } " vocabulary hierarchy implements a collection of simple developer tools."
-$nl
+{ $subsection "starting-ui-tools" }
"To take full advantage of the UI tools, you should be using a supported text editor. See " { $link "editor" } "."
$nl
"Common functionality:"
@@ -66,7 +55,8 @@ $nl
{ $subsection "ui-listener" }
{ $subsection "ui-browser" }
{ $subsection "ui-inspector" }
-{ $subsection "ui-profiler" }
+{ $subsection "ui.tools.error-list" }
+{ $subsection "ui.tools.profiler" }
{ $subsection "ui-walker" }
{ $subsection "ui.tools.deploy" }
"Platform-specific features:"
diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor
index 203953db1a..7ea34e651f 100644
--- a/basis/ui/tools/tools.factor
+++ b/basis/ui/tools/tools.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: memory system kernel tools.vocabs ui.tools.operations
-ui.tools.listener ui.tools.browser ui.tools.common
+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
@@ -30,4 +30,5 @@ tool "common" f {
{ T{ key-down f { A+ } "w" } close-window }
{ T{ key-down f { A+ } "q" } com-exit }
{ T{ key-down f f "F2" } refresh-all }
+ { T{ key-down f f "F3" } show-error-list }
} define-command-map
\ No newline at end of file
diff --git a/basis/ui/tools/walker/walker-docs.factor b/basis/ui/tools/walker/walker-docs.factor
index 011e3b4866..9e73a31282 100644
--- a/basis/ui/tools/walker/walker-docs.factor
+++ b/basis/ui/tools/walker/walker-docs.factor
@@ -1,6 +1,6 @@
IN: ui.tools.walker
USING: help.markup help.syntax ui.commands ui.operations
-ui.render tools.walker sequences ;
+ui.render tools.walker sequences tools.continuations ;
ARTICLE: "ui-walker-step" "Stepping through code"
"If the current position points to a word, the various stepping commands behave as follows:"
diff --git a/basis/ui/tools/walker/walker-tests.factor b/basis/ui/tools/walker/walker-tests.factor
index fefb188239..fe0b57b980 100644
--- a/basis/ui/tools/walker/walker-tests.factor
+++ b/basis/ui/tools/walker/walker-tests.factor
@@ -1,4 +1,3 @@
USING: ui.tools.walker tools.test ;
IN: ui.tools.walker.tests
-\ <walker-gadget> must-infer
diff --git a/basis/ui/traverse/traverse-docs.factor b/basis/ui/traverse/traverse-docs.factor
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/basis/ui/traverse/traverse-tests.factor b/basis/ui/traverse/traverse-tests.factor
index e18637a652..4d2072db1c 100644
--- a/basis/ui/traverse/traverse-tests.factor
+++ b/basis/ui/traverse/traverse-tests.factor
@@ -62,4 +62,4 @@ M: object (flatten-tree) , ;
{ 0 1 } { 2 0 1 } { { "a" "b" "c" "d" } { "e" "f" "g" } { { "h" "i" } "j" } } gadgets-in-range
] unit-test
-[ { array children>> } forget ] with-compilation-unit
+[ M\ array children>> forget ] with-compilation-unit
diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor
index f2b6154745..397fc419fa 100644
--- a/basis/ui/ui-docs.factor
+++ b/basis/ui/ui-docs.factor
@@ -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 } }
diff --git a/basis/ui/ui-tests.factor b/basis/ui/ui-tests.factor
index 4b4bf9d9ee..06de4eb9c2 100644
--- a/basis/ui/ui-tests.factor
+++ b/basis/ui/ui-tests.factor
@@ -1,5 +1,2 @@
IN: ui.tests
USING: ui ui.private tools.test ;
-
-\ open-window must-infer
-\ update-ui must-infer
\ No newline at end of file
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index bf17e455f8..d07403836a 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make dlists
deques sequences threads sequences words continuations init
-combinators 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 ;
+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
+strings ;
IN: ui
<PRIVATE
@@ -28,7 +29,7 @@ SYMBOL: windows
[ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
- windows global [ [ first = not ] with filter ] change-at ;
+ windows [ [ first = not ] with filter ] change-global ;
: raised-window ( world -- )
windows get-global
@@ -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*
@@ -117,12 +131,10 @@ M: world ungraft*
gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
: update-ui ( -- )
- [
- notify-queued
- layout-queued
- redraw-worlds
- send-queued-gestures
- ] [ ui-error ] recover ;
+ notify-queued
+ layout-queued
+ redraw-worlds
+ send-queued-gestures ;
SYMBOL: ui-thread
@@ -133,8 +145,7 @@ SYMBOL: ui-thread
PRIVATE>
: find-window ( quot -- world )
- windows get values
- [ gadget-child swap call ] with find-last nip ; inline
+ [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
@@ -142,9 +153,15 @@ PRIVATE>
<PRIVATE
: update-ui-loop ( -- )
- [ ui-running? ui-thread get-global self eq? and ]
- [ ui-notify-flag get lower-flag update-ui ]
- while ;
+ #! Note the logic: if update-ui fails, we open an error window
+ #! and run one iteration of update-ui. If that also fails, well,
+ #! the whole UI subsystem is broken so we exit out of the
+ #! update-ui-loop.
+ [ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
+ [
+ ui-notify-flag get lower-flag
+ [ update-ui ] [ ui-error update-ui ] recover
+ ] while ;
: start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ]
@@ -163,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* ;
@@ -193,4 +214,4 @@ M: object close-window
: with-ui ( quot -- )
ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
-HOOK: beep ui-backend ( -- )
\ No newline at end of file
+HOOK: beep ui-backend ( -- )
diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor
index 3a26b01213..6d6d4233f5 100644
--- a/basis/unicode/breaks/breaks-tests.factor
+++ b/basis/unicode/breaks/breaks-tests.factor
@@ -32,7 +32,7 @@ IN: unicode.breaks.tests
[ concat [ quot call [ "" like ] map ] curry ] bi unit-test
] each ;
-: grapheme-test ( tests quot -- )
+: grapheme-test ( tests -- )
[
[ 1quotation ]
[ concat [ >graphemes [ "" like ] map ] curry ] bi unit-test
diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor
index a76f5e78c4..9344d1102e 100644
--- a/basis/unicode/case/case-tests.factor
+++ b/basis/unicode/case/case-tests.factor
@@ -4,10 +4,6 @@ USING: unicode.case tools.test namespaces strings unicode.normalize
unicode.case.private ;
IN: unicode.case.tests
-\ >upper must-infer
-\ >lower must-infer
-\ >title must-infer
-
[ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test
[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test
[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test
diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor
index f53a1382ae..fdeb721e65 100644
--- a/basis/unicode/collation/collation-tests.factor
+++ b/basis/unicode/collation/collation-tests.factor
@@ -11,9 +11,10 @@ IN: unicode.collation.tests
: test-two ( str1 str2 -- )
[ +lt+ ] -rot [ string<=> ] 2curry unit-test ;
-: test-equality ( str1 str2 -- )
+: test-equality ( str1 str2 -- ? ? ? ? )
{ primary= secondary= tertiary= quaternary= }
- [ execute ] with with each ;
+ [ execute( a b -- ? ) ] with with map
+ first4 ;
[ f f f f ] [ "hello" "hi" test-equality ] unit-test
[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test
diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor
index f774016272..cea880c0b0 100644
--- a/basis/unicode/normalize/normalize-tests.factor
+++ b/basis/unicode/normalize/normalize-tests.factor
@@ -3,8 +3,6 @@ simple-flat-file io.encodings.utf8 io.files splitting math.parser
locals math quotations assocs combinators unicode.normalize.private ;
IN: unicode.normalize.tests
-{ nfc nfkc nfd nfkd } [ must-infer ] each
-
[ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test
[ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test
diff --git a/basis/unicode/unicode-docs.factor b/basis/unicode/unicode-docs.factor
index 9450b49f0b..56432585c0 100644
--- a/basis/unicode/unicode-docs.factor
+++ b/basis/unicode/unicode-docs.factor
@@ -1,7 +1,7 @@
USING: help.markup help.syntax strings ;
IN: unicode
-ARTICLE: "unicode" "Unicode"
+ARTICLE: "unicode" "Unicode support"
"The " { $vocab-link "unicode" } " vocabulary and its sub-vocabularies implement support for the Unicode 5.1 character set."
$nl
"The Unicode character set contains most of the world's writing systems. Unicode is intended as a replacement for, and is a superset of, such legacy character sets as ASCII, Latin1, MacRoman, and so on. Unicode characters are called " { $emphasis "code points" } "; Factor's " { $link "strings" } " are sequences of code points."
diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor
index 2e989b32c0..eae2020077 100644
--- a/basis/unix/groups/groups-tests.factor
+++ b/basis/unix/groups/groups-tests.factor
@@ -5,8 +5,6 @@ IN: unix.groups.tests
[ ] [ all-groups drop ] unit-test
-\ all-groups must-infer
-
[ t ] [ real-group-name string? ] unit-test
[ t ] [ effective-group-name string? ] unit-test
diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor
index a6a0147504..10fb2ad64f 100644
--- a/basis/unix/unix.factor
+++ b/basis/unix/unix.factor
@@ -194,6 +194,7 @@ FUNCTION: int setsockopt ( int s, int level, int optname, void* optval, socklen_
FUNCTION: int setuid ( uid_t uid ) ;
FUNCTION: int socket ( int domain, int type, int protocol ) ;
FUNCTION: int symlink ( char* path1, char* path2 ) ;
+FUNCTION: int link ( char* path1, char* path2 ) ;
FUNCTION: int system ( char* command ) ;
FUNCTION: int unlink ( char* path ) ;
diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor
index f2a4b7bc27..cf3747b346 100644
--- a/basis/unix/users/users-tests.factor
+++ b/basis/unix/users/users-tests.factor
@@ -3,11 +3,8 @@
USING: tools.test unix.users kernel strings math ;
IN: unix.users.tests
-
[ ] [ all-users drop ] unit-test
-\ all-users must-infer
-
[ t ] [ real-user-name string? ] unit-test
[ t ] [ effective-user-name string? ] unit-test
diff --git a/basis/urls/encoding/encoding-docs.factor b/basis/urls/encoding/encoding-docs.factor
index f8b435441f..82ab3d1f69 100644
--- a/basis/urls/encoding/encoding-docs.factor
+++ b/basis/urls/encoding/encoding-docs.factor
@@ -7,7 +7,11 @@ HELP: url-decode
HELP: url-encode
{ $values { "str" string } { "encoded" string } }
-{ $description "URL-encodes a string." } ;
+{ $description "URL-encodes a string, excluding certain characters, such as \"/\"." } ;
+
+HELP: url-encode-full
+{ $values { "str" string } { "encoded" string } }
+{ $description "URL-encodes a string, including all reserved characters, such as \"/\"." } ;
HELP: url-quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
diff --git a/basis/urls/encoding/encoding-tests.factor b/basis/urls/encoding/encoding-tests.factor
index 87b1812ef8..78e31a764d 100644
--- a/basis/urls/encoding/encoding-tests.factor
+++ b/basis/urls/encoding/encoding-tests.factor
@@ -26,3 +26,7 @@ USING: urls.encoding tools.test arrays kernel assocs present accessors ;
[ H{ { "text" "hello world" } } ] [ "text=hello+world" query>assoc ] unit-test
[ "a=3" ] [ { { "a" 3 } } assoc>query ] unit-test
+
+[ "a" ] [ { { "a" f } } assoc>query ] unit-test
+
+[ H{ { "a" f } } ] [ "a" query>assoc ] unit-test
\ No newline at end of file
diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor
index 7fed4b5f58..a5f5d62bfc 100644
--- a/basis/urls/encoding/encoding.factor
+++ b/basis/urls/encoding/encoding.factor
@@ -14,6 +14,25 @@ IN: urls.encoding
[ "/_-.:" member? ]
} 1|| ; foldable
+! see http://tools.ietf.org/html/rfc3986#section-2.2
+: gen-delim? ( ch -- ? )
+ ":/?#[]@" member? ; foldable
+
+: sub-delim? ( ch -- ? )
+ "!$&'()*+,;=" member? ; foldable
+
+: reserved? ( ch -- ? )
+ [ gen-delim? ] [ sub-delim? ] bi or ; foldable
+
+! see http://tools.ietf.org/html/rfc3986#section-2.3
+: unreserved? ( ch -- ? )
+ {
+ [ letter? ]
+ [ LETTER? ]
+ [ digit? ]
+ [ "-._~" member? ]
+ } 1|| ; foldable
+
<PRIVATE
: push-utf8 ( ch -- )
@@ -27,6 +46,11 @@ PRIVATE>
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
+: url-encode-full ( str -- encoded )
+ [
+ [ dup unreserved? [ , ] [ push-utf8 ] if ] each
+ ] "" make ;
+
<PRIVATE
: url-decode-hex ( index str -- )
@@ -72,6 +96,15 @@ PRIVATE>
] when*
] 2keep set-at ;
+: assoc-strings ( assoc -- assoc' )
+ [
+ {
+ { [ dup not ] [ ] }
+ { [ dup array? ] [ [ present ] map ] }
+ [ present 1array ]
+ } cond
+ ] assoc-map ;
+
PRIVATE>
: query>assoc ( query -- assoc )
@@ -86,11 +119,8 @@ PRIVATE>
: assoc>query ( assoc -- str )
[
- dup array? [ [ present ] map ] [ present 1array ] if
- ] assoc-map
- [
- [
+ assoc-strings [
[ url-encode ] dip
- [ url-encode "=" glue , ] with each
+ [ [ url-encode "=" glue , ] with each ] [ , ] if*
] assoc-each
] { } make "&" join ;
diff --git a/basis/urls/prettyprint/prettyprint.factor b/basis/urls/prettyprint/prettyprint.factor
index 59fb79e8d3..35e428c8fa 100644
--- a/basis/urls/prettyprint/prettyprint.factor
+++ b/basis/urls/prettyprint/prettyprint.factor
@@ -1,6 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel present prettyprint.custom prettyprint.backend urls ;
+USING: kernel present prettyprint.custom prettyprint.sections
+prettyprint.backend urls ;
IN: urls.prettyprint
-M: url pprint* dup present "URL\" " "\"" pprint-string ;
+M: url pprint*
+ \ URL" record-vocab
+ dup present "URL\" " "\"" pprint-string ;
diff --git a/basis/urls/urls-tests.factor b/basis/urls/urls-tests.factor
index 74eea9506c..f2ecd6ec69 100644
--- a/basis/urls/urls-tests.factor
+++ b/basis/urls/urls-tests.factor
@@ -1,5 +1,5 @@
IN: urls.tests
-USING: urls urls.private tools.test
+USING: urls urls.private tools.test prettyprint
arrays kernel assocs present accessors ;
CONSTANT: urls
@@ -80,6 +80,15 @@ CONSTANT: urls
}
"ftp://slava:secret@ftp.kernel.org/"
}
+ {
+ T{ url
+ { protocol "http" }
+ { host "foo.com" }
+ { path "/" }
+ { query H{ { "a" f } } }
+ }
+ "http://foo.com/?a"
+ }
}
urls [
@@ -227,3 +236,5 @@ urls [
[ "http://localhost/?foo=bar" >url ] unit-test
[ "/" ] [ "http://www.jedit.org" >url path>> ] unit-test
+
+[ "USING: urls ;\nURL\" foo\"" ] [ URL" foo" unparse-use ] unit-test
\ No newline at end of file
diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor
index df38869fbf..7c96f19ac9 100644
--- a/basis/values/values-docs.factor
+++ b/basis/values/values-docs.factor
@@ -2,7 +2,7 @@ USING: help.markup help.syntax ;
IN: values
ARTICLE: "values" "Global values"
-"Usually, dynamically scoped variables are sufficient for holding data which is not literal. But occasionally, for global information that's calculated just once, it's useful to use the word mechanism instead, and set the word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:"
+"Usually, dynamically-scoped variables subsume global variables and are sufficient for holding global data. But occasionally, for global information that's calculated just once and must be accessed more rapidly than a dynamic variable lookup can provide, it's useful to use the word mechanism instead, and set a word to the appropriate value just once. The " { $vocab-link "values" } " vocabulary implements " { $emphasis "values" } ", which abstract over this concept. To create a new word as a value, use the following syntax:"
{ $subsection POSTPONE: VALUE: }
"To get the value, just call the word. The following words manipulate values:"
{ $subsection get-value }
diff --git a/basis/vocabs/cache/authors.txt b/basis/vocabs/cache/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/vocabs/cache/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/vocabs/cache/cache.factor b/basis/vocabs/cache/cache.factor
new file mode 100644
index 0000000000..63a8d6d292
--- /dev/null
+++ b/basis/vocabs/cache/cache.factor
@@ -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
\ No newline at end of file
diff --git a/basis/vocabs/cache/summary.txt b/basis/vocabs/cache/summary.txt
new file mode 100644
index 0000000000..92ab1fe8eb
--- /dev/null
+++ b/basis/vocabs/cache/summary.txt
@@ -0,0 +1 @@
+Caching vocabulary data from disk
diff --git a/basis/vocabs/errors/authors.txt b/basis/vocabs/errors/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/vocabs/errors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/vocabs/errors/errors.factor b/basis/vocabs/errors/errors.factor
new file mode 100644
index 0000000000..8f88eb3816
--- /dev/null
+++ b/basis/vocabs/errors/errors.factor
@@ -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 ;
\ No newline at end of file
diff --git a/basis/vocabs/errors/summary.txt b/basis/vocabs/errors/summary.txt
new file mode 100644
index 0000000000..b7e7040366
--- /dev/null
+++ b/basis/vocabs/errors/summary.txt
@@ -0,0 +1 @@
+Loading vocabularies and batching errors
diff --git a/basis/vocabs/files/authors.txt b/basis/vocabs/files/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/vocabs/files/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/vocabs/files/files-docs.factor b/basis/vocabs/files/files-docs.factor
new file mode 100644
index 0000000000..e2c6a5f373
--- /dev/null
+++ b/basis/vocabs/files/files-docs.factor
@@ -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." } ;
+
diff --git a/basis/vocabs/files/files-tests.factor b/basis/vocabs/files/files-tests.factor
new file mode 100644
index 0000000000..d53b8c52af
--- /dev/null
+++ b/basis/vocabs/files/files-tests.factor
@@ -0,0 +1,9 @@
+IN: vocabs.files.tests
+USING: tools.test vocabs.files vocabs arrays sets ;
+
+[ t ] [
+ "kernel" vocab-files
+ "kernel" vocab vocab-files
+ "kernel" <vocab-link> vocab-files
+ 3array all-equal?
+] unit-test
\ No newline at end of file
diff --git a/basis/vocabs/files/files.factor b/basis/vocabs/files/files.factor
new file mode 100644
index 0000000000..c1d7dcfd59
--- /dev/null
+++ b/basis/vocabs/files/files.factor
@@ -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 ;
\ No newline at end of file
diff --git a/basis/vocabs/files/summary.txt b/basis/vocabs/files/summary.txt
new file mode 100644
index 0000000000..b1633e3782
--- /dev/null
+++ b/basis/vocabs/files/summary.txt
@@ -0,0 +1 @@
+Getting a list of files in a vocabulary
diff --git a/basis/vocabs/hierarchy/hierarchy-docs.factor b/basis/vocabs/hierarchy/hierarchy-docs.factor
new file mode 100644
index 0000000000..c5d8554635
--- /dev/null
+++ b/basis/vocabs/hierarchy/hierarchy-docs.factor
@@ -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 } }
+{ $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." } ;
diff --git a/basis/vocabs/hierarchy/hierarchy-tests.factor b/basis/vocabs/hierarchy/hierarchy-tests.factor
new file mode 100644
index 0000000000..97fa59a342
--- /dev/null
+++ b/basis/vocabs/hierarchy/hierarchy-tests.factor
@@ -0,0 +1,2 @@
+IN: vocabs.hierarchy.tests
+USING: continuations namespaces tools.test vocabs.hierarchy vocabs.hierarchy.private ;
diff --git a/basis/vocabs/hierarchy/hierarchy.factor b/basis/vocabs/hierarchy/hierarchy.factor
new file mode 100644
index 0000000000..046ccb8c2d
--- /dev/null
+++ b/basis/vocabs/hierarchy/hierarchy.factor
@@ -0,0 +1,99 @@
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs combinators.short-circuit fry
+io.directories io.files io.files.info io.pathnames kernel make
+memoize namespaces sequences sorting splitting vocabs sets
+vocabs.loader vocabs.metadata vocabs.errors ;
+IN: vocabs.hierarchy
+
+<PRIVATE
+
+: vocab-subdirs ( dir -- dirs )
+ [
+ [
+ { [ link-info directory? ] [ "." head? not ] } 1&&
+ ] filter
+ ] with-directory-files natural-sort ;
+
+: (all-child-vocabs) ( root name -- vocabs )
+ [
+ vocab-dir append-path dup exists?
+ [ vocab-subdirs ] [ drop { } ] if
+ ] keep
+ [ '[ [ _ "." ] dip 3append ] 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 ;
+
+PRIVATE>
+
+: all-vocabs ( -- assoc )
+ vocab-roots get [
+ dup [ "" vocabs-in-dir ] { } make
+ ] { } map>assoc ;
+
+: all-vocabs-under ( prefix -- vocabs )
+ [
+ [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each
+ ] { } make ;
+
+MEMO: all-vocabs-seq ( -- seq )
+ "" all-vocabs-under ;
+
+<PRIVATE
+
+: 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 ;
+
+PRIVATE>
+
+: 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 '[
+ dup _ (all-child-vocabs)
+ [ vocab-dir? ] with filter
+ ] map concat ;
+
+<PRIVATE
+
+: filter-unportable ( seq -- seq' )
+ [ vocab-name unportable? not ] filter ;
+
+PRIVATE>
+
+: (load) ( prefix -- failures )
+ all-vocabs-under
+ filter-unportable
+ require-all ;
+
+: load ( prefix -- )
+ (load) load-failures. ;
+
+: load-all ( -- )
+ "" load ;
+
+MEMO: all-tags ( -- seq )
+ all-vocabs-seq [ vocab-tags ] gather natural-sort ;
+
+MEMO: all-authors ( -- seq )
+ all-vocabs-seq [ vocab-authors ] gather natural-sort ;
\ No newline at end of file
diff --git a/basis/vocabs/hierarchy/summary.txt b/basis/vocabs/hierarchy/summary.txt
new file mode 100644
index 0000000000..b8d931570e
--- /dev/null
+++ b/basis/vocabs/hierarchy/summary.txt
@@ -0,0 +1 @@
+Searching for vocabularies on disk
diff --git a/basis/vocabs/metadata/authors.txt b/basis/vocabs/metadata/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/vocabs/metadata/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/vocabs/metadata/metadata-docs.factor b/basis/vocabs/metadata/metadata-docs.factor
new file mode 100644
index 0000000000..002f8534b4
--- /dev/null
+++ b/basis/vocabs/metadata/metadata-docs.factor
@@ -0,0 +1,44 @@
+USING: help.markup help.syntax strings ;
+IN: vocabs.metadata
+
+ARTICLE: "vocabs.metadata" "Vocabulary metadata"
+"Vocabulary summaries:"
+{ $subsection vocab-summary }
+{ $subsection set-vocab-summary }
+"Vocabulary authors:"
+{ $subsection vocab-authors }
+{ $subsection set-vocab-authors }
+"Vocabulary tags:"
+{ $subsection vocab-tags }
+{ $subsection set-vocab-tags }
+{ $subsection add-vocab-tags }
+"Getting and setting arbitrary vocabulary metadata:"
+{ $subsection vocab-file-contents }
+{ $subsection set-vocab-file-contents } ;
+
+ABOUT: "vocabs.metadata"
+
+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." } ;
+
diff --git a/basis/vocabs/metadata/metadata.factor b/basis/vocabs/metadata/metadata.factor
new file mode 100644
index 0000000000..85a503c7f0
--- /dev/null
+++ b/basis/vocabs/metadata/metadata.factor
@@ -0,0 +1,70 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs io.encodings.utf8 io.files
+io.pathnames kernel make math.parser memoize sequences sets
+sorting summary vocabs vocabs.loader ;
+IN: vocabs.metadata
+
+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 ;
+
+: unportable? ( vocab -- ? )
+ vocab-tags "unportable" swap member? ;
\ No newline at end of file
diff --git a/basis/vocabs/metadata/summary.txt b/basis/vocabs/metadata/summary.txt
new file mode 100644
index 0000000000..eec7fd52e9
--- /dev/null
+++ b/basis/vocabs/metadata/summary.txt
@@ -0,0 +1 @@
+Managing vocabulary author, tag and summary information
diff --git a/basis/vocabs/refresh/authors.txt b/basis/vocabs/refresh/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/vocabs/refresh/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/benchmark/typecheck4/authors.txt b/basis/vocabs/refresh/monitor/authors.txt
old mode 100755
new mode 100644
similarity index 100%
rename from extra/benchmark/typecheck4/authors.txt
rename to basis/vocabs/refresh/monitor/authors.txt
diff --git a/basis/tools/vocabs/monitor/monitor-tests.factor b/basis/vocabs/refresh/monitor/monitor-tests.factor
similarity index 67%
rename from basis/tools/vocabs/monitor/monitor-tests.factor
rename to basis/vocabs/refresh/monitor/monitor-tests.factor
index 0e767a3d34..86091189a5 100644
--- a/basis/tools/vocabs/monitor/monitor-tests.factor
+++ b/basis/vocabs/refresh/monitor/monitor-tests.factor
@@ -1,5 +1,5 @@
-USING: tools.test tools.vocabs.monitor io.pathnames ;
-IN: tools.vocabs.monitor.tests
+USING: tools.test vocabs.refresh.monitor io.pathnames ;
+IN: vocabs.refresh.monitor.tests
[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test
[ "kernel" ] [ "core/kernel/" path>vocab ] unit-test
diff --git a/basis/tools/vocabs/monitor/monitor.factor b/basis/vocabs/refresh/monitor/monitor.factor
similarity index 80%
rename from basis/tools/vocabs/monitor/monitor.factor
rename to basis/vocabs/refresh/monitor/monitor.factor
index 1914da78b2..1445b9f882 100644
--- a/basis/tools/vocabs/monitor/monitor.factor
+++ b/basis/vocabs/refresh/monitor/monitor.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: threads io.files io.pathnames io.monitors init kernel
-vocabs vocabs.loader tools.vocabs namespaces continuations
-sequences splitting assocs command-line concurrency.messaging
-io.backend sets tr accessors ;
-IN: tools.vocabs.monitor
+USING: accessors assocs command-line concurrency.messaging
+continuations init io.backend io.files io.monitors io.pathnames
+kernel namespaces sequences sets splitting threads
+tr vocabs vocabs.loader vocabs.refresh vocabs.cache ;
+IN: vocabs.refresh.monitor
TR: convert-separators "/\\" ".." ;
@@ -56,4 +56,4 @@ TR: convert-separators "/\\" ".." ;
[
"-no-monitors" (command-line) member?
[ start-monitor-thread ] unless
-] "tools.vocabs.monitor" add-init-hook
+] "vocabs.refresh.monitor" add-init-hook
diff --git a/basis/tools/vocabs/monitor/summary.txt b/basis/vocabs/refresh/monitor/summary.txt
similarity index 100%
rename from basis/tools/vocabs/monitor/summary.txt
rename to basis/vocabs/refresh/monitor/summary.txt
diff --git a/basis/vocabs/refresh/refresh-docs.factor b/basis/vocabs/refresh/refresh-docs.factor
new file mode 100644
index 0000000000..5652d2ac6a
--- /dev/null
+++ b/basis/vocabs/refresh/refresh-docs.factor
@@ -0,0 +1,22 @@
+USING: help.markup help.syntax strings ;
+IN: vocabs.refresh
+
+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
+
+ARTICLE: "vocabs.refresh" "Runtime code reloading"
+"Reloading source files changed on disk:"
+{ $subsection refresh }
+{ $subsection refresh-all } ;
+
+ABOUT: "vocabs.refresh"
diff --git a/basis/tools/vocabs/vocabs-tests.factor b/basis/vocabs/refresh/refresh-tests.factor
similarity index 71%
rename from basis/tools/vocabs/vocabs-tests.factor
rename to basis/vocabs/refresh/refresh-tests.factor
index 04e628d080..fa9a66ae8e 100644
--- a/basis/tools/vocabs/vocabs-tests.factor
+++ b/basis/vocabs/refresh/refresh-tests.factor
@@ -1,5 +1,5 @@
-IN: tools.vocabs.tests
-USING: tools.test tools.vocabs namespaces continuations ;
+IN: vocabs.refresh.tests
+USING: vocabs.refresh tools.test namespaces ;
[ ] [
changed-vocabs get-global
diff --git a/basis/vocabs/refresh/refresh.factor b/basis/vocabs/refresh/refresh.factor
new file mode 100644
index 0000000000..9ec89e3102
--- /dev/null
+++ b/basis/vocabs/refresh/refresh.factor
@@ -0,0 +1,91 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs checksums checksums.crc32
+io.encodings.utf8 io.files kernel namespaces sequences sets
+source-files vocabs vocabs.errors vocabs.loader ;
+IN: vocabs.refresh
+
+: 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 ;
\ No newline at end of file
diff --git a/basis/vocabs/refresh/summary.txt b/basis/vocabs/refresh/summary.txt
new file mode 100644
index 0000000000..4f75199aa5
--- /dev/null
+++ b/basis/vocabs/refresh/summary.txt
@@ -0,0 +1 @@
+Reloading changed vocabularies from disk
diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor
index f76e389dce..fd037cb2a0 100644
--- a/basis/windows/advapi32/advapi32.factor
+++ b/basis/windows/advapi32/advapi32.factor
@@ -1,5 +1,6 @@
USING: alien.syntax kernel math windows.types math.bitwise ;
IN: windows.advapi32
+
LIBRARY: advapi32
CONSTANT: PROV_RSA_FULL 1
@@ -122,6 +123,34 @@ C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
+C-STRUCT: SECURITY_DESCRIPTOR
+ { "UCHAR" "Revision" }
+ { "UCHAR" "Sbz1" }
+ { "WORD" "Control" }
+ { "PVOID" "Owner" }
+ { "PVOID" "Group" }
+ { "PACL" "Sacl" }
+ { "PACL" "Dacl" } ;
+
+TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR
+
+CONSTANT: SE_OWNER_DEFAULTED 1
+CONSTANT: SE_GROUP_DEFAULTED 2
+CONSTANT: SE_DACL_PRESENT 4
+CONSTANT: SE_DACL_DEFAULTED 8
+CONSTANT: SE_SACL_PRESENT 16
+CONSTANT: SE_SACL_DEFAULTED 32
+CONSTANT: SE_DACL_AUTO_INHERIT_REQ 256
+CONSTANT: SE_SACL_AUTO_INHERIT_REQ 512
+CONSTANT: SE_DACL_AUTO_INHERITED 1024
+CONSTANT: SE_SACL_AUTO_INHERITED 2048
+CONSTANT: SE_DACL_PROTECTED 4096
+CONSTANT: SE_SACL_PROTECTED 8192
+CONSTANT: SE_SELF_RELATIVE 32768
+
+TYPEDEF: DWORD SECURITY_DESCRIPTOR_CONTROL
+TYPEDEF: SECURITY_DESCRIPTOR_CONTROL* PSECURITY_DESCRIPTOR_CONTROL
+
! typedef enum _TOKEN_INFORMATION_CLASS {
CONSTANT: TokenUser 1
@@ -141,6 +170,140 @@ CONSTANT: TokenSessionReference 14
CONSTANT: TokenSandBoxInert 15
! } TOKEN_INFORMATION_CLASS;
+TYPEDEF: DWORD ACCESS_MODE
+C-ENUM:
+ NOT_USED_ACCESS
+ GRANT_ACCESS
+ SET_ACCESS
+ DENY_ACCESS
+ REVOKE_ACCESS
+ SET_AUDIT_SUCCESS
+ SET_AUDIT_FAILURE ;
+
+TYPEDEF: DWORD MULTIPLE_TRUSTEE_OPERATION
+C-ENUM:
+ NO_MULTIPLE_TRUSTEE
+ TRUSTEE_IS_IMPERSONATE ;
+
+TYPEDEF: DWORD TRUSTEE_FORM
+C-ENUM:
+ TRUSTEE_IS_SID
+ TRUSTEE_IS_NAME
+ TRUSTEE_BAD_FORM
+ TRUSTEE_IS_OBJECTS_AND_SID
+ TRUSTEE_IS_OBJECTS_AND_NAME ;
+
+TYPEDEF: DWORD TRUSTEE_TYPE
+C-ENUM:
+ TRUSTEE_IS_UNKNOWN
+ TRUSTEE_IS_USER
+ TRUSTEE_IS_GROUP
+ TRUSTEE_IS_DOMAIN
+ TRUSTEE_IS_ALIAS
+ TRUSTEE_IS_WELL_KNOWN_GROUP
+ TRUSTEE_IS_DELETED
+ TRUSTEE_IS_INVALID
+ TRUSTEE_IS_COMPUTER ;
+
+TYPEDEF: DWORD SE_OBJECT_TYPE
+C-ENUM:
+ SE_UNKNOWN_OBJECT_TYPE
+ SE_FILE_OBJECT
+ SE_SERVICE
+ SE_PRINTER
+ SE_REGISTRY_KEY
+ SE_LMSHARE
+ SE_KERNEL_OBJECT
+ SE_WINDOW_OBJECT
+ SE_DS_OBJECT
+ SE_DS_OBJECT_ALL
+ SE_PROVIDER_DEFINED_OBJECT
+ SE_WMIGUID_OBJECT
+ SE_REGISTRY_WOW64_32KEY ;
+
+TYPEDEF: TRUSTEE* PTRUSTEE
+
+C-STRUCT: TRUSTEE
+ { "PTRUSTEE" "pMultipleTrustee" }
+ { "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" }
+ { "TRUSTEE_FORM" "TrusteeForm" }
+ { "TRUSTEE_TYPE" "TrusteeType" }
+ { "LPTSTR" "ptstrName" } ;
+
+C-STRUCT: EXPLICIT_ACCESS
+ { "DWORD" "grfAccessPermissions" }
+ { "ACCESS_MODE" "grfAccessMode" }
+ { "DWORD" "grfInheritance" }
+ { "TRUSTEE" "Trustee" } ;
+
+C-STRUCT: SID_IDENTIFIER_AUTHORITY
+ { { "BYTE" 6 } "Value" } ;
+
+TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY
+
+CONSTANT: SECURITY_NULL_SID_AUTHORITY 0
+CONSTANT: SECURITY_WORLD_SID_AUTHORITY 1
+CONSTANT: SECURITY_LOCAL_SID_AUTHORITY 2
+CONSTANT: SECURITY_CREATOR_SID_AUTHORITY 3
+CONSTANT: SECURITY_NON_UNIQUE_AUTHORITY 4
+CONSTANT: SECURITY_NT_AUTHORITY 5
+CONSTANT: SECURITY_RESOURCE_MANAGER_AUTHORITY 6
+
+CONSTANT: SECURITY_NULL_RID 0
+CONSTANT: SECURITY_WORLD_RID 0
+CONSTANT: SECURITY_LOCAL_RID 0
+CONSTANT: SECURITY_CREATOR_OWNER_RID 0
+CONSTANT: SECURITY_CREATOR_GROUP_RID 1
+CONSTANT: SECURITY_CREATOR_OWNER_SERVER_RID 2
+CONSTANT: SECURITY_CREATOR_GROUP_SERVER_RID 3
+CONSTANT: SECURITY_DIALUP_RID 1
+CONSTANT: SECURITY_NETWORK_RID 2
+CONSTANT: SECURITY_BATCH_RID 3
+CONSTANT: SECURITY_INTERACTIVE_RID 4
+CONSTANT: SECURITY_SERVICE_RID 6
+CONSTANT: SECURITY_ANONYMOUS_LOGON_RID 7
+CONSTANT: SECURITY_PROXY_RID 8
+CONSTANT: SECURITY_SERVER_LOGON_RID 9
+CONSTANT: SECURITY_PRINCIPAL_SELF_RID 10
+CONSTANT: SECURITY_AUTHENTICATED_USER_RID 11
+CONSTANT: SECURITY_LOGON_IDS_RID 5
+CONSTANT: SECURITY_LOGON_IDS_RID_COUNT 3
+CONSTANT: SECURITY_LOCAL_SYSTEM_RID 18
+CONSTANT: SECURITY_NT_NON_UNIQUE 21
+CONSTANT: SECURITY_BUILTIN_DOMAIN_RID 32
+CONSTANT: DOMAIN_USER_RID_ADMIN 500
+CONSTANT: DOMAIN_USER_RID_GUEST 501
+CONSTANT: DOMAIN_GROUP_RID_ADMINS 512
+CONSTANT: DOMAIN_GROUP_RID_USERS 513
+CONSTANT: DOMAIN_GROUP_RID_GUESTS 514
+CONSTANT: DOMAIN_ALIAS_RID_ADMINS 544
+CONSTANT: DOMAIN_ALIAS_RID_USERS 545
+CONSTANT: DOMAIN_ALIAS_RID_GUESTS 546
+CONSTANT: DOMAIN_ALIAS_RID_POWER_USERS 547
+CONSTANT: DOMAIN_ALIAS_RID_ACCOUNT_OPS 548
+CONSTANT: DOMAIN_ALIAS_RID_SYSTEM_OPS 549
+CONSTANT: DOMAIN_ALIAS_RID_PRINT_OPS 550
+CONSTANT: DOMAIN_ALIAS_RID_BACKUP_OPS 551
+CONSTANT: DOMAIN_ALIAS_RID_REPLICATOR 552
+CONSTANT: SE_GROUP_MANDATORY 1
+CONSTANT: SE_GROUP_ENABLED_BY_DEFAULT 2
+CONSTANT: SE_GROUP_ENABLED 4
+CONSTANT: SE_GROUP_OWNER 8
+CONSTANT: SE_GROUP_LOGON_ID -1073741824
+
+! SID is a variable length structure
+TYPEDEF: void* PSID
+
+TYPEDEF: EXPLICIT_ACCESS* PEXPLICIT_ACCESS
+
+TYPEDEF: DWORD SECURITY_INFORMATION
+TYPEDEF: SECURITY_INFORMATION* PSECURITY_INFORMATION
+
+CONSTANT: OWNER_SECURITY_INFORMATION 1
+CONSTANT: GROUP_SECURITY_INFORMATION 2
+CONSTANT: DACL_SECURITY_INFORMATION 4
+CONSTANT: SACL_SECURITY_INFORMATION 8
+
CONSTANT: DELETE HEX: 00010000
CONSTANT: READ_CONTROL HEX: 00020000
CONSTANT: WRITE_DAC HEX: 00040000
@@ -187,6 +350,45 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080
TOKEN_ADJUST_DEFAULT
} flags ; foldable
+CONSTANT: HKEY_CLASSES_ROOT HEX: 80000000
+CONSTANT: HKEY_CURRENT_USER HEX: 80000001
+CONSTANT: HKEY_LOCAL_MACHINE HEX: 80000002
+CONSTANT: HKEY_USERS HEX: 80000003
+CONSTANT: HKEY_PERFORMANCE_DATA HEX: 80000004
+CONSTANT: HKEY_CURRENT_CONFIG HEX: 80000005
+CONSTANT: HKEY_DYN_DATA HEX: 80000006
+CONSTANT: HKEY_PERFORMANCE_TEXT HEX: 80000050
+CONSTANT: HKEY_PERFORMANCE_NLSTEXT HEX: 80000060
+
+CONSTANT: KEY_QUERY_VALUE HEX: 0001
+CONSTANT: KEY_SET_VALUE HEX: 0002
+CONSTANT: KEY_CREATE_SUB_KEY HEX: 0004
+CONSTANT: KEY_ENUMERATE_SUB_KEYS HEX: 0008
+CONSTANT: KEY_NOTIFY HEX: 0010
+CONSTANT: KEY_CREATE_LINK HEX: 0020
+CONSTANT: KEY_READ HEX: 20019
+CONSTANT: KEY_WOW64_32KEY HEX: 0200
+CONSTANT: KEY_WOW64_64KEY HEX: 0100
+CONSTANT: KEY_WRITE HEX: 20006
+CONSTANT: KEY_EXECUTE KEY_READ
+CONSTANT: KEY_ALL_ACCESS HEX: F003F
+
+CONSTANT: REG_NONE 0
+CONSTANT: REG_SZ 1
+CONSTANT: REG_EXPAND_SZ 2
+CONSTANT: REG_BINARY 3
+CONSTANT: REG_DWORD 4
+CONSTANT: REG_DWORD_LITTLE_ENDIAN 4
+CONSTANT: REG_DWORD_BIG_ENDIAN 5
+CONSTANT: REG_LINK 6
+CONSTANT: REG_MULTI_SZ 7
+CONSTANT: REG_RESOURCE_LIST 8
+CONSTANT: REG_FULL_RESOURCE_DESCRIPTOR 9
+CONSTANT: REG_RESOURCE_REQUIREMENTS_LIST 10
+CONSTANT: REG_QWORD 11
+CONSTANT: REG_QWORD_LITTLE_ENDIAN 11
+
+TYPEDEF: DWORD REGSAM
! : I_ScGetCurrentGroupStateW ;
! : A_SHAFinal ;
@@ -224,7 +426,19 @@ FUNCTION: BOOL AdjustTokenPrivileges ( HANDLE TokenHandle,
PTOKEN_PRIVILEGES PreviousState,
PDWORD ReturnLength ) ;
-! : AllocateAndInitializeSid ;
+FUNCTION: BOOL AllocateAndInitializeSid (
+ PSID_IDENTIFIER_AUTHORITY pIdentifierAuthority,
+ BYTE nSubAuthorityCount,
+ DWORD dwSubAuthority0,
+ DWORD dwSubAuthority1,
+ DWORD dwSubAuthority2,
+ DWORD dwSubAuthority3,
+ DWORD dwSubAuthority4,
+ DWORD dwSubAuthority5,
+ DWORD dwSubAuthority6,
+ DWORD dwSubAuthority7,
+ PSID* pSid ) ;
+
! : AllocateLocallyUniqueId ;
! : AreAllAccessesGranted ;
! : AreAnyAccessesGranted ;
@@ -442,7 +656,8 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
! : GetExplicitEntriesFromAclA ;
! : GetExplicitEntriesFromAclW ;
! : GetFileSecurityA ;
-! : GetFileSecurityW ;
+FUNCTION: BOOL GetFileSecurityW ( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded ) ;
+ALIAS: GetFileSecurity GetFileSecurityW
! : GetInformationCodeAuthzLevelW ;
! : GetInformationCodeAuthzPolicyW ;
! : GetInheritanceSourceA ;
@@ -459,19 +674,20 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
! : GetMultipleTrusteeW ;
! : GetNamedSecurityInfoA ;
! : GetNamedSecurityInfoExA ;
-! : GetNamedSecurityInfoExW ;
-! : GetNamedSecurityInfoW ;
+! FUNCTION: DWORD GetNamedSecurityInfoExW
+FUNCTION: DWORD GetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID* ppsidOwner, PSID* ppsidGroup, PACL* ppDacl, PACL* ppSacl, PSECURITY_DESCRIPTOR* ppSecurityDescriptor ) ;
+ALIAS: GetNamedSecurityInfo GetNamedSecurityInfoW
! : GetNumberOfEventLogRecords ;
! : GetOldestEventLogRecord ;
! : GetOverlappedAccessResults ;
! : GetPrivateObjectSecurity ;
-! : GetSecurityDescriptorControl ;
-! : GetSecurityDescriptorDacl ;
-! : GetSecurityDescriptorGroup ;
-! : GetSecurityDescriptorLength ;
-! : GetSecurityDescriptorOwner ;
-! : GetSecurityDescriptorRMControl ;
-! : GetSecurityDescriptorSacl ;
+FUNCTION: BOOL GetSecurityDescriptorControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSECURITY_DESCRIPTOR_CONTROL pControl, LPDWORD lpdwRevision ) ;
+FUNCTION: BOOL GetSecurityDescriptorDacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbDaclPresent, PACL* pDacl, LPBOOL lpDaclDefaulted ) ;
+FUNCTION: BOOL GetSecurityDescriptorGroup ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pGroup, LPBOOL lpGroupDefaulted ) ;
+FUNCTION: BOOL GetSecurityDescriptorLength ( PSECURITY_DESCRIPTOR pSecurityDescriptor ) ;
+FUNCTION: BOOL GetSecurityDescriptorOwner ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pOwner, LPBOOL lpOwnerDefaulted ) ;
+FUNCTION: BOOL GetSecurityDescriptorRMControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PUCHAR RMControl ) ;
+FUNCTION: BOOL GetSecurityDescriptorSacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbSaclPresent, PACL* pSacl, LPBOOL lpSaclDefaulted ) ;
! : GetSecurityInfo ;
! : GetSecurityInfoExA ;
! : GetSecurityInfoExW ;
@@ -510,7 +726,7 @@ ALIAS: GetUserName GetUserNameW
! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ;
FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
-! : InitializeSecurityDescriptor ;
+FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ;
! : InitializeSid ;
! : InitiateSystemShutdownA ;
! : InitiateSystemShutdownExA ;
@@ -669,43 +885,96 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : ReadEncryptedFileRaw ;
! : ReadEventLogA ;
! : ReadEventLogW ;
-! : RegCloseKey ;
+FUNCTION: LONG RegCloseKey ( HKEY hKey ) ;
! : RegConnectRegistryA ;
! : RegConnectRegistryW ;
! : RegCreateKeyA ;
! : RegCreateKeyExA ;
-! : RegCreateKeyExW ;
-! : RegCreateKeyW ;
+FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ;
+! : RegCreateKeyW
! : RegDeleteKeyA ;
! : RegDeleteKeyW ;
+
+FUNCTION: LONG RegDeleteKeyExW (
+ HKEY hKey,
+ LPCTSTR lpSubKey,
+ DWORD Reserved,
+ LPTSTR lpClass,
+ DWORD dwOptions,
+ REGSAM samDesired,
+ LPSECURITY_ATTRIBUTES lpSecurityAttributes,
+ PHKEY phkResult,
+ LPDWORD lpdwDisposition
+ ) ;
+
+ALIAS: RegDeleteKeyEx RegDeleteKeyExW
+
! : RegDeleteValueA ;
! : RegDeleteValueW ;
! : RegDisablePredefinedCache ;
! : RegEnumKeyA ;
! : RegEnumKeyExA ;
-! : RegEnumKeyExW ;
+FUNCTION: LONG RegEnumKeyExW (
+ HKEY hKey,
+ DWORD dwIndex,
+ LPTSTR lpName,
+ LPDWORD lpcName,
+ LPDWORD lpReserved,
+ LPTSTR lpClass,
+ LPDWORD lpcClass,
+ PFILETIME lpftLastWriteTime
+ ) ;
! : RegEnumKeyW ;
! : RegEnumValueA ;
-! : RegEnumValueW ;
+
+FUNCTION: LONG RegEnumValueW (
+ HKEY hKey,
+ DWORD dwIndex,
+ LPTSTR lpValueName,
+ LPDWORD lpcchValueName,
+ LPDWORD lpReserved,
+ LPDWORD lpType,
+ LPBYTE lpData,
+ LPDWORD lpcbData
+ ) ;
+
+ALIAS: RegEnumValue RegEnumValueW
+
! : RegFlushKey ;
! : RegGetKeySecurity ;
! : RegLoadKeyA ;
! : RegLoadKeyW ;
! : RegNotifyChangeKeyValue ;
-! : RegOpenCurrentUser ;
+FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ;
! : RegOpenKeyA ;
! : RegOpenKeyExA ;
-! : RegOpenKeyExW ;
+FUNCTION: LONG RegOpenKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD ulOptions, REGSAM samDesired, PHKEY phkResult ) ;
+ALIAS: RegOpenKeyEx RegOpenKeyExW
! : RegOpenKeyW ;
! : RegOpenUserClassesRoot ;
! : RegOverridePredefKey ;
! : RegQueryInfoKeyA ;
-! : RegQueryInfoKeyW ;
+FUNCTION: LONG RegQueryInfoKeyW (
+ HKEY hKey,
+ LPTSTR lpClass,
+ LPDWORD lpcClass,
+ LPDWORD lpReserved,
+ LPDWORD lpcSubKeys,
+ LPDWORD lpcMaxSubKeyLen,
+ LPDWORD lpcMaxClassLen,
+ LPDWORD lpcValues,
+ LPDWORD lpcMaxValueNameLen,
+ LPDWORD lpcMaxValueLen,
+ LPDWORD lpcbSecurityDescriptor,
+ PFILETIME lpftLastWriteTime
+ ) ;
+ALIAS: RegQueryInfoKey RegQueryInfoKeyW
! : RegQueryMultipleValuesA ;
! : RegQueryMultipleValuesW ;
! : RegQueryValueA ;
! : RegQueryValueExA ;
-! : RegQueryValueExW ;
+FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPDWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ;
+ALIAS: RegQueryValueEx RegQueryValueExW
! : RegQueryValueW ;
! : RegReplaceKeyA ;
! : RegReplaceKeyW ;
@@ -756,7 +1025,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : SetEntriesInAccessListA ;
! : SetEntriesInAccessListW ;
! : SetEntriesInAclA ;
-! : SetEntriesInAclW ;
+FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ;
+ALIAS: SetEntriesInAcl SetEntriesInAclW
! : SetEntriesInAuditListA ;
! : SetEntriesInAuditListW ;
! : SetFileSecurityA ;
@@ -767,7 +1037,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : SetNamedSecurityInfoA ;
! : SetNamedSecurityInfoExA ;
! : SetNamedSecurityInfoExW ;
-! : SetNamedSecurityInfoW ;
+FUNCTION: DWORD SetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID psidOwner, PSID psidGroup, PACL pDacl, PACL pSacl ) ;
+ALIAS: SetNamedSecurityInfo SetNamedSecurityInfoW
! : SetPrivateObjectSecurity ;
! : SetPrivateObjectSecurityEx ;
! : SetSecurityDescriptorControl ;
diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor
index a014a56ea0..e78c987cd4 100755
--- a/basis/windows/com/wrapper/wrapper.factor
+++ b/basis/windows/com/wrapper/wrapper.factor
@@ -132,7 +132,7 @@ unless
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
: (callbacks>vtbl) ( callbacks -- vtbl )
- [ execute ] void*-array{ } map-as malloc-byte-array ;
+ [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ;
: (callbacks>vtbls) ( callbacks -- vtbls )
[ (callbacks>vtbl) ] map ;
diff --git a/basis/windows/dinput/constants/constants-tests.factor b/basis/windows/dinput/constants/constants-tests.factor
new file mode 100644
index 0000000000..67785844fa
--- /dev/null
+++ b/basis/windows/dinput/constants/constants-tests.factor
@@ -0,0 +1,5 @@
+IN: windows.dinput.constants.tests
+USING: tools.test windows.dinput.constants.private ;
+
+[ ] [ define-constants ] unit-test
+[ ] [ free-dinput-constants ] unit-test
\ No newline at end of file
diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor
index cd1033d418..74238abed2 100755
--- a/basis/windows/dinput/constants/constants.factor
+++ b/basis/windows/dinput/constants/constants.factor
@@ -27,12 +27,12 @@ SYMBOLS:
: (flag) ( thing -- integer )
{
- { [ dup word? ] [ execute ] }
- { [ dup callable? ] [ call ] }
+ { [ dup word? ] [ execute( -- value ) ] }
+ { [ dup callable? ] [ call( -- value ) ] }
[ ]
} cond ;
-: (flags) ( array -- )
+: (flags) ( array -- n )
0 [ (flag) bitor ] reduce ;
: (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien )
@@ -63,14 +63,16 @@ SYMBOLS:
] ;
: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
- [ {
- [ set-DIDATAFORMAT-rgodf ]
- [ set-DIDATAFORMAT-dwNumObjs ]
- [ set-DIDATAFORMAT-dwDataSize ]
- [ set-DIDATAFORMAT-dwFlags ]
- [ set-DIDATAFORMAT-dwObjSize ]
- [ set-DIDATAFORMAT-dwSize ]
- } cleave ] keep ;
+ [
+ {
+ [ set-DIDATAFORMAT-rgodf ]
+ [ set-DIDATAFORMAT-dwNumObjs ]
+ [ set-DIDATAFORMAT-dwDataSize ]
+ [ set-DIDATAFORMAT-dwFlags ]
+ [ set-DIDATAFORMAT-dwObjSize ]
+ [ set-DIDATAFORMAT-dwSize ]
+ } cleave
+ ] keep ;
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip
@@ -78,9 +80,10 @@ SYMBOLS:
"DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
: (malloc-guid-symbol) ( symbol guid -- )
- global swap '[ [
- _ execute [ byte-length malloc ] [ over byte-array>memory ] bi
- ] unless* ] change-at ;
+ '[
+ _ execute( -- value )
+ [ byte-length malloc ] [ over byte-array>memory ] bi
+ ] initialize ;
: define-guid-constants ( -- )
{
@@ -105,7 +108,7 @@ SYMBOLS:
} [ first2 (malloc-guid-symbol) ] each ;
: define-joystick-format-constant ( -- )
- c_dfDIJoystick2 global [ [
+ c_dfDIJoystick2 [
DIDF_ABSAXIS
"DIJOYSTATE2" heap-size
"DIJOYSTATE2" {
@@ -274,10 +277,10 @@ SYMBOLS:
{ GUID_Slider_malloced "rglFSlider" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE }
{ GUID_Slider_malloced "rglFSlider" 1 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE }
} <DIDATAFORMAT>
- ] unless* ] change-at ;
+ ] initialize ;
: define-mouse-format-constant ( -- )
- c_dfDIMouse2 global [ [
+ c_dfDIMouse2 [
DIDF_RELAXIS
"DIMOUSESTATE2" heap-size
"DIMOUSESTATE2" {
@@ -293,13 +296,13 @@ SYMBOLS:
{ GUID_Button_malloced "rgbButtons" 6 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 }
{ GUID_Button_malloced "rgbButtons" 7 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 }
} <DIDATAFORMAT>
- ] unless* ] change-at ;
+ ] initialize ;
! Not a standard DirectInput format. Included for cross-platform niceness.
! This format returns the keyboard keys in USB HID order rather than Windows
! order
: define-hid-keyboard-format-constant ( -- )
- c_dfDIKeyboard_HID global [ [
+ c_dfDIKeyboard_HID [
DIDF_RELAXIS
256
f {
@@ -560,10 +563,10 @@ SYMBOLS:
{ GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 }
{ GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 }
} <DIDATAFORMAT>
- ] unless* ] change-at ;
+ ] initialize ;
: define-keyboard-format-constant ( -- )
- c_dfDIKeyboard global [ [
+ c_dfDIKeyboard [
DIDF_RELAXIS
256
f {
@@ -824,7 +827,7 @@ SYMBOLS:
{ GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 254 DIDFT_MAKEINSTANCE ] } 0 }
{ GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 255 DIDFT_MAKEINSTANCE ] } 0 }
} <DIDATAFORMAT>
- ] unless* ] change-at ;
+ ] initialize ;
: define-format-constants ( -- )
define-joystick-format-constant
@@ -837,7 +840,9 @@ SYMBOLS:
define-format-constants ;
[ define-constants ] "windows.dinput.constants" add-init-hook
-define-constants
+
+: uninitialize ( variable quot -- )
+ '[ _ when* f ] change-global ; inline
: free-dinput-constants ( -- )
{
@@ -846,10 +851,11 @@ define-constants
GUID_Slider_malloced GUID_Button_malloced GUID_Key_malloced GUID_POV_malloced GUID_Unknown_malloced
GUID_SysMouse_malloced GUID_SysKeyboard_malloced GUID_Joystick_malloced GUID_SysMouseEm_malloced
GUID_SysMouseEm2_malloced GUID_SysKeyboardEm_malloced GUID_SysKeyboardEm2_malloced
- } [ global [ [ free ] when* f ] change-at ] each
+ } [ [ free ] uninitialize ] each
+
{
c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2
- } [ global [ [ DIDATAFORMAT-rgodf free ] when* f ] change-at ] each ;
+ } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ;
PRIVATE>
diff --git a/basis/windows/errors/errors-tests.factor b/basis/windows/errors/errors-tests.factor
new file mode 100755
index 0000000000..96edb8a379
--- /dev/null
+++ b/basis/windows/errors/errors-tests.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test windows.errors strings ;
+IN: windows.errors.tests
+
+[ t ] [ 0 n>win32-error-string string? ] unit-test
diff --git a/basis/windows/errors/errors.factor b/basis/windows/errors/errors.factor
index 56bba768de..d180cb20e7 100644
--- a/basis/windows/errors/errors.factor
+++ b/basis/windows/errors/errors.factor
@@ -1,9 +1,754 @@
-IN: windows.errors
+USING: alien.c-types kernel locals math math.bitwise
+windows.kernel32 sequences byte-arrays unicode.categories
+io.encodings.string io.encodings.utf16n alien.strings
+arrays literals ;
+IN: windows.errors
-CONSTANT: ERROR_SUCCESS 0
-CONSTANT: ERROR_NO_MORE_FILES 18
-CONSTANT: ERROR_HANDLE_EOF 38
-CONSTANT: ERROR_BROKEN_PIPE 109
-CONSTANT: ERROR_ENVVAR_NOT_FOUND 203
-CONSTANT: ERROR_IO_INCOMPLETE 996
-CONSTANT: ERROR_IO_PENDING 997
+CONSTANT: ERROR_SUCCESS 0
+CONSTANT: ERROR_INVALID_FUNCTION 1
+CONSTANT: ERROR_FILE_NOT_FOUND 2
+CONSTANT: ERROR_PATH_NOT_FOUND 3
+CONSTANT: ERROR_TOO_MANY_OPEN_FILES 4
+CONSTANT: ERROR_ACCESS_DENIED 5
+CONSTANT: ERROR_INVALID_HANDLE 6
+CONSTANT: ERROR_ARENA_TRASHED 7
+CONSTANT: ERROR_NOT_ENOUGH_MEMORY 8
+CONSTANT: ERROR_INVALID_BLOCK 9
+CONSTANT: ERROR_BAD_ENVIRONMENT 10
+CONSTANT: ERROR_BAD_FORMAT 11
+CONSTANT: ERROR_INVALID_ACCESS 12
+CONSTANT: ERROR_INVALID_DATA 13
+CONSTANT: ERROR_OUTOFMEMORY 14
+CONSTANT: ERROR_INVALID_DRIVE 15
+CONSTANT: ERROR_CURRENT_DIRECTORY 16
+CONSTANT: ERROR_NOT_SAME_DEVICE 17
+CONSTANT: ERROR_NO_MORE_FILES 18
+CONSTANT: ERROR_WRITE_PROTECT 19
+CONSTANT: ERROR_BAD_UNIT 20
+CONSTANT: ERROR_NOT_READY 21
+CONSTANT: ERROR_BAD_COMMAND 22
+CONSTANT: ERROR_CRC 23
+CONSTANT: ERROR_BAD_LENGTH 24
+CONSTANT: ERROR_SEEK 25
+CONSTANT: ERROR_NOT_DOS_DISK 26
+CONSTANT: ERROR_SECTOR_NOT_FOUND 27
+CONSTANT: ERROR_OUT_OF_PAPER 28
+CONSTANT: ERROR_WRITE_FAULT 29
+CONSTANT: ERROR_READ_FAULT 30
+CONSTANT: ERROR_GEN_FAILURE 31
+CONSTANT: ERROR_SHARING_VIOLATION 32
+CONSTANT: ERROR_LOCK_VIOLATION 33
+CONSTANT: ERROR_WRONG_DISK 34
+CONSTANT: ERROR_SHARING_BUFFER_EXCEEDED 36
+CONSTANT: ERROR_HANDLE_EOF 38
+CONSTANT: ERROR_HANDLE_DISK_FULL 39
+CONSTANT: ERROR_NOT_SUPPORTED 50
+CONSTANT: ERROR_REM_NOT_LIST 51
+CONSTANT: ERROR_DUP_NAME 52
+CONSTANT: ERROR_BAD_NETPATH 53
+CONSTANT: ERROR_NETWORK_BUSY 54
+CONSTANT: ERROR_DEV_NOT_EXIST 55
+CONSTANT: ERROR_TOO_MANY_CMDS 56
+CONSTANT: ERROR_ADAP_HDW_ERR 57
+CONSTANT: ERROR_BAD_NET_RESP 58
+CONSTANT: ERROR_UNEXP_NET_ERR 59
+CONSTANT: ERROR_BAD_REM_ADAP 60
+CONSTANT: ERROR_PRINTQ_FULL 61
+CONSTANT: ERROR_NO_SPOOL_SPACE 62
+CONSTANT: ERROR_PRINT_CANCELLED 63
+CONSTANT: ERROR_NETNAME_DELETED 64
+CONSTANT: ERROR_NETWORK_ACCESS_DENIED 65
+CONSTANT: ERROR_BAD_DEV_TYPE 66
+CONSTANT: ERROR_BAD_NET_NAME 67
+CONSTANT: ERROR_TOO_MANY_NAMES 68
+CONSTANT: ERROR_TOO_MANY_SESS 69
+CONSTANT: ERROR_SHARING_PAUSED 70
+CONSTANT: ERROR_REQ_NOT_ACCEP 71
+CONSTANT: ERROR_REDIR_PAUSED 72
+CONSTANT: ERROR_FILE_EXISTS 80
+CONSTANT: ERROR_CANNOT_MAKE 82
+CONSTANT: ERROR_FAIL_I24 83
+CONSTANT: ERROR_OUT_OF_STRUCTURES 84
+CONSTANT: ERROR_ALREADY_ASSIGNED 85
+CONSTANT: ERROR_INVALID_PASSWORD 86
+CONSTANT: ERROR_INVALID_PARAMETER 87
+CONSTANT: ERROR_NET_WRITE_FAULT 88
+CONSTANT: ERROR_NO_PROC_SLOTS 89
+CONSTANT: ERROR_TOO_MANY_SEMAPHORES 100
+CONSTANT: ERROR_EXCL_SEM_ALREADY_OWNED 101
+CONSTANT: ERROR_SEM_IS_SET 102
+CONSTANT: ERROR_TOO_MANY_SEM_REQUESTS 103
+CONSTANT: ERROR_INVALID_AT_INTERRUPT_TIME 104
+CONSTANT: ERROR_SEM_OWNER_DIED 105
+CONSTANT: ERROR_SEM_USER_LIMIT 106
+CONSTANT: ERROR_DISK_CHANGE 107
+CONSTANT: ERROR_DRIVE_LOCKED 108
+CONSTANT: ERROR_BROKEN_PIPE 109
+CONSTANT: ERROR_OPEN_FAILED 110
+CONSTANT: ERROR_BUFFER_OVERFLOW 111
+CONSTANT: ERROR_DISK_FULL 112
+CONSTANT: ERROR_NO_MORE_SEARCH_HANDLES 113
+CONSTANT: ERROR_INVALID_TARGET_HANDLE 114
+CONSTANT: ERROR_INVALID_CATEGORY 117
+CONSTANT: ERROR_INVALID_VERIFY_SWITCH 118
+CONSTANT: ERROR_BAD_DRIVER_LEVEL 119
+CONSTANT: ERROR_CALL_NOT_IMPLEMENTED 120
+CONSTANT: ERROR_SEM_TIMEOUT 121
+CONSTANT: ERROR_INSUFFICIENT_BUFFER 122
+CONSTANT: ERROR_INVALID_NAME 123
+CONSTANT: ERROR_INVALID_LEVEL 124
+CONSTANT: ERROR_NO_VOLUME_LABEL 125
+CONSTANT: ERROR_MOD_NOT_FOUND 126
+CONSTANT: ERROR_PROC_NOT_FOUND 127
+CONSTANT: ERROR_WAIT_NO_CHILDREN 128
+CONSTANT: ERROR_CHILD_NOT_COMPLETE 129
+CONSTANT: ERROR_DIRECT_ACCESS_HANDLE 130
+CONSTANT: ERROR_NEGATIVE_SEEK 131
+CONSTANT: ERROR_SEEK_ON_DEVICE 132
+CONSTANT: ERROR_IS_JOIN_TARGET 133
+CONSTANT: ERROR_IS_JOINED 134
+CONSTANT: ERROR_IS_SUBSTED 135
+CONSTANT: ERROR_NOT_JOINED 136
+CONSTANT: ERROR_NOT_SUBSTED 137
+CONSTANT: ERROR_JOIN_TO_JOIN 138
+CONSTANT: ERROR_SUBST_TO_SUBST 139
+CONSTANT: ERROR_JOIN_TO_SUBST 140
+CONSTANT: ERROR_SUBST_TO_JOIN 141
+CONSTANT: ERROR_BUSY_DRIVE 142
+CONSTANT: ERROR_SAME_DRIVE 143
+CONSTANT: ERROR_DIR_NOT_ROOT 144
+CONSTANT: ERROR_DIR_NOT_EMPTY 145
+CONSTANT: ERROR_IS_SUBST_PATH 146
+CONSTANT: ERROR_IS_JOIN_PATH 147
+CONSTANT: ERROR_PATH_BUSY 148
+CONSTANT: ERROR_IS_SUBST_TARGET 149
+CONSTANT: ERROR_SYSTEM_TRACE 150
+CONSTANT: ERROR_INVALID_EVENT_COUNT 151
+CONSTANT: ERROR_TOO_MANY_MUXWAITERS 152
+CONSTANT: ERROR_INVALID_LIST_FORMAT 153
+CONSTANT: ERROR_LABEL_TOO_LONG 154
+CONSTANT: ERROR_TOO_MANY_TCBS 155
+CONSTANT: ERROR_SIGNAL_REFUSED 156
+CONSTANT: ERROR_DISCARDED 157
+CONSTANT: ERROR_NOT_LOCKED 158
+CONSTANT: ERROR_BAD_THREADID_ADDR 159
+CONSTANT: ERROR_BAD_ARGUMENTS 160
+CONSTANT: ERROR_BAD_PATHNAME 161
+CONSTANT: ERROR_SIGNAL_PENDING 162
+CONSTANT: ERROR_MAX_THRDS_REACHED 164
+CONSTANT: ERROR_LOCK_FAILED 167
+CONSTANT: ERROR_BUSY 170
+CONSTANT: ERROR_CANCEL_VIOLATION 173
+CONSTANT: ERROR_ATOMIC_LOCKS_NOT_SUPPORTED 174
+CONSTANT: ERROR_INVALID_SEGMENT_NUMBER 180
+CONSTANT: ERROR_INVALID_ORDINAL 182
+CONSTANT: ERROR_ALREADY_EXISTS 183
+CONSTANT: ERROR_INVALID_FLAG_NUMBER 186
+CONSTANT: ERROR_SEM_NOT_FOUND 187
+CONSTANT: ERROR_INVALID_STARTING_CODESEG 188
+CONSTANT: ERROR_INVALID_STACKSEG 189
+CONSTANT: ERROR_INVALID_MODULETYPE 190
+CONSTANT: ERROR_INVALID_EXE_SIGNATURE 191
+CONSTANT: ERROR_EXE_MARKED_INVALID 192
+CONSTANT: ERROR_BAD_EXE_FORMAT 193
+CONSTANT: ERROR_ITERATED_DATA_EXCEEDS_64k 194
+CONSTANT: ERROR_INVALID_MINALLOCSIZE 195
+CONSTANT: ERROR_DYNLINK_FROM_INVALID_RING 196
+CONSTANT: ERROR_IOPL_NOT_ENABLED 197
+CONSTANT: ERROR_INVALID_SEGDPL 198
+CONSTANT: ERROR_AUTODATASEG_EXCEEDS_64k 199
+CONSTANT: ERROR_RING2SEG_MUST_BE_MOVABLE 200
+CONSTANT: ERROR_RELOC_CHAIN_XEEDS_SEGLIM 201
+CONSTANT: ERROR_INFLOOP_IN_RELOC_CHAIN 202
+CONSTANT: ERROR_ENVVAR_NOT_FOUND 203
+CONSTANT: ERROR_NO_SIGNAL_SENT 205
+CONSTANT: ERROR_FILENAME_EXCED_RANGE 206
+CONSTANT: ERROR_RING2_STACK_IN_USE 207
+CONSTANT: ERROR_META_EXPANSION_TOO_LONG 208
+CONSTANT: ERROR_INVALID_SIGNAL_NUMBER 209
+CONSTANT: ERROR_THREAD_1_INACTIVE 210
+CONSTANT: ERROR_LOCKED 212
+CONSTANT: ERROR_TOO_MANY_MODULES 214
+CONSTANT: ERROR_NESTING_NOT_ALLOWED 215
+CONSTANT: ERROR_EXE_MACHINE_TYPE_MISMATCH 216
+CONSTANT: ERROR_BAD_PIPE 230
+CONSTANT: ERROR_PIPE_BUSY 231
+CONSTANT: ERROR_NO_DATA 232
+CONSTANT: ERROR_PIPE_NOT_CONNECTED 233
+CONSTANT: ERROR_MORE_DATA 234
+CONSTANT: ERROR_VC_DISCONNECTED 240
+CONSTANT: ERROR_INVALID_EA_NAME 254
+CONSTANT: ERROR_EA_LIST_INCONSISTENT 255
+CONSTANT: ERROR_NO_MORE_ITEMS 259
+CONSTANT: ERROR_CANNOT_COPY 266
+CONSTANT: ERROR_DIRECTORY 267
+CONSTANT: ERROR_EAS_DIDNT_FIT 275
+CONSTANT: ERROR_EA_FILE_CORRUPT 276
+CONSTANT: ERROR_EA_TABLE_FULL 277
+CONSTANT: ERROR_INVALID_EA_HANDLE 278
+CONSTANT: ERROR_EAS_NOT_SUPPORTED 282
+CONSTANT: ERROR_NOT_OWNER 288
+CONSTANT: ERROR_TOO_MANY_POSTS 298
+CONSTANT: ERROR_PARTIAL_COPY 299
+CONSTANT: ERROR_MR_MID_NOT_FOUND 317
+CONSTANT: ERROR_INVALID_ADDRESS 487
+CONSTANT: ERROR_ARITHMETIC_OVERFLOW 534
+CONSTANT: ERROR_PIPE_CONNECTED 535
+CONSTANT: ERROR_PIPE_LISTENING 536
+CONSTANT: ERROR_EA_ACCESS_DENIED 994
+CONSTANT: ERROR_OPERATION_ABORTED 995
+CONSTANT: ERROR_IO_INCOMPLETE 996
+CONSTANT: ERROR_IO_PENDING 997
+CONSTANT: ERROR_NOACCESS 998
+CONSTANT: ERROR_SWAPERROR 999
+CONSTANT: ERROR_STACK_OVERFLOW 1001
+CONSTANT: ERROR_INVALID_MESSAGE 1002
+CONSTANT: ERROR_CAN_NOT_COMPLETE 1003
+CONSTANT: ERROR_INVALID_FLAGS 1004
+CONSTANT: ERROR_UNRECOGNIZED_VOLUME 1005
+CONSTANT: ERROR_FILE_INVALID 1006
+CONSTANT: ERROR_FULLSCREEN_MODE 1007
+CONSTANT: ERROR_NO_TOKEN 1008
+CONSTANT: ERROR_BADDB 1009
+CONSTANT: ERROR_BADKEY 1010
+CONSTANT: ERROR_CANTOPEN 1011
+CONSTANT: ERROR_CANTREAD 1012
+CONSTANT: ERROR_CANTWRITE 1013
+CONSTANT: ERROR_REGISTRY_RECOVERED 1014
+CONSTANT: ERROR_REGISTRY_CORRUPT 1015
+CONSTANT: ERROR_REGISTRY_IO_FAILED 1016
+CONSTANT: ERROR_NOT_REGISTRY_FILE 1017
+CONSTANT: ERROR_KEY_DELETED 1018
+CONSTANT: ERROR_NO_LOG_SPACE 1019
+CONSTANT: ERROR_KEY_HAS_CHILDREN 1020
+CONSTANT: ERROR_CHILD_MUST_BE_VOLATILE 1021
+CONSTANT: ERROR_NOTIFY_ENUM_DIR 1022
+CONSTANT: ERROR_DEPENDENT_SERVICES_RUNNING 1051
+CONSTANT: ERROR_INVALID_SERVICE_CONTROL 1052
+CONSTANT: ERROR_SERVICE_REQUEST_TIMEOUT 1053
+CONSTANT: ERROR_SERVICE_NO_THREAD 1054
+CONSTANT: ERROR_SERVICE_DATABASE_LOCKED 1055
+CONSTANT: ERROR_SERVICE_ALREADY_RUNNING 1056
+CONSTANT: ERROR_INVALID_SERVICE_ACCOUNT 1057
+CONSTANT: ERROR_SERVICE_DISABLED 1058
+CONSTANT: ERROR_CIRCULAR_DEPENDENCY 1059
+CONSTANT: ERROR_SERVICE_DOES_NOT_EXIST 1060
+CONSTANT: ERROR_SERVICE_CANNOT_ACCEPT_CTRL 1061
+CONSTANT: ERROR_SERVICE_NOT_ACTIVE 1062
+CONSTANT: ERROR_FAILED_SERVICE_CONTROLLER_CONNECT 1063
+CONSTANT: ERROR_EXCEPTION_IN_SERVICE 1064
+CONSTANT: ERROR_DATABASE_DOES_NOT_EXIST 1065
+CONSTANT: ERROR_SERVICE_SPECIFIC_ERROR 1066
+CONSTANT: ERROR_PROCESS_ABORTED 1067
+CONSTANT: ERROR_SERVICE_DEPENDENCY_FAIL 1068
+CONSTANT: ERROR_SERVICE_LOGON_FAILED 1069
+CONSTANT: ERROR_SERVICE_START_HANG 1070
+CONSTANT: ERROR_INVALID_SERVICE_LOCK 1071
+CONSTANT: ERROR_SERVICE_MARKED_FOR_DELETE 1072
+CONSTANT: ERROR_SERVICE_EXISTS 1073
+CONSTANT: ERROR_ALREADY_RUNNING_LKG 1074
+CONSTANT: ERROR_SERVICE_DEPENDENCY_DELETED 1075
+CONSTANT: ERROR_BOOT_ALREADY_ACCEPTED 1076
+CONSTANT: ERROR_SERVICE_NEVER_STARTED 1077
+CONSTANT: ERROR_DUPLICATE_SERVICE_NAME 1078
+CONSTANT: ERROR_DIFFERENT_SERVICE_ACCOUNT 1079
+CONSTANT: ERROR_END_OF_MEDIA 1100
+CONSTANT: ERROR_FILEMARK_DETECTED 1101
+CONSTANT: ERROR_BEGINNING_OF_MEDIA 1102
+CONSTANT: ERROR_SETMARK_DETECTED 1103
+CONSTANT: ERROR_NO_DATA_DETECTED 1104
+CONSTANT: ERROR_PARTITION_FAILURE 1105
+CONSTANT: ERROR_INVALID_BLOCK_LENGTH 1106
+CONSTANT: ERROR_DEVICE_NOT_PARTITIONED 1107
+CONSTANT: ERROR_UNABLE_TO_LOCK_MEDIA 1108
+CONSTANT: ERROR_UNABLE_TO_UNLOAD_MEDIA 1109
+CONSTANT: ERROR_MEDIA_CHANGED 1110
+CONSTANT: ERROR_BUS_RESET 1111
+CONSTANT: ERROR_NO_MEDIA_IN_DRIVE 1112
+CONSTANT: ERROR_NO_UNICODE_TRANSLATION 1113
+CONSTANT: ERROR_DLL_INIT_FAILED 1114
+CONSTANT: ERROR_SHUTDOWN_IN_PROGRESS 1115
+CONSTANT: ERROR_NO_SHUTDOWN_IN_PROGRESS 1116
+CONSTANT: ERROR_IO_DEVICE 1117
+CONSTANT: ERROR_SERIAL_NO_DEVICE 1118
+CONSTANT: ERROR_IRQ_BUSY 1119
+CONSTANT: ERROR_MORE_WRITES 1120
+CONSTANT: ERROR_COUNTER_TIMEOUT 1121
+CONSTANT: ERROR_FLOPPY_ID_MARK_NOT_FOUND 1122
+CONSTANT: ERROR_FLOPPY_WRONG_CYLINDER 1123
+CONSTANT: ERROR_FLOPPY_UNKNOWN_ERROR 1124
+CONSTANT: ERROR_FLOPPY_BAD_REGISTERS 1125
+CONSTANT: ERROR_DISK_RECALIBRATE_FAILED 1126
+CONSTANT: ERROR_DISK_OPERATION_FAILED 1127
+CONSTANT: ERROR_DISK_RESET_FAILED 1128
+CONSTANT: ERROR_EOM_OVERFLOW 1129
+CONSTANT: ERROR_NOT_ENOUGH_SERVER_MEMORY 1130
+CONSTANT: ERROR_POSSIBLE_DEADLOCK 1131
+CONSTANT: ERROR_MAPPED_ALIGNMENT 1132
+CONSTANT: ERROR_SET_POWER_STATE_VETOED 1140
+CONSTANT: ERROR_SET_POWER_STATE_FAILED 1141
+CONSTANT: ERROR_TOO_MANY_LINKS 1142
+CONSTANT: ERROR_OLD_WIN_VERSION 1150
+CONSTANT: ERROR_APP_WRONG_OS 1151
+CONSTANT: ERROR_SINGLE_INSTANCE_APP 1152
+CONSTANT: ERROR_RMODE_APP 1153
+CONSTANT: ERROR_INVALID_DLL 1154
+CONSTANT: ERROR_NO_ASSOCIATION 1155
+CONSTANT: ERROR_DDE_FAIL 1156
+CONSTANT: ERROR_DLL_NOT_FOUND 1157
+CONSTANT: ERROR_BAD_DEVICE 1200
+CONSTANT: ERROR_CONNECTION_UNAVAIL 1201
+CONSTANT: ERROR_DEVICE_ALREADY_REMEMBERED 1202
+CONSTANT: ERROR_NO_NET_OR_BAD_PATH 1203
+CONSTANT: ERROR_BAD_PROVIDER 1204
+CONSTANT: ERROR_CANNOT_OPEN_PROFILE 1205
+CONSTANT: ERROR_BAD_PROFILE 1206
+CONSTANT: ERROR_NOT_CONTAINER 1207
+CONSTANT: ERROR_EXTENDED_ERROR 1208
+CONSTANT: ERROR_INVALID_GROUPNAME 1209
+CONSTANT: ERROR_INVALID_COMPUTERNAME 1210
+CONSTANT: ERROR_INVALID_EVENTNAME 1211
+CONSTANT: ERROR_INVALID_DOMAINNAME 1212
+CONSTANT: ERROR_INVALID_SERVICENAME 1213
+CONSTANT: ERROR_INVALID_NETNAME 1214
+CONSTANT: ERROR_INVALID_SHARENAME 1215
+CONSTANT: ERROR_INVALID_PASSWORDNAME 1216
+CONSTANT: ERROR_INVALID_MESSAGENAME 1217
+CONSTANT: ERROR_INVALID_MESSAGEDEST 1218
+CONSTANT: ERROR_SESSION_CREDENTIAL_CONFLICT 1219
+CONSTANT: ERROR_REMOTE_SESSION_LIMIT_EXCEEDED 1220
+CONSTANT: ERROR_DUP_DOMAINNAME 1221
+CONSTANT: ERROR_NO_NETWORK 1222
+CONSTANT: ERROR_CANCELLED 1223
+CONSTANT: ERROR_USER_MAPPED_FILE 1224
+CONSTANT: ERROR_CONNECTION_REFUSED 1225
+CONSTANT: ERROR_GRACEFUL_DISCONNECT 1226
+CONSTANT: ERROR_ADDRESS_ALREADY_ASSOCIATED 1227
+CONSTANT: ERROR_ADDRESS_NOT_ASSOCIATED 1228
+CONSTANT: ERROR_CONNECTION_INVALID 1229
+CONSTANT: ERROR_CONNECTION_ACTIVE 1230
+CONSTANT: ERROR_NETWORK_UNREACHABLE 1231
+CONSTANT: ERROR_HOST_UNREACHABLE 1232
+CONSTANT: ERROR_PROTOCOL_UNREACHABLE 1233
+CONSTANT: ERROR_PORT_UNREACHABLE 1234
+CONSTANT: ERROR_REQUEST_ABORTED 1235
+CONSTANT: ERROR_CONNECTION_ABORTED 1236
+CONSTANT: ERROR_RETRY 1237
+CONSTANT: ERROR_CONNECTION_COUNT_LIMIT 1238
+CONSTANT: ERROR_LOGIN_TIME_RESTRICTION 1239
+CONSTANT: ERROR_LOGIN_WKSTA_RESTRICTION 1240
+CONSTANT: ERROR_INCORRECT_ADDRESS 1241
+CONSTANT: ERROR_ALREADY_REGISTERED 1242
+CONSTANT: ERROR_SERVICE_NOT_FOUND 1243
+CONSTANT: ERROR_NOT_AUTHENTICATED 1244
+CONSTANT: ERROR_NOT_LOGGED_ON 1245
+CONSTANT: ERROR_CONTINUE 1246
+CONSTANT: ERROR_ALREADY_INITIALIZED 1247
+CONSTANT: ERROR_NO_MORE_DEVICES 1248
+CONSTANT: ERROR_NOT_ALL_ASSIGNED 1300
+CONSTANT: ERROR_SOME_NOT_MAPPED 1301
+CONSTANT: ERROR_NO_QUOTAS_FOR_ACCOUNT 1302
+CONSTANT: ERROR_LOCAL_USER_SESSION_KEY 1303
+CONSTANT: ERROR_NULL_LM_PASSWORD 1304
+CONSTANT: ERROR_UNKNOWN_REVISION 1305
+CONSTANT: ERROR_REVISION_MISMATCH 1306
+CONSTANT: ERROR_INVALID_OWNER 1307
+CONSTANT: ERROR_INVALID_PRIMARY_GROUP 1308
+CONSTANT: ERROR_NO_IMPERSONATION_TOKEN 1309
+CONSTANT: ERROR_CANT_DISABLE_MANDATORY 1310
+CONSTANT: ERROR_NO_LOGON_SERVERS 1311
+CONSTANT: ERROR_NO_SUCH_LOGON_SESSION 1312
+CONSTANT: ERROR_NO_SUCH_PRIVILEGE 1313
+CONSTANT: ERROR_PRIVILEGE_NOT_HELD 1314
+CONSTANT: ERROR_INVALID_ACCOUNT_NAME 1315
+CONSTANT: ERROR_USER_EXISTS 1316
+CONSTANT: ERROR_NO_SUCH_USER 1317
+CONSTANT: ERROR_GROUP_EXISTS 1318
+CONSTANT: ERROR_NO_SUCH_GROUP 1319
+CONSTANT: ERROR_MEMBER_IN_GROUP 1320
+CONSTANT: ERROR_MEMBER_NOT_IN_GROUP 1321
+CONSTANT: ERROR_LAST_ADMIN 1322
+CONSTANT: ERROR_WRONG_PASSWORD 1323
+CONSTANT: ERROR_ILL_FORMED_PASSWORD 1324
+CONSTANT: ERROR_PASSWORD_RESTRICTION 1325
+CONSTANT: ERROR_LOGON_FAILURE 1326
+CONSTANT: ERROR_ACCOUNT_RESTRICTION 1327
+CONSTANT: ERROR_INVALID_LOGON_HOURS 1328
+CONSTANT: ERROR_INVALID_WORKSTATION 1329
+CONSTANT: ERROR_PASSWORD_EXPIRED 1330
+CONSTANT: ERROR_ACCOUNT_DISABLED 1331
+CONSTANT: ERROR_NONE_MAPPED 1332
+CONSTANT: ERROR_TOO_MANY_LUIDS_REQUESTED 1333
+CONSTANT: ERROR_LUIDS_EXHAUSTED 1334
+CONSTANT: ERROR_INVALID_SUB_AUTHORITY 1335
+CONSTANT: ERROR_INVALID_ACL 1336
+CONSTANT: ERROR_INVALID_SID 1337
+CONSTANT: ERROR_INVALID_SECURITY_DESCR 1338
+CONSTANT: ERROR_BAD_INHERITANCE_ACL 1340
+CONSTANT: ERROR_SERVER_DISABLED 1341
+CONSTANT: ERROR_SERVER_NOT_DISABLED 1342
+CONSTANT: ERROR_INVALID_ID_AUTHORITY 1343
+CONSTANT: ERROR_ALLOTTED_SPACE_EXCEEDED 1344
+CONSTANT: ERROR_INVALID_GROUP_ATTRIBUTES 1345
+CONSTANT: ERROR_BAD_IMPERSONATION_LEVEL 1346
+CONSTANT: ERROR_CANT_OPEN_ANONYMOUS 1347
+CONSTANT: ERROR_BAD_VALIDATION_CLASS 1348
+CONSTANT: ERROR_BAD_TOKEN_TYPE 1349
+CONSTANT: ERROR_NO_SECURITY_ON_OBJECT 1350
+CONSTANT: ERROR_CANT_ACCESS_DOMAIN_INFO 1351
+CONSTANT: ERROR_INVALID_SERVER_STATE 1352
+CONSTANT: ERROR_INVALID_DOMAIN_STATE 1353
+CONSTANT: ERROR_INVALID_DOMAIN_ROLE 1354
+CONSTANT: ERROR_NO_SUCH_DOMAIN 1355
+CONSTANT: ERROR_DOMAIN_EXISTS 1356
+CONSTANT: ERROR_DOMAIN_LIMIT_EXCEEDED 1357
+CONSTANT: ERROR_INTERNAL_DB_CORRUPTION 1358
+CONSTANT: ERROR_INTERNAL_ERROR 1359
+CONSTANT: ERROR_GENERIC_NOT_MAPPED 1360
+CONSTANT: ERROR_BAD_DESCRIPTOR_FORMAT 1361
+CONSTANT: ERROR_NOT_LOGON_PROCESS 1362
+CONSTANT: ERROR_LOGON_SESSION_EXISTS 1363
+CONSTANT: ERROR_NO_SUCH_PACKAGE 1364
+CONSTANT: ERROR_BAD_LOGON_SESSION_STATE 1365
+CONSTANT: ERROR_LOGON_SESSION_COLLISION 1366
+CONSTANT: ERROR_INVALID_LOGON_TYPE 1367
+CONSTANT: ERROR_CANNOT_IMPERSONATE 1368
+CONSTANT: ERROR_RXACT_INVALID_STATE 1369
+CONSTANT: ERROR_RXACT_COMMIT_FAILURE 1370
+CONSTANT: ERROR_SPECIAL_ACCOUNT 1371
+CONSTANT: ERROR_SPECIAL_GROUP 1372
+CONSTANT: ERROR_SPECIAL_USER 1373
+CONSTANT: ERROR_MEMBERS_PRIMARY_GROUP 1374
+CONSTANT: ERROR_TOKEN_ALREADY_IN_USE 1375
+CONSTANT: ERROR_NO_SUCH_ALIAS 1376
+CONSTANT: ERROR_MEMBER_NOT_IN_ALIAS 1377
+CONSTANT: ERROR_MEMBER_IN_ALIAS 1378
+CONSTANT: ERROR_ALIAS_EXISTS 1379
+CONSTANT: ERROR_LOGON_NOT_GRANTED 1380
+CONSTANT: ERROR_TOO_MANY_SECRETS 1381
+CONSTANT: ERROR_SECRET_TOO_LONG 1382
+CONSTANT: ERROR_INTERNAL_DB_ERROR 1383
+CONSTANT: ERROR_TOO_MANY_CONTEXT_IDS 1384
+CONSTANT: ERROR_LOGON_TYPE_NOT_GRANTED 1385
+CONSTANT: ERROR_NT_CROSS_ENCRYPTION_REQUIRED 1386
+CONSTANT: ERROR_NO_SUCH_MEMBER 1387
+CONSTANT: ERROR_INVALID_MEMBER 1388
+CONSTANT: ERROR_TOO_MANY_SIDS 1389
+CONSTANT: ERROR_LM_CROSS_ENCRYPTION_REQUIRED 1390
+CONSTANT: ERROR_NO_INHERITANCE 1391
+CONSTANT: ERROR_FILE_CORRUPT 1392
+CONSTANT: ERROR_DISK_CORRUPT 1393
+CONSTANT: ERROR_NO_USER_SESSION_KEY 1394
+CONSTANT: ERROR_LICENSE_QUOTA_EXCEEDED 1395
+CONSTANT: ERROR_INVALID_WINDOW_HANDLE 1400
+CONSTANT: ERROR_INVALID_MENU_HANDLE 1401
+CONSTANT: ERROR_INVALID_CURSOR_HANDLE 1402
+CONSTANT: ERROR_INVALID_ACCEL_HANDLE 1403
+CONSTANT: ERROR_INVALID_HOOK_HANDLE 1404
+CONSTANT: ERROR_INVALID_DWP_HANDLE 1405
+CONSTANT: ERROR_TLW_WITH_WSCHILD 1406
+CONSTANT: ERROR_CANNOT_FIND_WND_CLASS 1407
+CONSTANT: ERROR_WINDOW_OF_OTHER_THREAD 1408
+CONSTANT: ERROR_HOTKEY_ALREADY_REGISTERED 1409
+CONSTANT: ERROR_CLASS_ALREADY_EXISTS 1410
+CONSTANT: ERROR_CLASS_DOES_NOT_EXIST 1411
+CONSTANT: ERROR_CLASS_HAS_WINDOWS 1412
+CONSTANT: ERROR_INVALID_INDEX 1413
+CONSTANT: ERROR_INVALID_ICON_HANDLE 1414
+CONSTANT: ERROR_PRIVATE_DIALOG_INDEX 1415
+CONSTANT: ERROR_LISTBOX_ID_NOT_FOUND 1416
+CONSTANT: ERROR_NO_WILDCARD_CHARACTERS 1417
+CONSTANT: ERROR_CLIPBOARD_NOT_OPEN 1418
+CONSTANT: ERROR_HOTKEY_NOT_REGISTERED 1419
+CONSTANT: ERROR_WINDOW_NOT_DIALOG 1420
+CONSTANT: ERROR_CONTROL_ID_NOT_FOUND 1421
+CONSTANT: ERROR_INVALID_COMBOBOX_MESSAGE 1422
+CONSTANT: ERROR_WINDOW_NOT_COMBOBOX 1423
+CONSTANT: ERROR_INVALID_EDIT_HEIGHT 1424
+CONSTANT: ERROR_DC_NOT_FOUND 1425
+CONSTANT: ERROR_INVALID_HOOK_FILTER 1426
+CONSTANT: ERROR_INVALID_FILTER_PROC 1427
+CONSTANT: ERROR_HOOK_NEEDS_HMOD 1428
+CONSTANT: ERROR_GLOBAL_ONLY_HOOK 1429
+CONSTANT: ERROR_JOURNAL_HOOK_SET 1430
+CONSTANT: ERROR_HOOK_NOT_INSTALLED 1431
+CONSTANT: ERROR_INVALID_LB_MESSAGE 1432
+CONSTANT: ERROR_LB_WITHOUT_TABSTOPS 1434
+CONSTANT: ERROR_DESTROY_OBJECT_OF_OTHER_THREAD 1435
+CONSTANT: ERROR_CHILD_WINDOW_MENU 1436
+CONSTANT: ERROR_NO_SYSTEM_MENU 1437
+CONSTANT: ERROR_INVALID_MSGBOX_STYLE 1438
+CONSTANT: ERROR_INVALID_SPI_VALUE 1439
+CONSTANT: ERROR_SCREEN_ALREADY_LOCKED 1440
+CONSTANT: ERROR_HWNDS_HAVE_DIFF_PARENT 1441
+CONSTANT: ERROR_NOT_CHILD_WINDOW 1442
+CONSTANT: ERROR_INVALID_GW_COMMAND 1443
+CONSTANT: ERROR_INVALID_THREAD_ID 1444
+CONSTANT: ERROR_NON_MDICHILD_WINDOW 1445
+CONSTANT: ERROR_POPUP_ALREADY_ACTIVE 1446
+CONSTANT: ERROR_NO_SCROLLBARS 1447
+CONSTANT: ERROR_INVALID_SCROLLBAR_RANGE 1448
+CONSTANT: ERROR_INVALID_SHOWWIN_COMMAND 1449
+CONSTANT: ERROR_NO_SYSTEM_RESOURCES 1450
+CONSTANT: ERROR_NONPAGED_SYSTEM_RESOURCES 1451
+CONSTANT: ERROR_PAGED_SYSTEM_RESOURCES 1452
+CONSTANT: ERROR_WORKING_SET_QUOTA 1453
+CONSTANT: ERROR_PAGEFILE_QUOTA 1454
+CONSTANT: ERROR_COMMITMENT_LIMIT 1455
+CONSTANT: ERROR_MENU_ITEM_NOT_FOUND 1456
+CONSTANT: ERROR_INVALID_KEYBOARD_HANDLE 1457
+CONSTANT: ERROR_HOOK_TYPE_NOT_ALLOWED 1458
+CONSTANT: ERROR_REQUIRES_INTERACTIVE_WINDOWSTATION 1459
+CONSTANT: ERROR_TIMEOUT 1460
+CONSTANT: ERROR_EVENTLOG_FILE_CORRUPT 1500
+CONSTANT: ERROR_EVENTLOG_CANT_START 1501
+CONSTANT: ERROR_LOG_FILE_FULL 1502
+CONSTANT: ERROR_EVENTLOG_FILE_CHANGED 1503
+CONSTANT: RPC_S_INVALID_STRING_BINDING 1700
+CONSTANT: RPC_S_WRONG_KIND_OF_BINDING 1701
+CONSTANT: RPC_S_INVALID_BINDING 1702
+CONSTANT: RPC_S_PROTSEQ_NOT_SUPPORTED 1703
+CONSTANT: RPC_S_INVALID_RPC_PROTSEQ 1704
+CONSTANT: RPC_S_INVALID_STRING_UUID 1705
+CONSTANT: RPC_S_INVALID_ENDPOINT_FORMAT 1706
+CONSTANT: RPC_S_INVALID_NET_ADDR 1707
+CONSTANT: RPC_S_NO_ENDPOINT_FOUND 1708
+CONSTANT: RPC_S_INVALID_TIMEOUT 1709
+CONSTANT: RPC_S_OBJECT_NOT_FOUND 1710
+CONSTANT: RPC_S_ALREADY_REGISTERED 1711
+CONSTANT: RPC_S_TYPE_ALREADY_REGISTERED 1712
+CONSTANT: RPC_S_ALREADY_LISTENING 1713
+CONSTANT: RPC_S_NO_PROTSEQS_REGISTERED 1714
+CONSTANT: RPC_S_NOT_LISTENING 1715
+CONSTANT: RPC_S_UNKNOWN_MGR_TYPE 1716
+CONSTANT: RPC_S_UNKNOWN_IF 1717
+CONSTANT: RPC_S_NO_BINDINGS 1718
+CONSTANT: RPC_S_NO_PROTSEQS 1719
+CONSTANT: RPC_S_CANT_CREATE_ENDPOINT 1720
+CONSTANT: RPC_S_OUT_OF_RESOURCES 1721
+CONSTANT: RPC_S_SERVER_UNAVAILABLE 1722
+CONSTANT: RPC_S_SERVER_TOO_BUSY 1723
+CONSTANT: RPC_S_INVALID_NETWORK_OPTIONS 1724
+CONSTANT: RPC_S_NO_CALL_ACTIVE 1725
+CONSTANT: RPC_S_CALL_FAILED 1726
+CONSTANT: RPC_S_CALL_FAILED_DNE 1727
+CONSTANT: RPC_S_PROTOCOL_ERROR 1728
+CONSTANT: RPC_S_UNSUPPORTED_TRANS_SYN 1730
+CONSTANT: RPC_S_UNSUPPORTED_TYPE 1732
+CONSTANT: RPC_S_INVALID_TAG 1733
+CONSTANT: RPC_S_INVALID_BOUND 1734
+CONSTANT: RPC_S_NO_ENTRY_NAME 1735
+CONSTANT: RPC_S_INVALID_NAME_SYNTAX 1736
+CONSTANT: RPC_S_UNSUPPORTED_NAME_SYNTAX 1737
+CONSTANT: RPC_S_UUID_NO_ADDRESS 1739
+CONSTANT: RPC_S_DUPLICATE_ENDPOINT 1740
+CONSTANT: RPC_S_UNKNOWN_AUTHN_TYPE 1741
+CONSTANT: RPC_S_MAX_CALLS_TOO_SMALL 1742
+CONSTANT: RPC_S_STRING_TOO_LONG 1743
+CONSTANT: RPC_S_PROTSEQ_NOT_FOUND 1744
+CONSTANT: RPC_S_PROCNUM_OUT_OF_RANGE 1745
+CONSTANT: RPC_S_BINDING_HAS_NO_AUTH 1746
+CONSTANT: RPC_S_UNKNOWN_AUTHN_SERVICE 1747
+CONSTANT: RPC_S_UNKNOWN_AUTHN_LEVEL 1748
+CONSTANT: RPC_S_INVALID_AUTH_IDENTITY 1749
+CONSTANT: RPC_S_UNKNOWN_AUTHZ_SERVICE 1750
+CONSTANT: EPT_S_INVALID_ENTRY 1751
+CONSTANT: EPT_S_CANT_PERFORM_OP 1752
+CONSTANT: EPT_S_NOT_REGISTERED 1753
+CONSTANT: RPC_S_NOTHING_TO_EXPORT 1754
+CONSTANT: RPC_S_INCOMPLETE_NAME 1755
+CONSTANT: RPC_S_INVALID_VERS_OPTION 1756
+CONSTANT: RPC_S_NO_MORE_MEMBERS 1757
+CONSTANT: RPC_S_NOT_ALL_OBJS_UNEXPORTED 1758
+CONSTANT: RPC_S_INTERFACE_NOT_FOUND 1759
+CONSTANT: RPC_S_ENTRY_ALREADY_EXISTS 1760
+CONSTANT: RPC_S_ENTRY_NOT_FOUND 1761
+CONSTANT: RPC_S_NAME_SERVICE_UNAVAILABLE 1762
+CONSTANT: RPC_S_INVALID_NAF_ID 1763
+CONSTANT: RPC_S_CANNOT_SUPPORT 1764
+CONSTANT: RPC_S_NO_CONTEXT_AVAILABLE 1765
+CONSTANT: RPC_S_INTERNAL_ERROR 1766
+CONSTANT: RPC_S_ZERO_DIVIDE 1767
+CONSTANT: RPC_S_ADDRESS_ERROR 1768
+CONSTANT: RPC_S_FP_DIV_ZERO 1769
+CONSTANT: RPC_S_FP_UNDERFLOW 1770
+CONSTANT: RPC_S_FP_OVERFLOW 1771
+CONSTANT: RPC_X_NO_MORE_ENTRIES 1772
+CONSTANT: RPC_X_SS_CHAR_TRANS_OPEN_FAIL 1773
+CONSTANT: RPC_X_SS_CHAR_TRANS_SHORT_FILE 1774
+CONSTANT: RPC_X_SS_IN_NULL_CONTEXT 1775
+CONSTANT: RPC_X_SS_CONTEXT_DAMAGED 1777
+CONSTANT: RPC_X_SS_HANDLES_MISMATCH 1778
+CONSTANT: RPC_X_SS_CANNOT_GET_CALL_HANDLE 1779
+CONSTANT: RPC_X_NULL_REF_POINTER 1780
+CONSTANT: RPC_X_ENUM_VALUE_OUT_OF_RANGE 1781
+CONSTANT: RPC_X_BYTE_COUNT_TOO_SMALL 1782
+CONSTANT: RPC_X_BAD_STUB_DATA 1783
+CONSTANT: ERROR_INVALID_USER_BUFFER 1784
+CONSTANT: ERROR_UNRECOGNIZED_MEDIA 1785
+CONSTANT: ERROR_NO_TRUST_LSA_SECRET 1786
+CONSTANT: ERROR_NO_TRUST_SAM_ACCOUNT 1787
+CONSTANT: ERROR_TRUSTED_DOMAIN_FAILURE 1788
+CONSTANT: ERROR_TRUSTED_RELATIONSHIP_FAILURE 1789
+CONSTANT: ERROR_TRUST_FAILURE 1790
+CONSTANT: RPC_S_CALL_IN_PROGRESS 1791
+CONSTANT: ERROR_NETLOGON_NOT_STARTED 1792
+CONSTANT: ERROR_ACCOUNT_EXPIRED 1793
+CONSTANT: ERROR_REDIRECTOR_HAS_OPEN_HANDLES 1794
+CONSTANT: ERROR_PRINTER_DRIVER_ALREADY_INSTALLED 1795
+CONSTANT: ERROR_UNKNOWN_PORT 1796
+CONSTANT: ERROR_UNKNOWN_PRINTER_DRIVER 1797
+CONSTANT: ERROR_UNKNOWN_PRINTPROCESSOR 1798
+CONSTANT: ERROR_INVALID_SEPARATOR_FILE 1799
+CONSTANT: ERROR_INVALID_PRIORITY 1800
+CONSTANT: ERROR_INVALID_PRINTER_NAME 1801
+CONSTANT: ERROR_PRINTER_ALREADY_EXISTS 1802
+CONSTANT: ERROR_INVALID_PRINTER_COMMAND 1803
+CONSTANT: ERROR_INVALID_DATATYPE 1804
+CONSTANT: ERROR_INVALID_ENVIRONMENT 1805
+CONSTANT: RPC_S_NO_MORE_BINDINGS 1806
+CONSTANT: ERROR_NOLOGON_INTERDOMAIN_TRUST_ACCOUNT 1807
+CONSTANT: ERROR_NOLOGON_WORKSTATION_TRUST_ACCOUNT 1808
+CONSTANT: ERROR_NOLOGON_SERVER_TRUST_ACCOUNT 1809
+CONSTANT: ERROR_DOMAIN_TRUST_INCONSISTENT 1810
+CONSTANT: ERROR_SERVER_HAS_OPEN_HANDLES 1811
+CONSTANT: ERROR_RESOURCE_DATA_NOT_FOUND 1812
+CONSTANT: ERROR_RESOURCE_TYPE_NOT_FOUND 1813
+CONSTANT: ERROR_RESOURCE_NAME_NOT_FOUND 1814
+CONSTANT: ERROR_RESOURCE_LANG_NOT_FOUND 1815
+CONSTANT: ERROR_NOT_ENOUGH_QUOTA 1816
+CONSTANT: RPC_S_NO_INTERFACES 1817
+CONSTANT: RPC_S_CALL_CANCELLED 1818
+CONSTANT: RPC_S_BINDING_INCOMPLETE 1819
+CONSTANT: RPC_S_COMM_FAILURE 1820
+CONSTANT: RPC_S_UNSUPPORTED_AUTHN_LEVEL 1821
+CONSTANT: RPC_S_NO_PRINC_NAME 1822
+CONSTANT: RPC_S_NOT_RPC_ERROR 1823
+CONSTANT: RPC_S_UUID_LOCAL_ONLY 1824
+CONSTANT: RPC_S_SEC_PKG_ERROR 1825
+CONSTANT: RPC_S_NOT_CANCELLED 1826
+CONSTANT: RPC_X_INVALID_ES_ACTION 1827
+CONSTANT: RPC_X_WRONG_ES_VERSION 1828
+CONSTANT: RPC_X_WRONG_STUB_VERSION 1829
+CONSTANT: RPC_X_INVALID_PIPE_OBJECT 1830
+CONSTANT: RPC_X_INVALID_PIPE_OPERATION 1831
+CONSTANT: RPC_X_WRONG_PIPE_VERSION 1832
+CONSTANT: RPC_S_GROUP_MEMBER_NOT_FOUND 1898
+CONSTANT: EPT_S_CANT_CREATE 1899
+CONSTANT: RPC_S_INVALID_OBJECT 1900
+CONSTANT: ERROR_INVALID_TIME 1901
+CONSTANT: ERROR_INVALID_FORM_NAME 1902
+CONSTANT: ERROR_INVALID_FORM_SIZE 1903
+CONSTANT: ERROR_ALREADY_WAITING 1904
+CONSTANT: ERROR_PRINTER_DELETED 1905
+CONSTANT: ERROR_INVALID_PRINTER_STATE 1906
+CONSTANT: ERROR_PASSWORD_MUST_CHANGE 1907
+CONSTANT: ERROR_DOMAIN_CONTROLLER_NOT_FOUND 1908
+CONSTANT: ERROR_ACCOUNT_LOCKED_OUT 1909
+CONSTANT: OR_INVALID_OXID 1910
+CONSTANT: OR_INVALID_OID 1911
+CONSTANT: OR_INVALID_SET 1912
+CONSTANT: RPC_S_SEND_INCOMPLETE 1913
+CONSTANT: ERROR_INVALID_PIXEL_FORMAT 2000
+CONSTANT: ERROR_BAD_DRIVER 2001
+CONSTANT: ERROR_INVALID_WINDOW_STYLE 2002
+CONSTANT: ERROR_METAFILE_NOT_SUPPORTED 2003
+CONSTANT: ERROR_TRANSFORM_NOT_SUPPORTED 2004
+CONSTANT: ERROR_CLIPPING_NOT_SUPPORTED 2005
+CONSTANT: ERROR_BAD_USERNAME 2202
+CONSTANT: ERROR_NOT_CONNECTED 2250
+CONSTANT: ERROR_OPEN_FILES 2401
+CONSTANT: ERROR_ACTIVE_CONNECTIONS 2402
+CONSTANT: ERROR_DEVICE_IN_USE 2404
+CONSTANT: ERROR_UNKNOWN_PRINT_MONITOR 3000
+CONSTANT: ERROR_PRINTER_DRIVER_IN_USE 3001
+CONSTANT: ERROR_SPOOL_FILE_NOT_FOUND 3002
+CONSTANT: ERROR_SPL_NO_STARTDOC 3003
+CONSTANT: ERROR_SPL_NO_ADDJOB 3004
+CONSTANT: ERROR_PRINT_PROCESSOR_ALREADY_INSTALLED 3005
+CONSTANT: ERROR_PRINT_MONITOR_ALREADY_INSTALLED 3006
+CONSTANT: ERROR_INVALID_PRINT_MONITOR 3007
+CONSTANT: ERROR_PRINT_MONITOR_IN_USE 3008
+CONSTANT: ERROR_PRINTER_HAS_JOBS_QUEUED 3009
+CONSTANT: ERROR_SUCCESS_REBOOT_REQUIRED 3010
+CONSTANT: ERROR_SUCCESS_RESTART_REQUIRED 3011
+CONSTANT: ERROR_WINS_INTERNAL 4000
+CONSTANT: ERROR_CAN_NOT_DEL_LOCAL_WINS 4001
+CONSTANT: ERROR_STATIC_INIT 4002
+CONSTANT: ERROR_INC_BACKUP 4003
+CONSTANT: ERROR_FULL_BACKUP 4004
+CONSTANT: ERROR_REC_NON_EXISTENT 4005
+CONSTANT: ERROR_RPL_NOT_ALLOWED 4006
+CONSTANT: ERROR_NO_BROWSER_SERVERS_FOUND 6118
+
+CONSTANT: SUBLANG_NEUTRAL 0
+CONSTANT: LANG_NEUTRAL 0
+CONSTANT: SUBLANG_DEFAULT 1
+
+CONSTANT: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100
+CONSTANT: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200
+CONSTANT: FORMAT_MESSAGE_FROM_STRING HEX: 00000400
+CONSTANT: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800
+CONSTANT: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000
+CONSTANT: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000
+CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF
+
+: make-lang-id ( lang1 lang2 -- n )
+ 10 shift bitor ; inline
+
+ERROR: error-message-failed id ;
+:: n>win32-error-string ( id -- string )
+ {
+ FORMAT_MESSAGE_FROM_SYSTEM
+ FORMAT_MESSAGE_ARGUMENT_ARRAY
+ } flags
+ f
+ id
+ LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
+ 32768 [ "TCHAR" <c-array> ] keep
+ f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
+ utf16n alien>string [ blank? ] trim ;
+
+: win32-error-string ( -- str )
+ GetLastError n>win32-error-string ;
+
+: (win32-error) ( n -- )
+ dup zero? [
+ drop
+ ] [
+ win32-error-string throw
+ ] if ;
+
+: win32-error ( -- )
+ GetLastError (win32-error) ;
+
+: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ;
+: win32-error>0 ( n -- ) 0 > [ win32-error ] when ;
+: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
+: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
+
+: invalid-handle? ( handle -- )
+ INVALID_HANDLE_VALUE = [
+ win32-error-string throw
+ ] when ;
+
+CONSTANT: expected-io-errors
+ ${
+ ERROR_SUCCESS
+ ERROR_IO_INCOMPLETE
+ ERROR_IO_PENDING
+ WAIT_TIMEOUT
+ }
+
+: expected-io-error? ( error-code -- ? )
+ expected-io-errors member? ;
+
+: expected-io-error ( error-code -- )
+ dup expected-io-error? [
+ drop
+ ] [
+ win32-error-string throw
+ ] if ;
+
+: io-error ( return-value -- )
+ { 0 f } member? [ GetLastError expected-io-error ] when ;
diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor
index a034856b34..1753ff1ce1 100755
--- a/basis/windows/fonts/fonts.factor
+++ b/basis/windows/fonts/fonts.factor
@@ -1,5 +1,5 @@
USING: assocs memoize locals kernel accessors init fonts math
-combinators windows windows.types windows.gdi32 ;
+combinators windows.errors windows.types windows.gdi32 ;
IN: windows.fonts
: windows-font-name ( string -- string' )
diff --git a/basis/windows/fonts/tags.txt b/basis/windows/fonts/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/windows/fonts/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor
index 794aa0e32e..0699c92be3 100755
--- a/basis/windows/gdi32/gdi32.factor
+++ b/basis/windows/gdi32/gdi32.factor
@@ -1419,7 +1419,7 @@ DESTRUCTOR: DeleteDC
! FUNCTION: DeleteMetaFile
FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
DESTRUCTOR: DeleteObject
-! FUNCTION: DescribePixelFormat
+FUNCTION: int DescribePixelFormat ( HDC hdc, int iPixelFormat, UINT nBytes, PIXELFORMATDESCRIPTOR* ppfd ) ;
! FUNCTION: DeviceCapabilitiesExA
! FUNCTION: DeviceCapabilitiesExW
! FUNCTION: DPtoLP
@@ -1501,7 +1501,6 @@ DESTRUCTOR: DeleteObject
FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
ALIAS: ExtTextOut ExtTextOutW
! FUNCTION: FillPath
-FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
! FUNCTION: FillRgn
! FUNCTION: FixBrushOrgEx
! FUNCTION: FlattenPath
diff --git a/basis/windows/gdi32/tags.txt b/basis/windows/gdi32/tags.txt
index 6bf68304bb..2320bdd648 100644
--- a/basis/windows/gdi32/tags.txt
+++ b/basis/windows/gdi32/tags.txt
@@ -1 +1,2 @@
unportable
+bindings
diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor
index 36acc5e346..e654b68bdc 100755
--- a/basis/windows/kernel32/kernel32.factor
+++ b/basis/windows/kernel32/kernel32.factor
@@ -1110,7 +1110,19 @@ FUNCTION: BOOL FindVolumeMountPointClose ( HANDLE hFindVolumeMountPoint ) ;
! FUNCTION: FoldStringA
! FUNCTION: FoldStringW
! FUNCTION: FormatMessageA
-! FUNCTION: FormatMessageW
+FUNCTION: DWORD FormatMessageW (
+ DWORD dwFlags,
+ LPCVOID lpSource,
+ DWORD dwMessageId,
+ DWORD dwLanguageId,
+ LPTSTR lpBuffer,
+ DWORD nSize,
+ void* Arguments
+ ) ;
+
+ALIAS: FormatMessage FormatMessageW
+
+
FUNCTION: BOOL FreeConsole ( ) ;
! FUNCTION: FreeEnvironmentStringsA
FUNCTION: BOOL FreeEnvironmentStringsW ( LPTCH lpszEnvironmentBlock ) ;
@@ -1139,7 +1151,8 @@ FUNCTION: BOOL GetCommState ( HANDLE hFile, LPDCB lpDCB ) ;
! FUNCTION: GetCommTimeouts
! FUNCTION: GetComPlusPackageInstallStatus
! FUNCTION: GetCompressedFileSizeA
-! FUNCTION: GetCompressedFileSizeW
+FUNCTION: DWORD GetCompressedFileSizeW ( LPCTSTR lpFileName, LPDWORD lpFileSizeHigh ) ;
+ALIAS: GetCompressedFileSize GetCompressedFileSizeW
FUNCTION: BOOL GetComputerNameW ( LPTSTR lpBuffer, LPDWORD lpnSize ) ;
ALIAS: GetComputerName GetComputerNameW
FUNCTION: BOOL GetComputerNameExW ( COMPUTER_NAME_FORMAT NameType, LPTSTR lpBuffer, LPDWORD lpnSize ) ;
@@ -1477,7 +1490,7 @@ ALIAS: LoadLibraryEx LoadLibraryExW
! FUNCTION: LoadLibraryW
! FUNCTION: LoadModule
! FUNCTION: LoadResource
-! FUNCTION: LocalAlloc
+FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ;
! FUNCTION: LocalCompact
! FUNCTION: LocalFileTimeToFileTime
! FUNCTION: LocalFlags
diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor
index e69a9213b0..864700cb0f 100755
--- a/basis/windows/ole32/ole32.factor
+++ b/basis/windows/ole32/ole32.factor
@@ -1,6 +1,6 @@
USING: alien alien.syntax alien.c-types alien.strings math
-kernel sequences windows windows.types debugger io accessors
-math.order namespaces make math.parser windows.kernel32
+kernel sequences windows.errors windows.types debugger io
+accessors math.order namespaces make math.parser windows.kernel32
combinators locals specialized-arrays.direct.uchar ;
IN: windows.ole32
@@ -120,7 +120,7 @@ TUPLE: ole32-error error-code ;
C: <ole32-error> ole32-error
M: ole32-error error.
- "COM method failed: " print error-code>> (win32-error-string) print ;
+ "COM method failed: " print error-code>> n>win32-error-string print ;
: ole32-error ( hresult -- )
dup succeeded? [ drop ] [ <ole32-error> throw ] if ;
diff --git a/basis/windows/opengl32/opengl32.factor b/basis/windows/opengl32/opengl32.factor
index d0b396eba2..4173332dc3 100755
--- a/basis/windows/opengl32/opengl32.factor
+++ b/basis/windows/opengl32/opengl32.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax parser namespaces kernel
-math math.bitwise windows.types windows.types init assocs
-sequences libc ;
+math math.bitwise windows.types init assocs splitting
+sequences libc opengl.gl opengl.gl.extensions opengl.gl.windows ;
IN: windows.opengl32
! PIXELFORMATDESCRIPTOR flags
@@ -71,22 +71,6 @@ CONSTANT: WGL_SWAP_UNDERLAY13 HEX: 10000000
CONSTANT: WGL_SWAP_UNDERLAY14 HEX: 20000000
CONSTANT: WGL_SWAP_UNDERLAY15 HEX: 40000000
-: windowed-pfd-dwFlags ( -- n )
- { PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ;
-: offscreen-pfd-dwFlags ( -- n )
- { PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL } flags ;
-
-! TODO: compare to http://www.nullterminator.net/opengl32.html
-: make-pfd ( flags bits -- pfd )
- "PIXELFORMATDESCRIPTOR" <c-object>
- "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
- 1 over set-PIXELFORMATDESCRIPTOR-nVersion
- rot over set-PIXELFORMATDESCRIPTOR-dwFlags
- PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
- [ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep
- 16 over set-PIXELFORMATDESCRIPTOR-cDepthBits
- PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask ;
-
LIBRARY: gl
@@ -100,5 +84,112 @@ LIBRARY: gl
FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ;
FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ;
FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ;
-FUNCTION: HGLRC wglGetCurrentContext ( ) ;
-FUNCTION: void* wglGetProcAddress ( char* name ) ;
+
+! WGL_ARB_extensions_string extension
+
+GL-FUNCTION: char* wglGetExtensionsStringARB { } ( HDC hDC ) ;
+
+! WGL_ARB_pixel_format extension
+
+CONSTANT: WGL_NUMBER_PIXEL_FORMATS_ARB HEX: 2000
+CONSTANT: WGL_DRAW_TO_WINDOW_ARB HEX: 2001
+CONSTANT: WGL_DRAW_TO_BITMAP_ARB HEX: 2002
+CONSTANT: WGL_ACCELERATION_ARB HEX: 2003
+CONSTANT: WGL_NEED_PALETTE_ARB HEX: 2004
+CONSTANT: WGL_NEED_SYSTEM_PALETTE_ARB HEX: 2005
+CONSTANT: WGL_SWAP_LAYER_BUFFERS_ARB HEX: 2006
+CONSTANT: WGL_SWAP_METHOD_ARB HEX: 2007
+CONSTANT: WGL_NUMBER_OVERLAYS_ARB HEX: 2008
+CONSTANT: WGL_NUMBER_UNDERLAYS_ARB HEX: 2009
+CONSTANT: WGL_TRANSPARENT_ARB HEX: 200A
+CONSTANT: WGL_TRANSPARENT_RED_VALUE_ARB HEX: 2037
+CONSTANT: WGL_TRANSPARENT_GREEN_VALUE_ARB HEX: 2038
+CONSTANT: WGL_TRANSPARENT_BLUE_VALUE_ARB HEX: 2039
+CONSTANT: WGL_TRANSPARENT_ALPHA_VALUE_ARB HEX: 203A
+CONSTANT: WGL_TRANSPARENT_INDEX_VALUE_ARB HEX: 203B
+CONSTANT: WGL_SHARE_DEPTH_ARB HEX: 200C
+CONSTANT: WGL_SHARE_STENCIL_ARB HEX: 200D
+CONSTANT: WGL_SHARE_ACCUM_ARB HEX: 200E
+CONSTANT: WGL_SUPPORT_GDI_ARB HEX: 200F
+CONSTANT: WGL_SUPPORT_OPENGL_ARB HEX: 2010
+CONSTANT: WGL_DOUBLE_BUFFER_ARB HEX: 2011
+CONSTANT: WGL_STEREO_ARB HEX: 2012
+CONSTANT: WGL_PIXEL_TYPE_ARB HEX: 2013
+CONSTANT: WGL_COLOR_BITS_ARB HEX: 2014
+CONSTANT: WGL_RED_BITS_ARB HEX: 2015
+CONSTANT: WGL_RED_SHIFT_ARB HEX: 2016
+CONSTANT: WGL_GREEN_BITS_ARB HEX: 2017
+CONSTANT: WGL_GREEN_SHIFT_ARB HEX: 2018
+CONSTANT: WGL_BLUE_BITS_ARB HEX: 2019
+CONSTANT: WGL_BLUE_SHIFT_ARB HEX: 201A
+CONSTANT: WGL_ALPHA_BITS_ARB HEX: 201B
+CONSTANT: WGL_ALPHA_SHIFT_ARB HEX: 201C
+CONSTANT: WGL_ACCUM_BITS_ARB HEX: 201D
+CONSTANT: WGL_ACCUM_RED_BITS_ARB HEX: 201E
+CONSTANT: WGL_ACCUM_GREEN_BITS_ARB HEX: 201F
+CONSTANT: WGL_ACCUM_BLUE_BITS_ARB HEX: 2020
+CONSTANT: WGL_ACCUM_ALPHA_BITS_ARB HEX: 2021
+CONSTANT: WGL_DEPTH_BITS_ARB HEX: 2022
+CONSTANT: WGL_STENCIL_BITS_ARB HEX: 2023
+CONSTANT: WGL_AUX_BUFFERS_ARB HEX: 2024
+
+CONSTANT: WGL_NO_ACCELERATION_ARB HEX: 2025
+CONSTANT: WGL_GENERIC_ACCELERATION_ARB HEX: 2026
+CONSTANT: WGL_FULL_ACCELERATION_ARB HEX: 2027
+
+CONSTANT: WGL_SWAP_EXCHANGE_ARB HEX: 2028
+CONSTANT: WGL_SWAP_COPY_ARB HEX: 2029
+CONSTANT: WGL_SWAP_UNDEFINED_ARB HEX: 202A
+
+CONSTANT: WGL_TYPE_RGBA_ARB HEX: 202B
+CONSTANT: WGL_TYPE_COLORINDEX_ARB HEX: 202C
+
+GL-FUNCTION: BOOL wglGetPixelFormatAttribivARB { } (
+ HDC hdc,
+ int iPixelFormat,
+ int iLayerPlane,
+ UINT nAttributes,
+ int* piAttributes,
+ int* piValues
+ ) ;
+
+GL-FUNCTION: BOOL wglGetPixelFormatAttribfvARB { } (
+ HDC hdc,
+ int iPixelFormat,
+ int iLayerPlane,
+ UINT nAttributes,
+ int* piAttributes,
+ FLOAT* pfValues
+ ) ;
+
+GL-FUNCTION: BOOL wglChoosePixelFormatARB { } (
+ HDC hdc,
+ int* piAttribIList,
+ FLOAT* pfAttribFList,
+ UINT nMaxFormats,
+ int* piFormats,
+ UINT* nNumFormats
+ ) ;
+
+! WGL_ARB_multisample extension
+
+CONSTANT: WGL_SAMPLE_BUFFERS_ARB HEX: 2041
+CONSTANT: WGL_SAMPLES_ARB HEX: 2042
+
+! WGL_ARB_pixel_format_float extension
+
+CONSTANT: WGL_TYPE_RGBA_FLOAT_ARB HEX: 21A0
+
+! wgl extensions querying
+
+: has-wglGetExtensionsStringARB? ( -- ? )
+ "wglGetExtensionsStringARB" wglGetProcAddress >boolean ;
+
+: wgl-extensions ( hdc -- extensions )
+ has-wglGetExtensionsStringARB? [ wglGetExtensionsStringARB " " split ] [ drop { } ] if ;
+
+: has-wgl-extensions? ( hdc extensions -- ? )
+ swap wgl-extensions [ member? ] curry all? ;
+
+: has-wgl-pixel-format-extension? ( hdc -- ? )
+ { "WGL_ARB_pixel_format" } has-wgl-extensions? ;
diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor
index 7802ceb297..016f5ab149 100644
--- a/basis/windows/shell32/shell32.factor
+++ b/basis/windows/shell32/shell32.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax
combinators io.encodings.utf16n io.files io.pathnames kernel
-windows windows.com windows.com.syntax windows.user32
-windows.ole32 ;
+windows.errors windows.com windows.com.syntax windows.user32
+windows.ole32 windows ;
IN: windows.shell32
CONSTANT: CSIDL_DESKTOP HEX: 00
diff --git a/basis/windows/time/time.factor b/basis/windows/time/time.factor
index e63834d369..71726a554a 100644
--- a/basis/windows/time/time.factor
+++ b/basis/windows/time/time.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types kernel math windows windows.kernel32
-namespaces calendar math.bitwise ;
+USING: alien alien.c-types kernel math windows.errors
+windows.kernel32 namespaces calendar math.bitwise ;
IN: windows.time
: >64bit ( lo hi -- n )
- 32 shift bitor ;
+ 32 shift bitor ; inline
: windows-1601 ( -- timestamp )
1601 1 1 0 0 0 instant <timestamp> ;
diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor
index 20bae06f30..062196c3f8 100755
--- a/basis/windows/types/types.factor
+++ b/basis/windows/types/types.factor
@@ -100,7 +100,7 @@ TYPEDEF: HANDLE HGDIOBJ
TYPEDEF: HANDLE HGLOBAL
TYPEDEF: HANDLE HHOOK
TYPEDEF: HANDLE HINSTANCE
-TYPEDEF: HANDLE HKEY
+TYPEDEF: DWORD HKEY
TYPEDEF: HANDLE HKL
TYPEDEF: HANDLE HLOCAL
TYPEDEF: HANDLE HMENU
diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
index 53d2d9918f..feb0bef7a8 100755
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math sequences fry io.encodings.string
-io.encodings.utf16n accessors arrays combinators destructors locals
-cache namespaces init images.normalization fonts alien.c-types
-windows windows.usp10 windows.offscreen windows.gdi32
-windows.ole32 windows.types windows.fonts opengl.textures ;
+io.encodings.utf16n accessors arrays combinators destructors
+cache namespaces init fonts alien.c-types windows.usp10
+windows.offscreen windows.gdi32 windows.ole32 windows.types
+windows.fonts opengl.textures locals windows.errors ;
IN: windows.uniscribe
TUPLE: script-string font string metrics ssa size image disposed ;
@@ -59,10 +59,10 @@ TUPLE: script-string font string metrics ssa size image disposed ;
ssa>> ! ssa
0 ! iX
0 ! iY
- 0 ! uOptions
- f ! prc
+ ETO_OPAQUE ! uOptions
]
- [ selection-start/end ] bi
+ [ [ { 0 0 } ] dip size>> <RECT> ]
+ [ selection-start/end ] tri
! iMinSel
! iMaxSel
FALSE ! fDisabled
@@ -71,11 +71,8 @@ TUPLE: script-string font string metrics ssa size image disposed ;
: draw-script-string ( dc script-string -- )
[ font>> set-dc-colors ] keep (draw-script-string) ;
-: script-string-bitmap-size ( script-string -- dim )
- size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
-
:: make-script-string-image ( dc script-string -- image )
- script-string script-string-bitmap-size dc
+ script-string size>> dc
[ dc script-string draw-script-string ] make-bitmap-image ;
: set-dc-font ( dc font -- )
@@ -111,8 +108,8 @@ M: script-string dispose*
SYMBOL: cached-script-strings
-: cached-script-string ( string font -- script-string )
+: cached-script-string ( font string -- script-string )
cached-script-strings get-global [ <script-string> ] 2cache ;
[ <cache-assoc> cached-script-strings set-global ]
-"windows.uniscribe" add-init-hook
\ No newline at end of file
+"windows.uniscribe" add-init-hook
diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor
index 9daac21697..1e694bcbe4 100644
--- a/basis/windows/user32/user32.factor
+++ b/basis/windows/user32/user32.factor
@@ -542,12 +542,46 @@ C-STRUCT: DEV_BROADCAST_HDR
{ "DWORD" "dbch_size" }
{ "DWORD" "dbch_devicetype" }
{ "DWORD" "dbch_reserved" } ;
+
C-STRUCT: DEV_BROADCAST_DEVICEW
{ "DWORD" "dbcc_size" }
{ "DWORD" "dbcc_devicetype" }
{ "DWORD" "dbcc_reserved" }
{ "GUID" "dbcc_classguid" }
- { "WCHAR[1]" "dbcc_name" } ;
+ { { "WCHAR" 1 } "dbcc_name" } ;
+
+CONSTANT: CCHDEVICENAME 32
+
+C-STRUCT: MONITORINFOEX
+ { "DWORD" "cbSize" }
+ { "RECT" "rcMonitor" }
+ { "RECT" "rcWork" }
+ { "DWORD" "dwFlags" }
+ { { "TCHAR" CCHDEVICENAME } "szDevice" } ;
+
+TYPEDEF: MONITORINFOEX* LPMONITORINFOEX
+TYPEDEF: MONITORINFOEX* LPMONITORINFO
+
+CONSTANT: MONITOR_DEFAULTTONULL 0
+CONSTANT: MONITOR_DEFAULTTOPRIMARY 1
+CONSTANT: MONITOR_DEFAULTTONEAREST 2
+CONSTANT: MONITORINFOF_PRIMARY 1
+CONSTANT: SWP_NOSIZE 1
+CONSTANT: SWP_NOMOVE 2
+CONSTANT: SWP_NOZORDER 4
+CONSTANT: SWP_NOREDRAW 8
+CONSTANT: SWP_NOACTIVATE 16
+CONSTANT: SWP_FRAMECHANGED 32
+CONSTANT: SWP_SHOWWINDOW 64
+CONSTANT: SWP_HIDEWINDOW 128
+CONSTANT: SWP_NOCOPYBITS 256
+CONSTANT: SWP_NOOWNERZORDER 512
+CONSTANT: SWP_NOSENDCHANGING 1024
+CONSTANT: SWP_DRAWFRAME SWP_FRAMECHANGED
+CONSTANT: SWP_NOREPOSITION SWP_NOOWNERZORDER
+CONSTANT: SWP_DEFERERASE 8192
+CONSTANT: SWP_ASYNCWINDOWPOS 16384
+
LIBRARY: user32
@@ -807,7 +841,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ;
! FUNCTION: EqualRect
! FUNCTION: ExcludeUpdateRgn
! FUNCTION: ExitWindowsEx
-! FUNCTION: FillRect
+FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ;
FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ;
! FUNCTION: FindWindowExW
@@ -910,7 +944,10 @@ ALIAS: GetMessage GetMessageW
! FUNCTION: GetMessagePos
! FUNCTION: GetMessageTime
! FUNCTION: GetMonitorInfoA
-! FUNCTION: GetMonitorInfoW
+
+FUNCTION: BOOL GetMonitorInfoW ( HMONITOR hMonitor, LPMONITORINFO lpmi ) ;
+ALIAS: GetMonitorInfo GetMonitorInfoW
+
! FUNCTION: GetMouseMovePointsEx
! FUNCTION: GetNextDlgGroupItem
! FUNCTION: GetNextDlgTabItem
@@ -961,6 +998,8 @@ FUNCTION: HWND GetWindow ( HWND hWnd, UINT uCmd ) ;
! FUNCTION: GetWindowInfo
! FUNCTION: GetWindowLongA
! FUNCTION: GetWindowLongW
+FUNCTION: LONG_PTR GetWindowLongW ( HANDLE hWnd, int index ) ;
+ALIAS: GetWindowLong GetWindowLongW
! FUNCTION: GetWindowModuleFileName
! FUNCTION: GetWindowModuleFileNameA
! FUNCTION: GetWindowModuleFileNameW
@@ -1127,7 +1166,7 @@ ALIAS: MessageBoxEx MessageBoxExW
! FUNCTION: ModifyMenuW
! FUNCTION: MonitorFromPoint
! FUNCTION: MonitorFromRect
-! FUNCTION: MonitorFromWindow
+FUNCTION: HMONITOR MonitorFromWindow ( HWND hWnd, DWORD dwFlags ) ;
! FUNCTION: mouse_event
@@ -1303,12 +1342,14 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
! FUNCTION: SetWindowContextHelpId
! FUNCTION: SetWindowLongA
! FUNCTION: SetWindowLongW
+FUNCTION: LONG_PTR SetWindowLongW ( HANDLE hWnd, int index, LONG_PTR dwNewLong ) ;
+ALIAS: SetWindowLong SetWindowLongW
! FUNCTION: SetWindowPlacement
FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
: HWND_BOTTOM ( -- alien ) 1 <alien> ;
: HWND_NOTOPMOST ( -- alien ) -2 <alien> ;
-: HWND_TOP ( -- alien ) 0 <alien> ;
+CONSTANT: HWND_TOP f
: HWND_TOPMOST ( -- alien ) -1 <alien> ;
! FUNCTION: SetWindowRgn
diff --git a/basis/windows/usp10/tags.txt b/basis/windows/usp10/tags.txt
new file mode 100644
index 0000000000..2320bdd648
--- /dev/null
+++ b/basis/windows/usp10/tags.txt
@@ -0,0 +1,2 @@
+unportable
+bindings
diff --git a/basis/windows/windows.factor b/basis/windows/windows.factor
index 902b1bec8d..92ba8b638a 100755
--- a/basis/windows/windows.factor
+++ b/basis/windows/windows.factor
@@ -1,61 +1,5 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax alien.c-types alien.strings arrays
-combinators kernel math namespaces parser sequences
-windows.errors windows.types windows.kernel32 words
-io.encodings.utf16n ;
IN: windows
-: lo-word ( wparam -- lo ) <short> *short ; inline
-: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
CONSTANT: MAX_UNICODE_PATH 32768
-
-! You must LocalFree the return value!
-FUNCTION: void* error_message ( DWORD id ) ;
-
-: (win32-error-string) ( n -- string )
- error_message
- dup utf16n alien>string
- swap LocalFree drop ;
-
-: win32-error-string ( -- str )
- GetLastError (win32-error-string) ;
-
-: (win32-error) ( n -- )
- dup zero? [
- drop
- ] [
- win32-error-string throw
- ] if ;
-
-: win32-error ( -- )
- GetLastError (win32-error) ;
-
-: win32-error=0/f ( n -- ) { 0 f } member? [ win32-error ] when ;
-: win32-error>0 ( n -- ) 0 > [ win32-error ] when ;
-: win32-error<0 ( n -- ) 0 < [ win32-error ] when ;
-: win32-error<>0 ( n -- ) zero? [ win32-error ] unless ;
-
-: invalid-handle? ( handle -- )
- INVALID_HANDLE_VALUE = [
- win32-error-string throw
- ] when ;
-
-: expected-io-errors ( -- seq )
- ERROR_SUCCESS
- ERROR_IO_INCOMPLETE
- ERROR_IO_PENDING
- WAIT_TIMEOUT 4array ; foldable
-
-: expected-io-error? ( error-code -- ? )
- expected-io-errors member? ;
-
-: expected-io-error ( error-code -- )
- dup expected-io-error? [
- drop
- ] [
- (win32-error-string) throw
- ] if ;
-
-: io-error ( return-value -- )
- { 0 f } member? [ GetLastError expected-io-error ] when ;
diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor
index 06df74cd4c..f0d32588f5 100755
--- a/basis/windows/winsock/winsock.factor
+++ b/basis/windows/winsock/winsock.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors windows math.bitwise io.encodings.utf16n ;
+windows.errors math.bitwise io.encodings.utf16n ;
IN: windows.winsock
USE: libc
@@ -403,7 +403,7 @@ CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
: (winsock-error-string) ( n -- str )
! #! WSAStartup returns the error code 'n' directly
dup winsock-expected-error?
- [ drop f ] [ error_message utf16n alien>string ] if ;
+ [ drop f ] [ n>win32-error-string ] if ;
: winsock-error-string ( -- string/f )
WSAGetLastError (winsock-error-string) ;
diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor
index e66572dc1b..07f42caae3 100644
--- a/basis/wrap/strings/strings-tests.factor
+++ b/basis/wrap/strings/strings-tests.factor
@@ -38,6 +38,4 @@ word wrap.">
[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test
[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
-\ wrap-string must-infer
-
[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test
diff --git a/basis/wrap/words/words-tests.factor b/basis/wrap/words/words-tests.factor
index 7598b382ba..6df69a65d6 100644
--- a/basis/wrap/words/words-tests.factor
+++ b/basis/wrap/words/words-tests.factor
@@ -79,4 +79,3 @@ IN: wrap.words.tests
} 35 35 wrap-words [ { } like ] map
] unit-test
-\ wrap-words must-infer
diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor
index 58957ba8e7..482d50ab5f 100644
--- a/basis/wrap/wrap.factor
+++ b/basis/wrap/wrap.factor
@@ -30,7 +30,7 @@ SYMBOL: line-ideal
{ [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
:: min-by ( seq quot -- elt )
- f 1.0/0.0 seq [| key value new |
+ f 1/0. seq [| key value new |
new quot call :> newvalue
newvalue value < [ new newvalue ] [ key value ] if
] each drop ; inline
diff --git a/basis/x11/authors.txt b/basis/x11/authors.txt
new file mode 100644
index 0000000000..db8d84451d
--- /dev/null
+++ b/basis/x11/authors.txt
@@ -0,0 +1,2 @@
+Eduardo Cavazos
+Slava Pestov
diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor
index 87b91624af..20bf66c704 100644
--- a/basis/x11/clipboard/clipboard.factor
+++ b/basis/x11/clipboard/clipboard.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
kernel math namespaces sequences io.encodings.string
-io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants
+io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants
specialized-arrays.int accessors ;
IN: x11.clipboard
diff --git a/basis/x11/events/events.factor b/basis/x11/events/events.factor
index 07650a9da7..5673dd7f76 100644
--- a/basis/x11/events/events.factor
+++ b/basis/x11/events/events.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays hashtables io kernel math
math.order namespaces prettyprint sequences strings combinators
-x11.xlib ;
+x11 x11.xlib ;
IN: x11.events
GENERIC: expose-event ( event window -- )
diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor
index e6001d3e59..67ac0e8cc1 100644
--- a/basis/x11/glx/glx.factor
+++ b/basis/x11/glx/glx.factor
@@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
!
! based on glx.h from xfree86, and some of glxtokens.h
-USING: alien alien.c-types alien.syntax x11.xlib namespaces make
-kernel sequences parser words specialized-arrays.int accessors ;
+USING: alien alien.c-types alien.syntax x11 x11.xlib x11.syntax
+namespaces make kernel sequences parser words specialized-arrays.int
+accessors ;
IN: x11.glx
LIBRARY: glx
@@ -36,67 +37,64 @@ TYPEDEF: XID GLXFBConfigID
TYPEDEF: void* GLXContext ! typedef struct __GLXcontextRec *GLXContext;
TYPEDEF: void* GLXFBConfig ! typedef struct __GLXFBConfigRec *GLXFBConfig;
-FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ;
-FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ;
-FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ;
-FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ;
-FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ;
-FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ;
-FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ;
-FUNCTION: GLXContext glXGetCurrentContext ( ) ;
-FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ;
-FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ;
-FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ;
-FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ;
-FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ;
-FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ;
-FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ;
-FUNCTION: void glXWaitGL ( ) ;
-FUNCTION: void glXWaitX ( ) ;
-FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ;
-FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ;
-FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ;
+X-FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ;
+X-FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ;
+X-FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ;
+X-FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ;
+X-FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ;
+X-FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ;
+X-FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ;
+X-FUNCTION: GLXContext glXGetCurrentContext ( ) ;
+X-FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ;
+X-FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ;
+X-FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ;
+X-FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ;
+X-FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ;
+X-FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ;
+X-FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ;
+X-FUNCTION: void glXWaitGL ( ) ;
+X-FUNCTION: void glXWaitX ( ) ;
+X-FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ;
+X-FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ;
+X-FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ;
! New for GLX 1.3
-FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ;
-FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ;
-FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ;
-FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ;
-FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ;
-FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ;
-FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ;
-FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ;
-FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ;
-FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ;
-FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ;
-FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ;
-FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ;
-FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ;
-FUNCTION: Display* glXGetCurrentDisplay ( ) ;
-FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ;
-FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ;
-FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ;
+X-FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ;
+X-FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ;
+X-FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ;
+X-FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ;
+X-FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ;
+X-FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ;
+X-FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ;
+X-FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ;
+X-FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ;
+X-FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ;
+X-FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ;
+X-FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ;
+X-FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ;
+X-FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ;
+X-FUNCTION: Display* glXGetCurrentDisplay ( ) ;
+X-FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ;
+X-FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ;
+X-FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ;
! GLX 1.4 and later
-FUNCTION: void* glXGetProcAddress ( char* procname ) ;
+X-FUNCTION: void* glXGetProcAddress ( char* procname ) ;
! GLX_ARB_get_proc_address extension
-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
+X-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
+
+! GLX_ARB_multisample
+CONSTANT: GLX_SAMPLE_BUFFERS 100000
+CONSTANT: GLX_SAMPLES 100001
+
+! GLX_ARB_fbconfig_float
+CONSTANT: GLX_RGBA_FLOAT_TYPE HEX: 20B9
+CONSTANT: GLX_RGBA_FLOAT_BIT HEX: 0004
! GLX Events
! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks)
-: choose-visual ( flags -- XVisualInfo* )
- [ dpy get scr get ] dip
- [
- %
- GLX_RGBA ,
- GLX_DEPTH_SIZE , 16 ,
- 0 ,
- ] int-array{ } make
- glXChooseVisual
- [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
-
: create-glx ( XVisualInfo* -- GLXContext )
[ dpy get ] dip f 1 glXCreateContext
[ "Failed to create GLX context" throw ] unless* ;
diff --git a/basis/x11/io/authors.txt b/basis/x11/io/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/x11/io/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/x11/io/io.factor b/basis/x11/io/io.factor
new file mode 100644
index 0000000000..0e618cd323
--- /dev/null
+++ b/basis/x11/io/io.factor
@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend calendar threads kernel ;
+IN: x11.io
+
+HOOK: init-x-io io-backend ( -- )
+
+M: object init-x-io ;
+
+HOOK: wait-for-display io-backend ( -- )
+
+M: object wait-for-display 10 milliseconds sleep ;
+
+HOOK: awaken-event-loop io-backend ( -- )
+
+M: object awaken-event-loop ;
\ No newline at end of file
diff --git a/basis/x11/io/unix/authors.txt b/basis/x11/io/unix/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/x11/io/unix/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/x11/io/unix/tags.txt b/basis/x11/io/unix/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/x11/io/unix/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/x11/io/unix/unix.factor b/basis/x11/io/unix/unix.factor
new file mode 100644
index 0000000000..821beb91a5
--- /dev/null
+++ b/basis/x11/io/unix/unix.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend.unix io.backend.unix.multiplexers
+namespaces system x11 x11.xlib x11.io
+accessors threads sequences kernel ;
+IN: x11.io.unix
+
+SYMBOL: dpy-fd
+
+M: unix init-x-io dpy get XConnectionNumber <fd> dpy-fd set-global ;
+
+M: unix wait-for-display dpy-fd get +input+ wait-for-fd ;
+
+M: unix awaken-event-loop
+ dpy-fd get [ fd>> mx get remove-input-callbacks [ resume ] each ] when* ;
\ No newline at end of file
diff --git a/basis/x11/syntax/authors.txt b/basis/x11/syntax/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/x11/syntax/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/x11/syntax/syntax.factor b/basis/x11/syntax/syntax.factor
new file mode 100644
index 0000000000..db2adab5dc
--- /dev/null
+++ b/basis/x11/syntax/syntax.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax alien.parser words x11.io sequences kernel ;
+IN: x11.syntax
+
+SYNTAX: X-FUNCTION:
+ (FUNCTION:)
+ [ \ awaken-event-loop suffix ] dip
+ define-declared ;
\ No newline at end of file
diff --git a/basis/x11/windows/windows.factor b/basis/x11/windows/windows.factor
index 9619ae0bee..54cf205c14 100644
--- a/basis/x11/windows/windows.factor
+++ b/basis/x11/windows/windows.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types hashtables kernel math math.vectors
-math.bitwise namespaces sequences x11.xlib x11.constants x11.glx
+math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx
arrays fry ;
IN: x11.windows
@@ -9,7 +9,7 @@ IN: x11.windows
{ CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
: create-colormap ( visinfo -- colormap )
- dpy get root get rot XVisualInfo-visual AllocNone
+ [ dpy get root get ] dip XVisualInfo-visual AllocNone
XCreateColormap ;
: event-mask ( -- n )
@@ -53,11 +53,8 @@ IN: x11.windows
dup
] dip auto-position ;
-: glx-window ( loc dim -- window glx )
- GLX_DOUBLEBUFFER 1array choose-visual
- [ create-window ] keep
- [ create-glx ] keep
- XFree ;
+: glx-window ( loc dim visual -- window glx )
+ [ create-window ] [ create-glx ] bi ;
: create-pixmap ( dim visual -- pixmap )
[ [ { 0 0 } swap ] dip create-window ] [
@@ -74,9 +71,8 @@ IN: x11.windows
: create-glx-pixmap ( dim visual -- pixmap glx-pixmap )
[ create-pixmap ] [ (create-glx-pixmap) ] bi ;
-: glx-pixmap ( dim -- glx pixmap glx-pixmap )
- { } choose-visual
- [ nip create-glx ] [ create-glx-pixmap ] [ nip XFree ] 2tri ;
+: glx-pixmap ( dim visual -- glx pixmap glx-pixmap )
+ [ nip create-glx ] [ create-glx-pixmap ] 2bi ;
: destroy-window ( win -- )
dpy get swap XDestroyWindow drop ;
diff --git a/basis/x11/x11.factor b/basis/x11/x11.factor
new file mode 100644
index 0000000000..09328c6f6e
--- /dev/null
+++ b/basis/x11/x11.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2005, 2009 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.strings continuations io
+io.encodings.ascii kernel namespaces x11.xlib x11.io
+vocabs vocabs.loader ;
+IN: x11
+
+SYMBOL: dpy
+SYMBOL: scr
+SYMBOL: root
+
+: init-locale ( -- )
+ LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
+ XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
+
+: flush-dpy ( -- ) dpy get XFlush drop ;
+
+: x-atom ( string -- atom ) [ dpy get ] dip 0 XInternAtom ;
+
+: check-display ( alien -- alien' )
+ [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ;
+
+: init-x ( display-string -- )
+ init-locale
+ dup [ ascii string>alien ] when
+ XOpenDisplay check-display dpy set-global
+ dpy get XDefaultScreen scr set-global
+ dpy get scr get XRootWindow root set-global
+ init-x-io ;
+
+: close-x ( -- ) dpy get XCloseDisplay drop ;
+
+: with-x ( display-string quot -- )
+ [ init-x ] dip [ close-x ] [ ] cleanup ; inline
+
+"io.backend.unix" vocab [ "x11.io.unix" require ] when
\ No newline at end of file
diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor
index e06872fa83..54f20a28dd 100644
--- a/basis/x11/xim/xim.factor
+++ b/basis/x11/xim/xim.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays byte-arrays
hashtables io io.encodings.string kernel math namespaces
-sequences strings continuations x11.xlib specialized-arrays.uint
+sequences strings continuations x11 x11.xlib specialized-arrays.uint
accessors io.encodings.utf16n ;
IN: x11.xim
@@ -22,7 +22,7 @@ SYMBOL: xim
xim get-global XCloseIM drop f xim set-global ;
: with-xim ( quot -- )
- [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ;
+ [ "Factor" init-xim ] dip [ close-xim ] [ ] cleanup ; inline
: create-xic ( window classname -- xic )
[
diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor
index 3394de87b2..638f5c8d56 100644
--- a/basis/x11/xlib/xlib.factor
+++ b/basis/x11/xlib/xlib.factor
@@ -13,7 +13,7 @@
USING: kernel arrays alien alien.c-types alien.strings
alien.syntax math math.bitwise words sequences namespaces
-continuations io io.encodings.ascii ;
+continuations io io.encodings.ascii x11.syntax ;
IN: x11.xlib
LIBRARY: xlib
@@ -71,26 +71,26 @@ C-STRUCT: Display
{ "void*" "free_funcs" }
{ "int" "fd" } ;
-FUNCTION: Display* XOpenDisplay ( void* display_name ) ;
+X-FUNCTION: Display* XOpenDisplay ( void* display_name ) ;
! 2.2 Obtaining Information about the Display, Image Formats, or Screens
-FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ;
-FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ;
-FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ;
-FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ;
-FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ;
-FUNCTION: int XDefaultScreen ( Display* display ) ;
-FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ;
-FUNCTION: Window XDefaultRootWindow ( Display* display ) ;
-FUNCTION: int XProtocolVersion ( Display* display ) ;
-FUNCTION: int XProtocolRevision ( Display* display ) ;
-FUNCTION: int XQLength ( Display* display ) ;
-FUNCTION: int XScreenCount ( Display* display ) ;
-FUNCTION: int XConnectionNumber ( Display* display ) ;
+X-FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ;
+X-FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ;
+X-FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ;
+X-FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ;
+X-FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ;
+X-FUNCTION: int XDefaultScreen ( Display* display ) ;
+X-FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ;
+X-FUNCTION: Window XDefaultRootWindow ( Display* display ) ;
+X-FUNCTION: int XProtocolVersion ( Display* display ) ;
+X-FUNCTION: int XProtocolRevision ( Display* display ) ;
+X-FUNCTION: int XQLength ( Display* display ) ;
+X-FUNCTION: int XScreenCount ( Display* display ) ;
+X-FUNCTION: int XConnectionNumber ( Display* display ) ;
! 2.5 Closing the Display
-FUNCTION: int XCloseDisplay ( Display* display ) ;
+X-FUNCTION: int XCloseDisplay ( Display* display ) ;
!
! 3 - Window Functions
@@ -147,17 +147,17 @@ CONSTANT: StaticGravity 10
! 3.3 - Creating Windows
-FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ;
-FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ;
-FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ;
-FUNCTION: Status XMapWindow ( Display* display, Window window ) ;
-FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ;
-FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ;
-FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ;
+X-FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ;
+X-FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ;
+X-FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XMapWindow ( Display* display, Window window ) ;
+X-FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ;
+X-FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ;
! 3.5 Mapping Windows
-FUNCTION: int XMapRaised ( Display* display, Window w ) ;
+X-FUNCTION: int XMapRaised ( Display* display, Window w ) ;
! 3.7 - Configuring Windows
@@ -178,25 +178,25 @@ C-STRUCT: XWindowChanges
{ "Window" "sibling" }
{ "int" "stack_mode" } ;
-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ;
-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ;
-FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ;
-FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ;
+X-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ;
+X-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ;
+X-FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ;
+X-FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ;
! 3.8 Changing Window Stacking Order
-FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ;
-FUNCTION: Status XLowerWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XLowerWindow ( Display* display, Window w ) ;
! 3.9 - Changing Window Attributes
-FUNCTION: Status XChangeWindowAttributes (
+X-FUNCTION: Status XChangeWindowAttributes (
Display* display, Window w, ulong valuemask, XSetWindowAttributes* attr ) ;
-FUNCTION: Status XSetWindowBackground (
+X-FUNCTION: Status XSetWindowBackground (
Display* display, Window w, ulong background_pixel ) ;
-FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ;
-FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ;
+X-FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ;
+X-FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 4 - Window Information Functions
@@ -204,7 +204,7 @@ FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ;
! 4.1 - Obtaining Window Information
-FUNCTION: Status XQueryTree (
+X-FUNCTION: Status XQueryTree (
Display* display,
Window w,
Window* root_return,
@@ -236,13 +236,13 @@ C-STRUCT: XWindowAttributes
{ "Bool" "override_redirect" }
{ "Screen*" "screen" } ;
-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ;
+X-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ;
CONSTANT: IsUnmapped 0
CONSTANT: IsUnviewable 1
CONSTANT: IsViewable 2
-FUNCTION: Status XGetGeometry (
+X-FUNCTION: Status XGetGeometry (
Display* display,
Drawable d,
Window* root_return,
@@ -255,27 +255,27 @@ FUNCTION: Status XGetGeometry (
! 4.2 - Translating Screen Coordinates
-FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ;
+X-FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ;
! 4.3 - Properties and Atoms
-FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ;
+X-FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ;
-FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ;
+X-FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ;
! 4.4 - Obtaining and Changing Window Properties
-FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ;
+X-FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ;
-FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ;
+X-FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ;
! 4.5 Selections
-FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ;
+X-FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ;
-FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ;
+X-FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ;
-FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ;
+X-FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -284,8 +284,8 @@ FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target,
! 5.1 - Creating and Freeing Pixmaps
-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
+X-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
+X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -300,13 +300,13 @@ C-STRUCT: XColor
{ "char" "flags" }
{ "char" "pad" } ;
-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ;
-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ;
-FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ;
+X-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ;
+X-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ;
+X-FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ;
! 6.4 Creating, Copying, and Destroying Colormaps
-FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ;
+X-FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 7 - Graphics Context Functions
@@ -378,27 +378,27 @@ C-STRUCT: XGCValues
{ "int" "dash_offset" }
{ "char" "dashes" } ;
-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ;
-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ;
-FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ;
-FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ;
-FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ;
-FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ;
-FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ;
+X-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ;
+X-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ;
+X-FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ;
+X-FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ;
+X-FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ;
+X-FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ;
+X-FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ;
-FUNCTION: GContext XGContextFromGC ( GC gc ) ;
+X-FUNCTION: GContext XGContextFromGC ( GC gc ) ;
-FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ;
+X-FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 8 - Graphics Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-FUNCTION: Status XClearWindow ( Display* display, Window w ) ;
-FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ;
-FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ;
-FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
+X-FUNCTION: Status XClearWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ;
+X-FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ;
+X-FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
+X-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
! 8.5 - Font Metrics
@@ -410,9 +410,9 @@ C-STRUCT: XCharStruct
{ "short" "descent" }
{ "ushort" "attributes" } ;
-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
+X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
+X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
+X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
C-STRUCT: XFontStruct
{ "XExtData*" "ext_data" }
@@ -432,11 +432,11 @@ C-STRUCT: XFontStruct
{ "int" "ascent" }
{ "int" "descent" } ;
-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
+X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
! 8.6 - Drawing Text
-FUNCTION: Status XDrawString (
+X-FUNCTION: Status XDrawString (
Display* display,
Drawable d,
GC gc,
@@ -479,8 +479,8 @@ C-STRUCT: XImage
{ "XPointer" "obdata" }
{ "XImage-funcs" "f" } ;
-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
+X-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
: XImage-size ( ximage -- size )
[ XImage-height ] [ XImage-bytes_per_line ] bi * ;
@@ -492,12 +492,12 @@ FUNCTION: int XDestroyImage ( XImage *ximage ) ;
! 9 - Window and Session Manager Functions
!
-FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ;
-FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ;
-FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ;
-FUNCTION: Status XGrabServer ( Display* display ) ;
-FUNCTION: Status XUngrabServer ( Display* display ) ;
-FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
+X-FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ;
+X-FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ;
+X-FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ;
+X-FUNCTION: Status XGrabServer ( Display* display ) ;
+X-FUNCTION: Status XUngrabServer ( Display* display ) ;
+X-FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 10 - Events
@@ -1066,11 +1066,11 @@ C-UNION: XEvent
! 11 - Event Handling Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ;
-FUNCTION: Status XFlush ( Display* display ) ;
-FUNCTION: Status XSync ( Display* display, int discard ) ;
-FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ;
-FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ;
+X-FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ;
+X-FUNCTION: Status XFlush ( Display* display ) ;
+X-FUNCTION: Status XSync ( Display* display, int discard ) ;
+X-FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ;
+X-FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ;
! 11.3 - Event Queue Management
@@ -1078,16 +1078,16 @@ CONSTANT: QueuedAlready 0
CONSTANT: QueuedAfterReading 1
CONSTANT: QueuedAfterFlush 2
-FUNCTION: int XEventsQueued ( Display* display, int mode ) ;
-FUNCTION: int XPending ( Display* display ) ;
+X-FUNCTION: int XEventsQueued ( Display* display, int mode ) ;
+X-FUNCTION: int XPending ( Display* display ) ;
! 11.6 - Sending Events to Other Applications
-FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ;
+X-FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ;
! 11.8 - Handling Protocol Errors
-FUNCTION: int XSetErrorHandler ( void* handler ) ;
+X-FUNCTION: int XSetErrorHandler ( void* handler ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 12 - Input Device Functions
@@ -1095,7 +1095,7 @@ FUNCTION: int XSetErrorHandler ( void* handler ) ;
CONSTANT: None 0
-FUNCTION: int XGrabPointer (
+X-FUNCTION: int XGrabPointer (
Display* display,
Window grab_window,
Bool owner_events,
@@ -1106,16 +1106,16 @@ FUNCTION: int XGrabPointer (
Cursor cursor,
Time time ) ;
-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ;
-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ;
-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ;
-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ;
+X-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ;
+X-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ;
+X-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ;
+X-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ;
-FUNCTION: Status XGetInputFocus ( Display* display,
+X-FUNCTION: Status XGetInputFocus ( Display* display,
Window* focus_return,
int* revert_to_return ) ;
-FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ;
+X-FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 14 - Inter-Client Communication Functions
@@ -1123,15 +1123,15 @@ FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, i
! 14.1 Client to Window Manager Communication
-FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ;
-FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ;
+X-FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ;
+X-FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ;
! 14.1.1. Manipulating Top-Level Windows
-FUNCTION: Status XIconifyWindow (
+X-FUNCTION: Status XIconifyWindow (
Display* display, Window w, int screen_number ) ;
-FUNCTION: Status XWithdrawWindow (
+X-FUNCTION: Status XWithdrawWindow (
Display* display, Window w, int screen_number ) ;
! 14.1.6 - Setting and Reading the WM_HINTS Property
@@ -1173,10 +1173,10 @@ C-STRUCT: XSizeHints
! 14.1.10. Setting and Reading the WM_PROTOCOLS Property
-FUNCTION: Status XSetWMProtocols (
+X-FUNCTION: Status XSetWMProtocols (
Display* display, Window w, Atom* protocols, int count ) ;
-FUNCTION: Status XGetWMProtocols (
+X-FUNCTION: Status XGetWMProtocols (
Display* display,
Window w,
Atom** protocols_return,
@@ -1188,9 +1188,9 @@ FUNCTION: Status XGetWMProtocols (
! 16.1 Keyboard Utility Functions
-FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ;
+X-FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ;
-FUNCTION: int XLookupString (
+X-FUNCTION: int XLookupString (
XKeyEvent* event_struct,
void* buffer_return,
int bytes_buffer,
@@ -1227,7 +1227,7 @@ C-STRUCT: XVisualInfo
! Appendix D - Compatibility Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-FUNCTION: Status XSetStandardProperties (
+X-FUNCTION: Status XSetStandardProperties (
Display* display,
Window w,
char* window_name,
@@ -1314,10 +1314,10 @@ CONSTANT: XA_LAST_PREDEFINED 68
! The rest of the stuff is not from the book.
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-FUNCTION: void XFree ( void* data ) ;
-FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ;
-FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ;
-FUNCTION: int XBell ( Display* display, int percent ) ;
+X-FUNCTION: void XFree ( void* data ) ;
+X-FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ;
+X-FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ;
+X-FUNCTION: int XBell ( Display* display, int percent ) ;
! !!! INPUT METHODS
@@ -1381,23 +1381,23 @@ CONSTANT: XLookupChars 2
CONSTANT: XLookupKeySym 3
CONSTANT: XLookupBoth 4
-FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ;
+X-FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ;
-FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ;
+X-FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ;
-FUNCTION: Status XCloseIM ( XIM im ) ;
+X-FUNCTION: Status XCloseIM ( XIM im ) ;
-FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ;
+X-FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ;
-FUNCTION: void XDestroyIC ( XIC ic ) ;
+X-FUNCTION: void XDestroyIC ( XIC ic ) ;
-FUNCTION: void XSetICFocus ( XIC ic ) ;
+X-FUNCTION: void XSetICFocus ( XIC ic ) ;
-FUNCTION: void XUnsetICFocus ( XIC ic ) ;
+X-FUNCTION: void XUnsetICFocus ( XIC ic ) ;
-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
+X-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
-FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
+X-FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
! !!! category of setlocale
CONSTANT: LC_ALL 0
@@ -1407,37 +1407,8 @@ CONSTANT: LC_MONETARY 3
CONSTANT: LC_NUMERIC 4
CONSTANT: LC_TIME 5
-FUNCTION: char* setlocale ( int category, char* name ) ;
+X-FUNCTION: char* setlocale ( int category, char* name ) ;
-FUNCTION: Bool XSupportsLocale ( ) ;
+X-FUNCTION: Bool XSupportsLocale ( ) ;
-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ;
-
-SYMBOL: dpy
-SYMBOL: scr
-SYMBOL: root
-
-: init-locale ( -- )
- LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
- XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
-
-: flush-dpy ( -- ) dpy get XFlush drop ;
-
-: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ;
-
-: check-display ( alien -- alien' )
- [
- "Cannot connect to X server - check $DISPLAY" throw
- ] unless* ;
-
-: initialize-x ( display-string -- )
- init-locale
- dup [ ascii string>alien ] when
- XOpenDisplay check-display dpy set-global
- dpy get XDefaultScreen scr set-global
- dpy get scr get XRootWindow root set-global ;
-
-: close-x ( -- ) dpy get XCloseDisplay drop ;
-
-: with-x ( display-string quot -- )
- [ initialize-x ] dip [ close-x ] [ ] cleanup ;
+X-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ;
diff --git a/basis/xml/syntax/syntax-tests.factor b/basis/xml/syntax/syntax-tests.factor
index 10ab961ec0..6fcaf780cc 100644
--- a/basis/xml/syntax/syntax-tests.factor
+++ b/basis/xml/syntax/syntax-tests.factor
@@ -33,8 +33,6 @@ TAG: neg calculate
calc-arith
] unit-test
-\ calc-arith must-infer
-
XML-NS: foo http://blah.com
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
@@ -90,7 +88,6 @@ XML-NS: foo http://blah.com
[ "<x>3</x>" ] [ 3 [XML <x><-></x> XML] xml>string ] unit-test
[ "<x></x>" ] [ f [XML <x><-></x> XML] xml>string ] unit-test
-\ <XML must-infer
[ [XML <-> XML] ] must-infer
[ [XML <foo><-></foo> <bar val=<->/> XML] ] must-infer
diff --git a/basis/xml/syntax/tags.txt b/basis/xml/syntax/tags.txt
index 71c0ff7282..4f4a20b1cb 100644
--- a/basis/xml/syntax/tags.txt
+++ b/basis/xml/syntax/tags.txt
@@ -1 +1,2 @@
+extensions
syntax
diff --git a/basis/xml/tests/state-parser-tests.factor b/basis/xml/tests/state-parser-tests.factor
index 7616efaf1d..5e214dc4a3 100644
--- a/basis/xml/tests/state-parser-tests.factor
+++ b/basis/xml/tests/state-parser-tests.factor
@@ -2,7 +2,7 @@ USING: tools.test xml.tokenize xml.state io.streams.string kernel io strings asc
IN: xml.test.state
: string-parse ( str quot -- )
- [ <string-reader> ] dip with-state ;
+ [ <string-reader> ] dip with-state ; inline
: take-rest ( -- string )
[ f ] take-until ;
diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor
index 1d07aa9406..74ba931c79 100644
--- a/basis/xml/tests/test.factor
+++ b/basis/xml/tests/test.factor
@@ -7,9 +7,7 @@ xml.traversal continuations assocs io.encodings.binary
sequences.deep accessors io.streams.string ;
! This is insufficient
-\ read-xml must-infer
[ [ drop ] each-element ] must-infer
-\ string>xml must-infer
SYMBOL: xml-file
[ ] [
diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor
index c41b05eb85..55b5147abb 100644
--- a/basis/xml/tests/xmltest.factor
+++ b/basis/xml/tests/xmltest.factor
@@ -43,7 +43,7 @@ MACRO: drop-input ( quot -- newquot )
xml-tests [ unit-test ] assoc-each ;
: works? ( result quot -- ? )
- [ first ] [ call ] bi* = ;
+ [ first ] [ call( -- result ) ] bi* = ;
: partition-xml-tests ( -- successes failures )
xml-tests [ first2 works? ] partition ;
diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor
index f19e845ab9..ee09668a53 100644
--- a/basis/xml/writer/writer-tests.factor
+++ b/basis/xml/writer/writer-tests.factor
@@ -1,13 +1,10 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.data xml.writer tools.test fry xml kernel multiline
+USING: xml.data xml.writer tools.test fry xml xml.syntax kernel multiline
xml.writer.private io.streams.string xml.traversal sequences
-io.encodings.utf8 io.files accessors io.directories ;
+io.encodings.utf8 io.files accessors io.directories math math.parser ;
IN: xml.writer.tests
-\ write-xml must-infer
-\ xml>string must-infer
-\ pprint-xml must-infer
! Add a test for pprint-xml with sensitive-tags
[ "foo" ] [ T{ name { main "foo" } } name>string ] unit-test
@@ -66,3 +63,11 @@ CONSTANT: test-file "resource:basis/xml/writer/test.xml"
[ ] [ "<?xml version='1.0' encoding='UTF-16BE'?><x/>" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test
[ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test
[ ] [ test-file delete-file ] unit-test
+
+[ ] [
+ { 1 2 3 4 } [
+ [ number>string ] [ sq number>string ] bi
+ [XML <tr><td><-></td><td><-></td></tr> XML]
+ ] map [XML <h2>Timings</h2> <table><-></table> XML]
+ pprint-xml
+] unit-test
\ No newline at end of file
diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor
index 4f5bad1aa5..ab957ebc75 100755
--- a/basis/xml/writer/writer.factor
+++ b/basis/xml/writer/writer.factor
@@ -19,7 +19,7 @@ SYMBOL: indentation
: indent-string ( -- string )
xml-pprint? get
- [ indentation get indenter get <repetition> concat ]
+ [ indentation get indenter get <repetition> "" join ]
[ "" ] if ;
: ?indent ( -- )
diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor
index 8d5db4a6e9..d57b8ce28d 100644
--- a/basis/xmode/code2html/code2html-tests.factor
+++ b/basis/xmode/code2html/code2html-tests.factor
@@ -3,8 +3,6 @@ USING: xmode.code2html xmode.catalog
tools.test multiline splitting memoize
kernel io.streams.string xml.writer ;
-\ htmlize-file must-infer
-
[ ] [ \ (load-mode) reset-memoized ] unit-test
[ ] [
diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor
index 3fb5a532c9..b5141f6cc4 100644
--- a/basis/xmode/code2html/code2html.factor
+++ b/basis/xmode/code2html/code2html.factor
@@ -24,7 +24,7 @@ IN: xmode.code2html
[XML <style><-></style> XML] ;
:: htmlize-stream ( path stream -- xml )
- stream lines
+ stream stream-lines
[ "" ] [ path over first find-mode htmlize-lines ]
if-empty :> input
default-stylesheet :> stylesheet
diff --git a/build-support/factor.sh b/build-support/factor.sh
index ad64c541fe..ba5815cfc1 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -22,6 +22,13 @@ test_program_installed() {
return 1;
}
+exit_script() {
+ if [[ $FIND_MAKE_TARGET -eq true ]] ; then
+ echo $MAKE_TARGET;
+ fi
+ exit $1
+}
+
ensure_program_installed() {
installed=0;
for i in $* ;
@@ -43,7 +50,7 @@ ensure_program_installed() {
$ECHO -n "any of [ $* ]"
fi
$ECHO " and try again."
- exit 1
+ exit_script 1;
fi
}
@@ -51,7 +58,7 @@ check_ret() {
RET=$?
if [[ $RET -ne 0 ]] ; then
$ECHO $1 failed
- exit 2
+ exit_script 2
fi
}
@@ -62,7 +69,7 @@ check_gcc_version() {
if [[ $GCC_VERSION == *3.3.* ]] ; then
$ECHO "You have a known buggy version of gcc (3.3)"
$ECHO "Install gcc 3.4 or higher and try again."
- exit 3
+ exit_script 3
elif [[ $GCC_VERSION == *4.3.* ]] ; then
MAKE_OPTS="$MAKE_OPTS SITE_CFLAGS=-fno-forward-propagate"
fi
@@ -139,7 +146,6 @@ check_library_exists() {
}
check_X11_libraries() {
- check_library_exists GLU
check_library_exists GL
check_library_exists X11
check_library_exists pango-1.0
@@ -155,7 +161,7 @@ check_factor_exists() {
if [[ -d "factor" ]] ; then
$ECHO "A directory called 'factor' already exists."
$ECHO "Rename or delete it and try again."
- exit 4
+ exit_script 4
fi
}
@@ -199,7 +205,7 @@ find_architecture() {
write_test_program() {
echo "#include <stdio.h>" > $C_WORD.c
- echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
+ echo "int main(){printf(\"%ld\", (long)(8*sizeof(void*))); return 0; }" >> $C_WORD.c
}
c_find_word_size() {
@@ -280,7 +286,7 @@ check_os_arch_word() {
$ECHO "OS, ARCH, or WORD is empty. Please report this."
echo $MAKE_TARGET
- exit 5
+ exit_script 5
fi
}
@@ -386,7 +392,7 @@ check_makefile_exists() {
echo "You are likely in the wrong directory."
echo "Run this script from your factor directory:"
echo " ./build-support/factor.sh"
- exit 6
+ exit_script 6
fi
}
@@ -491,7 +497,7 @@ make_boot_image() {
}
install_build_system_apt() {
- sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
+ sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make
check_ret sudo
}
@@ -537,6 +543,6 @@ case "$1" in
bootstrap) get_config_info; bootstrap ;;
report) find_build_info ;;
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
- make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
+ make-target) FIND_MAKE_TARGET=true; ECHO=false; find_build_info; exit_script ;;
*) usage ;;
esac
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 6bd1d2f53a..66e67ab322 100644
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -145,12 +145,6 @@ ARTICLE: "reading-writing-memory" "Reading and writing memory directly"
{ $subsection set-alien-float }
{ $subsection set-alien-double } ;
-ARTICLE: "loading-libs" "Loading native libraries"
-"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
-{ $subsection add-library }
-"Once a library has been defined, you can try loading it to see if the path name is correct:"
-{ $subsection load-library } ;
-
ARTICLE: "alien-invoke" "Calling C from Factor"
"The easiest way to call into a C library is to define bindings using a pair of parsing words:"
{ $subsection POSTPONE: LIBRARY: }
diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor
index 57dc298c00..d3265f31bb 100644
--- a/core/alien/alien-tests.factor
+++ b/core/alien/alien-tests.factor
@@ -1,6 +1,6 @@
USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
-system prettyprint layouts alien.libraries ;
+system prettyprint layouts alien.libraries sets ;
IN: alien.tests
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
@@ -86,3 +86,5 @@ f initialize-test set-global
[ ] [ initialize-test get BAD-ALIEN >>alien drop ] unit-test
[ 7575 ] [ initialize-test [ 7575 ] initialize-alien ] unit-test
+
+[ V{ BAD-ALIEN } ] [ { BAD-ALIEN BAD-ALIEN BAD-ALIEN } prune ] unit-test
\ No newline at end of file
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index ea0cb9208e..ec38e3be5b 100644
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -49,6 +49,8 @@ M: alien equal?
2drop f
] if ;
+M: simple-alien hashcode* nip dup expired>> [ drop 1234 ] [ alien-address ] if ;
+
ERROR: alien-callback-error ;
: alien-callback ( return parameters abi quot -- alien )
diff --git a/core/alien/strings/strings-docs.factor b/core/alien/strings/strings-docs.factor
new file mode 100644
index 0000000000..388b9842db
--- /dev/null
+++ b/core/alien/strings/strings-docs.factor
@@ -0,0 +1,20 @@
+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." } ;
+
+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: 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." } ;
+
+ABOUT: "c-strings"
diff --git a/basis/alien/strings/strings-tests.factor b/core/alien/strings/strings-tests.factor
similarity index 93%
rename from basis/alien/strings/strings-tests.factor
rename to core/alien/strings/strings-tests.factor
index 263453ba1c..6a0a42253b 100644
--- a/basis/alien/strings/strings-tests.factor
+++ b/core/alien/strings/strings-tests.factor
@@ -1,4 +1,4 @@
-USING: alien.strings tools.test kernel libc
+USING: alien.strings alien.c-types tools.test kernel libc
io.encodings.8-bit io.encodings.utf8 io.encodings.utf16
io.encodings.utf16n io.encodings.ascii alien io.encodings.string ;
IN: alien.strings.tests
diff --git a/core/alien/strings/strings.factor b/core/alien/strings/strings.factor
new file mode 100644
index 0000000000..943530d4f2
--- /dev/null
+++ b/core/alien/strings/strings.factor
@@ -0,0 +1,61 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays sequences kernel kernel.private accessors math
+alien.accessors byte-arrays io io.encodings io.encodings.utf8
+io.encodings.utf16n io.streams.byte-array io.streams.memory system
+system.private alien strings combinators namespaces init ;
+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 ;
+
+HOOK: alien>native-string os ( alien -- string )
+
+HOOK: native-string>alien os ( string -- alien )
+
+M: windows alien>native-string utf16n alien>string ;
+
+M: wince native-string>alien utf16n string>alien ;
+
+M: winnt native-string>alien utf8 string>alien ;
+
+M: unix alien>native-string utf8 alien>string ;
+
+M: unix native-string>alien utf8 string>alien ;
+
+: dll-path ( dll -- string )
+ path>> alien>native-string ;
+
+: string>symbol ( str -- alien )
+ dup string?
+ [ native-string>alien ]
+ [ [ native-string>alien ] map ] if ;
+
+[
+ 8 getenv utf8 alien>string string>cpu \ cpu set-global
+ 9 getenv utf8 alien>string string>os \ os set-global
+] "alien.strings" add-init-hook
+
diff --git a/basis/alien/strings/summary.txt b/core/alien/strings/summary.txt
similarity index 100%
rename from basis/alien/strings/summary.txt
rename to core/alien/strings/summary.txt
diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor
index 9576a41b7b..d4046a4dcf 100755
--- a/core/assocs/assocs-docs.factor
+++ b/core/assocs/assocs-docs.factor
@@ -361,8 +361,7 @@ HELP: inc-at
HELP: >alist
{ $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } }
-{ $contract "Converts an associative structure into an association list." }
-{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which constructs the association list by iterating over the assoc with " { $link assoc-find } "." } ;
+{ $contract "Converts an associative structure into an association list." } ;
HELP: assoc-clone-like
{ $values
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index ec56cffff7..e783ef81c4 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -32,7 +32,7 @@ M: assoc assoc-like drop ;
3drop f
] [
3dup nth-unsafe at*
- [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
+ [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if
] if ; inline recursive
: search-alist ( key alist -- pair/f i/f )
@@ -105,7 +105,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
assoc-size 0 = ;
: assoc-stack ( key seq -- value )
- [ length 1- ] keep (assoc-stack) ; flushable
+ [ length 1 - ] keep (assoc-stack) ; flushable
: assoc-subset? ( assoc1 assoc2 -- ? )
[ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor
index 26100277a8..5ed92b7776 100644
--- a/core/bootstrap/layouts/layouts.factor
+++ b/core/bootstrap/layouts/layouts.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel alien byte-arrays
hashtables vectors strings sbufs arrays
@@ -9,28 +9,28 @@ BIN: 111 tag-mask set
8 num-tags set
3 tag-bits set
-17 num-types set
+15 num-types set
+
+32 mega-cache-size set
H{
{ fixnum BIN: 000 }
{ bignum BIN: 001 }
- { tuple BIN: 010 }
- { object BIN: 011 }
- { hi-tag BIN: 011 }
- { ratio BIN: 100 }
- { float BIN: 101 }
- { complex BIN: 110 }
- { POSTPONE: f BIN: 111 }
+ { array BIN: 010 }
+ { float BIN: 011 }
+ { quotation BIN: 100 }
+ { POSTPONE: f BIN: 101 }
+ { object BIN: 110 }
+ { hi-tag BIN: 110 }
+ { tuple BIN: 111 }
} tag-numbers set
tag-numbers get H{
- { array 8 }
- { wrapper 9 }
- { byte-array 10 }
- { callstack 11 }
- { string 12 }
- { word 13 }
- { quotation 14 }
- { dll 15 }
- { alien 16 }
+ { wrapper 8 }
+ { byte-array 9 }
+ { callstack 10 }
+ { string 11 }
+ { word 12 }
+ { dll 13 }
+ { alien 14 }
} assoc-union type-numbers set
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 4466bd9bfe..e5a6bbe5fa 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic hashtables
hashtables.private io kernel math math.private math.order
@@ -12,8 +12,6 @@ IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
-crossref off
-
H{ } clone sub-primitives set
"vocab:bootstrap/syntax.factor" parse-file
@@ -71,6 +69,8 @@ bootstrapping? on
"classes.predicate"
"compiler.units"
"continuations.private"
+ "generic.single"
+ "generic.single.private"
"growable"
"hashtables"
"hashtables.private"
@@ -82,8 +82,10 @@ bootstrapping? on
"kernel"
"kernel.private"
"math"
+ "math.parser.private"
"math.private"
"memory"
+ "memory.private"
"quotations"
"quotations.private"
"sbufs"
@@ -99,7 +101,6 @@ bootstrapping? on
"threads.private"
"tools.profiler.private"
"words"
- "words.private"
"vectors"
"vectors.private"
} [ create-vocab drop ] each
@@ -127,9 +128,7 @@ bootstrapping? on
"fixnum" "math" create register-builtin
"bignum" "math" create register-builtin
"tuple" "kernel" create register-builtin
-"ratio" "math" create register-builtin
"float" "math" create register-builtin
-"complex" "math" create register-builtin
"f" "syntax" lookup register-builtin
"array" "arrays" create register-builtin
"wrapper" "kernel" create register-builtin
@@ -148,24 +147,6 @@ bootstrapping? on
"f?" "syntax" vocab-words delete-at
! Some unions
-"integer" "math" create
-"fixnum" "math" lookup
-"bignum" "math" lookup
-2array
-define-union-class
-
-"rational" "math" create
-"integer" "math" lookup
-"ratio" "math" lookup
-2array
-define-union-class
-
-"real" "math" create
-"rational" "math" lookup
-"float" "math" lookup
-2array
-define-union-class
-
"c-ptr" "alien" create [
"alien" "alien" lookup ,
"f" "syntax" lookup ,
@@ -212,19 +193,9 @@ bi
"bignum" "math" create { } define-builtin
"bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop
-"ratio" "math" create {
- { "numerator" { "integer" "math" } read-only }
- { "denominator" { "integer" "math" } read-only }
-} define-builtin
-
"float" "math" create { } define-builtin
"float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop
-"complex" "math" create {
- { "real" { "real" "math" } read-only }
- { "imaginary" { "real" "math" } read-only }
-} define-builtin
-
"array" "arrays" create {
{ "length" { "array-capacity" "sequences.private" } read-only }
} define-builtin
@@ -260,7 +231,7 @@ bi
"vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] }
"props"
- { "optimized" read-only }
+ { "direct-entry-def" }
{ "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only }
} define-builtin
@@ -340,7 +311,7 @@ tuple
[ create dup 1quotation ] dip define-declared ;
{
- { "(execute)" "words.private" (( word -- )) }
+ { "(execute)" "kernel.private" (( word -- )) }
{ "(call)" "kernel.private" (( quot -- )) }
{ "both-fixnums?" "math.private" (( x y -- ? )) }
{ "fixnum+fast" "math.private" (( x y -- z )) }
@@ -380,6 +351,7 @@ tuple
{ "get-local" "locals.backend" (( n -- obj )) }
{ "load-local" "locals.backend" (( obj -- )) }
{ "drop-locals" "locals.backend" (( n -- )) }
+ { "mega-cache-lookup" "generic.single.private" (( methods index cache -- )) }
} [ first3 make-sub-primitive ] each
! Primitive words
@@ -396,14 +368,12 @@ tuple
{ "float>bignum" "math.private" (( x -- y )) }
{ "fixnum>float" "math.private" (( x -- y )) }
{ "bignum>float" "math.private" (( x -- y )) }
- { "<ratio>" "math.private" (( a b -- a/b )) }
- { "string>float" "math.private" (( str -- n/f )) }
- { "float>string" "math.private" (( n -- str )) }
+ { "(string>float)" "math.parser.private" (( str -- n/f )) }
+ { "(float>string)" "math.parser.private" (( n -- str )) }
{ "float>bits" "math" (( x -- n )) }
{ "double>bits" "math" (( x -- n )) }
{ "bits>float" "math" (( n -- x )) }
{ "bits>double" "math" (( n -- x )) }
- { "<complex>" "math.private" (( x y -- z )) }
{ "fixnum+" "math.private" (( x y -- z )) }
{ "fixnum-" "math.private" (( x y -- z )) }
{ "fixnum*" "math.private" (( x y -- z )) }
@@ -446,8 +416,8 @@ tuple
{ "(exists?)" "io.files.private" (( path -- ? )) }
{ "gc" "memory" (( -- )) }
{ "gc-stats" "memory" f }
- { "save-image" "memory" (( path -- )) }
- { "save-image-and-exit" "memory" (( path -- )) }
+ { "(save-image)" "memory.private" (( path -- )) }
+ { "(save-image-and-exit)" "memory.private" (( path -- )) }
{ "datastack" "kernel" (( -- ds )) }
{ "retainstack" "kernel" (( -- rs )) }
{ "callstack" "kernel" (( -- cs )) }
@@ -459,38 +429,38 @@ tuple
{ "code-room" "memory" (( -- code-free code-total )) }
{ "micros" "system" (( -- us )) }
{ "modify-code-heap" "compiler.units" (( alist -- )) }
- { "dlopen" "alien.libraries" (( path -- dll )) }
- { "dlsym" "alien.libraries" (( name dll -- alien )) }
+ { "(dlopen)" "alien.libraries" (( path -- dll )) }
+ { "(dlsym)" "alien.libraries" (( name dll -- alien )) }
{ "dlclose" "alien.libraries" (( dll -- )) }
{ "<byte-array>" "byte-arrays" (( n -- byte-array )) }
{ "(byte-array)" "byte-arrays" (( n -- byte-array )) }
{ "<displaced-alien>" "alien" (( displacement c-ptr -- alien )) }
- { "alien-signed-cell" "alien.accessors" f }
- { "set-alien-signed-cell" "alien.accessors" f }
- { "alien-unsigned-cell" "alien.accessors" f }
- { "set-alien-unsigned-cell" "alien.accessors" f }
- { "alien-signed-8" "alien.accessors" f }
- { "set-alien-signed-8" "alien.accessors" f }
- { "alien-unsigned-8" "alien.accessors" f }
- { "set-alien-unsigned-8" "alien.accessors" f }
- { "alien-signed-4" "alien.accessors" f }
- { "set-alien-signed-4" "alien.accessors" f }
- { "alien-unsigned-4" "alien.accessors" f }
- { "set-alien-unsigned-4" "alien.accessors" f }
- { "alien-signed-2" "alien.accessors" f }
- { "set-alien-signed-2" "alien.accessors" f }
- { "alien-unsigned-2" "alien.accessors" f }
- { "set-alien-unsigned-2" "alien.accessors" f }
- { "alien-signed-1" "alien.accessors" f }
- { "set-alien-signed-1" "alien.accessors" f }
- { "alien-unsigned-1" "alien.accessors" f }
- { "set-alien-unsigned-1" "alien.accessors" f }
- { "alien-float" "alien.accessors" f }
- { "set-alien-float" "alien.accessors" f }
- { "alien-double" "alien.accessors" f }
- { "set-alien-double" "alien.accessors" f }
- { "alien-cell" "alien.accessors" f }
- { "set-alien-cell" "alien.accessors" f }
+ { "alien-signed-cell" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-cell" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-cell" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-cell" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-signed-8" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-8" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-8" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-8" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-signed-4" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-4" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-4" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-4" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-signed-2" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-2" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-2" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-2" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-signed-1" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-signed-1" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-unsigned-1" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-unsigned-1" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-float" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-float" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-double" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-double" "alien.accessors" (( value c-ptr n -- )) }
+ { "alien-cell" "alien.accessors" (( c-ptr n -- value )) }
+ { "set-alien-cell" "alien.accessors" (( value c-ptr n -- )) }
{ "alien-address" "alien" (( c-ptr -- addr )) }
{ "set-slot" "slots.private" (( value obj n -- )) }
{ "string-nth" "strings.private" (( n string -- ch )) }
@@ -504,7 +474,7 @@ tuple
{ "end-scan" "memory" (( -- )) }
{ "size" "memory" (( obj -- n )) }
{ "die" "kernel" (( -- )) }
- { "fopen" "io.streams.c" (( path mode -- alien )) }
+ { "(fopen)" "io.streams.c" (( path mode -- alien )) }
{ "fgetc" "io.streams.c" (( alien -- ch/f )) }
{ "fread" "io.streams.c" (( n alien -- str/f )) }
{ "fputc" "io.streams.c" (( ch alien -- )) }
@@ -528,13 +498,21 @@ tuple
{ "set-innermost-frame-quot" "kernel.private" (( n callstack -- )) }
{ "call-clear" "kernel" (( quot -- )) }
{ "resize-byte-array" "byte-arrays" (( n byte-array -- newbyte-array )) }
- { "dll-valid?" "alien" (( dll -- ? )) }
+ { "dll-valid?" "alien.libraries" (( dll -- ? )) }
{ "unimplemented" "kernel.private" (( -- * )) }
{ "gc-reset" "memory" (( -- )) }
{ "jit-compile" "quotations" (( quot -- )) }
{ "load-locals" "locals.backend" (( ... n -- )) }
{ "check-datastack" "kernel.private" (( array in# out# -- ? )) }
+ { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) }
+ { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) }
+ { "lookup-method" "generic.single.private" (( object methods -- method )) }
+ { "reset-dispatch-stats" "generic.single" (( -- )) }
+ { "dispatch-stats" "generic.single" (( -- stats )) }
+ { "reset-inline-cache-stats" "generic.single" (( -- )) }
+ { "inline-cache-stats" "generic.single" (( -- stats )) }
+ { "optimized?" "words" (( word -- ? )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
-"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared
+"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared
diff --git a/core/bootstrap/syntax-docs.factor b/core/bootstrap/syntax-docs.factor
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index 6e6812e25c..55b92df215 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -16,6 +16,7 @@ IN: bootstrap.syntax
"<PRIVATE"
"BIN:"
"B{"
+ "BV{"
"C:"
"CHAR:"
"DEFER:"
@@ -62,6 +63,7 @@ IN: bootstrap.syntax
"W{"
"["
"\\"
+ "M\\"
"]"
"delimiter"
"f"
diff --git a/basis/byte-vectors/byte-vectors-docs.factor b/core/byte-vectors/byte-vectors-docs.factor
similarity index 100%
rename from basis/byte-vectors/byte-vectors-docs.factor
rename to core/byte-vectors/byte-vectors-docs.factor
diff --git a/basis/byte-vectors/byte-vectors-tests.factor b/core/byte-vectors/byte-vectors-tests.factor
similarity index 100%
rename from basis/byte-vectors/byte-vectors-tests.factor
rename to core/byte-vectors/byte-vectors-tests.factor
diff --git a/basis/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor
similarity index 80%
rename from basis/byte-vectors/byte-vectors.factor
rename to core/byte-vectors/byte-vectors.factor
index 970f4abbd8..c273cea867 100644
--- a/basis/byte-vectors/byte-vectors.factor
+++ b/core/byte-vectors/byte-vectors.factor
@@ -1,8 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel kernel.private math sequences
-sequences.private growable byte-arrays accessors parser
-prettyprint.custom ;
+sequences.private growable byte-arrays accessors ;
IN: byte-vectors
TUPLE: byte-vector
@@ -42,10 +41,4 @@ M: byte-array like
M: byte-array new-resizable drop <byte-vector> ;
-SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ;
-
-M: byte-vector pprint* pprint-object ;
-M: byte-vector pprint-delims drop \ BV{ \ } ;
-M: byte-vector >pprint-sequence ;
-
INSTANCE: byte-vector growable
diff --git a/basis/byte-vectors/summary.txt b/core/byte-vectors/summary.txt
similarity index 100%
rename from basis/byte-vectors/summary.txt
rename to core/byte-vectors/summary.txt
diff --git a/basis/byte-vectors/tags.txt b/core/byte-vectors/tags.txt
similarity index 100%
rename from basis/byte-vectors/tags.txt
rename to core/byte-vectors/tags.txt
diff --git a/core/checksums/checksums-tests.factor b/core/checksums/checksums-tests.factor
index 1ec675b0cf..8ba09d8e91 100644
--- a/core/checksums/checksums-tests.factor
+++ b/core/checksums/checksums-tests.factor
@@ -1,7 +1,3 @@
IN: checksums.tests
USING: checksums tools.test ;
-\ checksum-bytes must-infer
-\ checksum-stream must-infer
-\ checksum-lines must-infer
-\ checksum-file must-infer
diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor
index 98d36b21c3..82918b6f81 100644
--- a/core/checksums/checksums.factor
+++ b/core/checksums/checksums.factor
@@ -13,7 +13,7 @@ GENERIC: checksum-stream ( stream checksum -- value )
GENERIC: checksum-lines ( lines checksum -- value )
M: checksum checksum-stream
- [ contents ] dip checksum-bytes ;
+ [ stream-contents ] dip checksum-bytes ;
M: checksum checksum-lines
[ B{ CHAR: \n } join ] dip checksum-bytes ;
diff --git a/core/checksums/crc32/crc32.factor b/core/checksums/crc32/crc32.factor
index 47da144d4d..7655ec8482 100644
--- a/core/checksums/crc32/crc32.factor
+++ b/core/checksums/crc32/crc32.factor
@@ -9,7 +9,7 @@ CONSTANT: crc32-polynomial HEX: edb88320
CONSTANT: crc32-table V{ }
-256 [
+256 iota [
8 [
[ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
] times >bignum
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index a3610ff7c5..3069c4b555 100644
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -7,12 +7,6 @@ random stack-checker effects kernel.private sbufs math.order
classes.tuple accessors ;
IN: classes.algebra.tests
-\ class< must-infer
-\ class-and must-infer
-\ class-or must-infer
-\ flatten-class must-infer
-\ flatten-builtin-class must-infer
-
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
@@ -311,7 +305,16 @@ SINGLETON: sc
[ sa ] [ sa { sa sb sc } min-class ] unit-test
+[ f ] [ sa sb classes-intersect? ] unit-test
+
[ +lt+ ] [ integer sequence class<=> ] unit-test
[ +lt+ ] [ sequence object class<=> ] unit-test
[ +gt+ ] [ object sequence class<=> ] unit-test
[ +eq+ ] [ integer integer class<=> ] unit-test
+
+! Limitations:
+
+! UNION: u1 sa sb ;
+! UNION: u2 sc ;
+
+! [ f ] [ u1 u2 classes-intersect? ] unit-test
\ No newline at end of file
diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
index 0e4a3b56fd..32f7af8113 100644
--- a/core/classes/builtin/builtin.factor
+++ b/core/classes/builtin/builtin.factor
@@ -33,13 +33,13 @@ M: lo-tag-class define-builtin-predicate
M: hi-tag-class define-builtin-predicate
dup class>type [ eq? ] curry [ hi-tag ] prepend 1quotation
- [ dup tag 3 eq? ] [ [ drop f ] if ] surround
+ [ dup tag 6 eq? ] [ [ drop f ] if ] surround
define-predicate ;
M: lo-tag-class instance? [ tag ] [ class>type ] bi* eq? ;
M: hi-tag-class instance?
- over tag 3 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
+ over tag 6 eq? [ [ hi-tag ] [ class>type ] bi* eq? ] [ 2drop f ] if ;
M: builtin-class (flatten-class) dup set ;
@@ -55,7 +55,7 @@ M: anonymous-intersection (flatten-class)
[
builtins get sift [ (flatten-class) ] each
] [
- unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
+ [ ] [ assoc-intersect ] map-reduce [ swap set ] assoc-each
] if-empty ;
M: anonymous-complement (flatten-class)
diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor
index 673c108b27..61d153f064 100644
--- a/core/classes/classes-tests.factor
+++ b/core/classes/classes-tests.factor
@@ -3,7 +3,7 @@ io.streams.string kernel math namespaces parser prettyprint
sequences strings tools.test vectors words quotations classes
classes.private classes.union classes.mixin classes.predicate
classes.algebra vectors definitions source-files compiler.units
-kernel.private sorting vocabs memory eval accessors ;
+kernel.private sorting vocabs memory eval accessors sets ;
IN: classes.tests
[ t ] [ 3 object instance? ] unit-test
@@ -22,17 +22,18 @@ M: method-forget-class method-forget-test ;
[ ] [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
[ t ] [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
-[ t ] [
+[ { } { } ] [
all-words [ class? ] filter
implementors-map get keys
- [ natural-sort ] bi@ =
+ [ natural-sort ] bi@
+ [ diff ] [ swap diff ] 2bi
] unit-test
! Minor leak
-[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test
+[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval( -- ) ] unit-test
[ ] [ f \ word set-global ] unit-test
-[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test
-[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test
+[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tests FORGET: forget-me" eval( -- ) ] unit-test
[ 0 ] [
[ word? ] instances
[ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index eded33beed..dfaec95f76 100644
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -135,7 +135,7 @@ M: sequence implementors [ implementors ] gather ;
[ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
[ reset-class ]
[ ?define-symbol ]
- [ redefined ]
+ [ changed-definition ]
[ ]
} cleave
] dip [ assoc-union ] curry change-props
@@ -174,8 +174,7 @@ GENERIC: update-methods ( class seq -- )
[ forget ] [ drop ] if
] [ 2drop ] if ;
-: forget-methods ( class -- )
- [ implementors ] [ [ swap 2array ] curry ] bi map forget-all ;
+GENERIC: forget-methods ( class -- )
GENERIC: class-forgotten ( use class -- )
diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor
index 376eace4ed..f44642fdd5 100644
--- a/core/classes/mixin/mixin-tests.factor
+++ b/core/classes/mixin/mixin-tests.factor
@@ -42,7 +42,7 @@ INSTANCE: integer mx1
[ t ] [ mx1 integer class<= ] unit-test
[ t ] [ mx1 number class<= ] unit-test
-"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval
+"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- )
[ t ] [ array mx1 class<= ] unit-test
[ f ] [ mx1 number class<= ] unit-test
@@ -118,4 +118,14 @@ MIXIN: move-instance-declaration-mixin
[ ] [ "IN: classes.mixin.tests.a" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
-[ { string } ] [ move-instance-declaration-mixin members ] unit-test
\ No newline at end of file
+[ { string } ] [ move-instance-declaration-mixin members ] unit-test
+
+MIXIN: silly-mixin
+SYMBOL: not-a-class
+
+[ [ \ not-a-class \ silly-mixin add-mixin-instance ] with-compilation-unit ] must-fail
+
+SYMBOL: not-a-mixin
+TUPLE: a-class ;
+
+[ [ \ a-class \ not-a-mixin add-mixin-instance ] with-compilation-unit ] must-fail
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index 4bdb893d9a..6cf95716be 100644
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -50,7 +50,9 @@ TUPLE: check-mixin-class class ;
[ [ f ] 2dip "instances" word-prop set-at ]
2bi ;
-: add-mixin-instance ( class mixin -- )
+GENERIC# add-mixin-instance 1 ( class mixin -- )
+
+M: class add-mixin-instance
#! Note: we call update-classes on the new member, not the
#! mixin. This ensures that we only have to update the
#! methods whose specializer intersects the new member, not
diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index 22b5784269..b95507c78b 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -50,20 +50,20 @@ TUPLE: test-8 { b integer read-only } ;
DEFER: foo
-[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ]
+[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval( -- ) ]
[ error>> invalid-slot-name? ]
must-fail-with
-[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ]
+[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval( -- ) ]
[ error>> invalid-slot-name? ]
must-fail-with
-[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ]
+[ "IN: classes.tuple.parser.tests TUPLE: foo" eval( -- ) ]
[ error>> unexpected-eof? ]
must-fail-with
2 [
- [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ]
+ [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval( -- ) ]
[ error>> no-initial-value? ]
must-fail-with
@@ -71,14 +71,14 @@ must-fail-with
] times
2 [
- [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ]
+ [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval( -- ) ]
[ error>> bad-initial-value? ]
must-fail-with
[ f ] [ \ foo tuple-class? ] unit-test
] times
-[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ]
+[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval( -- ) ]
[ error>> duplicate-slot-names? ]
must-fail-with
@@ -107,7 +107,7 @@ TUPLE: parsing-corner-case x ;
" f"
" 3"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
@@ -116,7 +116,7 @@ TUPLE: parsing-corner-case x ;
"T{ parsing-corner-case"
" { x 3 }"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
@@ -125,7 +125,7 @@ TUPLE: parsing-corner-case x ;
"T{ parsing-corner-case {"
" x 3 }"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
@@ -133,12 +133,12 @@ TUPLE: parsing-corner-case x ;
{
"USE: classes.tuple.parser.tests T{ parsing-corner-case"
" { x 3 }"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
[
{
"USE: classes.tuple.parser.tests T{ parsing-corner-case {"
" x 3 }"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] [ error>> unexpected-eof? ] must-fail-with
diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
index 5e12322a48..85a6249dd3 100644
--- a/core/classes/tuple/parser/parser.factor
+++ b/core/classes/tuple/parser/parser.factor
@@ -89,11 +89,14 @@ ERROR: bad-literal-tuple ;
swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
[ dup <enum> ] dip update boa>tuple ;
-: parse-tuple-literal ( -- tuple )
- scan-word scan {
+: parse-tuple-literal-slots ( class -- tuple )
+ scan {
{ f [ unexpected-eof ] }
{ "f" [ \ } parse-until boa>tuple ] }
{ "{" [ parse-slot-values assoc>tuple ] }
{ "}" [ new ] }
[ bad-literal-tuple ]
} case ;
+
+: parse-tuple-literal ( -- tuple )
+ scan-word parse-tuple-literal-slots ;
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 32cab65904..4c55001aa1 100644
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -92,7 +92,7 @@ ARTICLE: "tuple-constructors" "Tuple constructors"
$nl
"Constructors play a part in enforcing the invariant that slot values must always match slot declarations. The " { $link new } " word fills in the tuple with initial values, and " { $link boa } " ensures that the values on the stack match the corresponding slot declarations. See " { $link "tuple-declarations" } "."
$nl
-"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construt a different class, without breaking callers."
+"All tuple construction should be done through constructor words, and construction primitives should be encapsulated and never called outside of the vocabulary where the class is defined, because this encourages looser coupling. For example, a constructor word could be changed to use memoization instead of always constructing a new instance, or it could be changed to construct a different class, without breaking callers."
$nl
"Examples of constructors:"
{ $code
@@ -220,13 +220,13 @@ ARTICLE: "tuple-examples" "Tuple examples"
" <employee> \"project manager\" >>position ;" }
"An alternative strategy is to define the most general BOA constructor first:"
{ $code
- ": <employee> ( name position -- person )"
+ ": <employee> ( name position -- employee )"
" 40000 employee boa ;"
}
"Now we can define more specific constructors:"
{ $code
- ": <manager> ( name -- person )"
- " \"manager\" <person> ;" }
+ ": <manager> ( name -- employee )"
+ " \"manager\" <employee> ;" }
"An example using reader words:"
{ $code
"TUPLE: check to amount number ;"
@@ -254,9 +254,9 @@ ARTICLE: "tuple-examples" "Tuple examples"
" } ;"
""
": next-position ( role -- newrole )"
- " positions [ index 1+ ] keep nth ;"
+ " positions [ index 1 + ] keep nth ;"
""
- ": promote ( person -- person )"
+ ": promote ( employee -- employee )"
" [ 1.2 * ] change-salary"
" [ next-position ] change-position ;"
}
diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index fa2df4e312..466b221877 100644
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -1,11 +1,11 @@
-USING: definitions generic kernel kernel.private math
-math.constants parser sequences tools.test words assocs
-namespaces quotations sequences.private classes continuations
-generic.standard effects classes.tuple classes.tuple.private
-arrays vectors strings compiler.units accessors classes.algebra
-calendar prettyprint io.streams.string splitting summary
-columns math.order classes.private slots slots.private eval see
-words.symbol ;
+USING: definitions generic kernel kernel.private math math.constants
+parser sequences tools.test words assocs namespaces quotations
+sequences.private classes continuations generic.single
+generic.standard effects classes.tuple classes.tuple.private arrays
+vectors strings compiler.units accessors classes.algebra calendar
+prettyprint io.streams.string splitting summary columns math.order
+classes.private slots slots.private eval see words.symbol
+compiler.errors ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
@@ -27,19 +27,17 @@ C: <redefinition-test> redefinition-test
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
-"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval
+"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- )
[ t ] [ "redefinition-test" get redefinition-test? ] unit-test
! Make sure we handle changing shapes!
TUPLE: point x y ;
-C: <point> point
-
-[ ] [ 100 200 <point> "p" set ] unit-test
+[ ] [ 100 200 point boa "p" set ] unit-test
! Use eval to sequence parsing explicitly
-[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test
[ 100 ] [ "p" get x>> ] unit-test
[ 200 ] [ "p" get y>> ] unit-test
@@ -51,7 +49,7 @@ C: <point> point
[ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test
[ 2 ] [ "p" get tuple-size ] unit-test
@@ -89,7 +87,7 @@ C: <empty> empty
[ t length ] [ object>> t eq? ] must-fail-with
[ "<constructor-test>" ]
-[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval word name>> ] unit-test
+[ "IN: classes.tuple.test TUPLE: constructor-test ; C: <constructor-test> constructor-test" eval( -- ) word name>> ] unit-test
TUPLE: size-test a b c d ;
@@ -102,7 +100,7 @@ GENERIC: <yo-momma> ( a -- b )
TUPLE: yo-momma ;
-[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests C: <yo-momma> yo-momma" eval( -- ) ] unit-test
[ f ] [ \ <yo-momma> generic? ] unit-test
@@ -112,8 +110,6 @@ TUPLE: yo-momma ;
[ ] [ \ yo-momma forget ] unit-test
[ ] [ \ <yo-momma> forget ] unit-test
[ f ] [ \ yo-momma update-map get values memq? ] unit-test
-
- [ f ] [ \ yo-momma crossref get at ] unit-test
] with-compilation-unit
TUPLE: loc-recording ;
@@ -133,7 +129,7 @@ M: integer forget-robustness-generic ;
[
[ ] [ \ forget-robustness-generic forget ] unit-test
[ ] [ \ forget-robustness forget ] unit-test
- [ ] [ { forget-robustness forget-robustness-generic } forget ] unit-test
+ [ ] [ M\ forget-robustness forget-robustness-generic forget ] unit-test
] with-compilation-unit
! rapido found this one
@@ -199,17 +195,6 @@ TUPLE: erg's-reshape-problem a b c d ;
C: <erg's-reshape-problem> erg's-reshape-problem
-! We want to make sure constructors are recompiled when
-! tuples are reshaped
-: cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ;
-: cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ;
-
-[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test
-
-[ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test
-
-[ t ] [ cons-test-1 tuple-size "a" get tuple-size = ] unit-test
-
! Inheritance
TUPLE: computer cpu ram ;
C: <computer> computer
@@ -281,13 +266,13 @@ test-server-slot-values
] unit-test
[
- "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval
+ "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval( -- )
] must-fail
! Dynamically changing inheritance hierarchy
TUPLE: electronic-device ;
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
[ f ] [ electronic-device laptop class<= ] unit-test
[ t ] [ server electronic-device class<= ] unit-test
@@ -303,17 +288,17 @@ TUPLE: electronic-device ;
[ f ] [ "server" get laptop? ] unit-test
[ t ] [ "server" get server? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
[ f ] [ "laptop" get electronic-device? ] unit-test
[ t ] [ "laptop" get computer? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
@@ -326,7 +311,7 @@ TUPLE: make-me-some-accessors voltage grounded? ;
[ ] [ "laptop" get 220 >>voltage drop ] unit-test
[ ] [ "server" get 110 >>voltage drop ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ; C: <computer> computer" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
@@ -334,7 +319,7 @@ test-server-slot-values
[ 220 ] [ "laptop" get voltage>> ] unit-test
[ 110 ] [ "server" get voltage>> ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
@@ -343,7 +328,7 @@ test-server-slot-values
[ 110 ] [ "server" get voltage>> ] unit-test
! Reshaping superclass and subclass simultaneously
-[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ; C: <computer> computer C: <laptop> laptop C: <server> server" eval( -- ) ] unit-test
test-laptop-slot-values
test-server-slot-values
@@ -354,9 +339,7 @@ test-server-slot-values
! Reshape crash
TUPLE: test1 a ; TUPLE: test2 < test1 b ;
-C: <test2> test2
-
-"a" "b" <test2> "test" set
+"a" "b" test2 boa "test" set
: test-a/b ( -- )
[ "a" ] [ "test" get a>> ] unit-test
@@ -364,11 +347,11 @@ C: <test2> test2
test-a/b
-[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test
test-a/b
-[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test
test-a/b
@@ -393,34 +376,36 @@ T{ move-up-2 f "a" "b" "c" } "move-up" set
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test
test-move-up
-[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test
! Constructors must be recompiled when changing superclass
TUPLE: constructor-update-1 xxx ;
TUPLE: constructor-update-2 < constructor-update-1 yyy zzz ;
-C: <constructor-update-2> constructor-update-2
+: <constructor-update-2> ( a b c -- tuple ) constructor-update-2 boa ;
{ 3 1 } [ <constructor-update-2> ] must-infer-as
-[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test
-{ 5 1 } [ <constructor-update-2> ] must-infer-as
+{ 3 1 } [ <constructor-update-2> ] must-infer-as
-[ { 1 2 3 4 5 } ] [ 1 2 3 4 5 <constructor-update-2> tuple-slots ] unit-test
+[ 1 2 3 4 5 <constructor-update-2> ] [ not-compiled? ] must-fail-with
+
+[ ] [ [ \ <constructor-update-2> forget ] with-compilation-unit ] unit-test
! Redefinition problem
TUPLE: redefinition-problem ;
@@ -431,7 +416,7 @@ UNION: redefinition-problem' redefinition-problem integer ;
TUPLE: redefinition-problem-2 ;
-"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval
+"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval( -- )
[ t ] [ 3 redefinition-problem'? ] unit-test
@@ -472,7 +457,7 @@ USE: vocabs
] with-compilation-unit
] unit-test
-[ "USE: words T{ word }" eval ]
+[ "USE: words T{ word }" eval( -- ) ]
[ error>> T{ no-method f word new } = ]
must-fail-with
@@ -485,7 +470,7 @@ must-fail-with
[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test
-: accessor-exists? ( class name -- ? )
+: accessor-exists? ( name -- ? )
[ "forget-accessors-test" "classes.tuple.tests" lookup ] dip
">>" append "accessors" lookup method >boolean ;
@@ -520,13 +505,13 @@ TUPLE: another-forget-accessors-test ;
[ f ] [
t parser-notes? [
[
- "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval
+ "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval( -- )
] with-string-writer empty?
] with-variable
] unit-test
! Missing error check
-[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
+[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail
! Class forget messyness
TUPLE: subclass-forget-test ;
@@ -535,7 +520,7 @@ TUPLE: subclass-forget-test-1 < subclass-forget-test ;
TUPLE: subclass-forget-test-2 < subclass-forget-test ;
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
-[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval( -- ) ] unit-test
[ { subclass-forget-test-2 } ]
[ subclass-forget-test-2 class-usages ]
@@ -549,7 +534,7 @@ unit-test
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
[ subclass-forget-test-3 new ] must-fail
-[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail
+[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval( -- ) ] must-fail
! More
DEFER: subclass-reset-test
@@ -559,14 +544,14 @@ DEFER: subclass-reset-test-3
GENERIC: break-me ( obj -- )
-[ ] [ [ { integer break-me } forget ] with-compilation-unit ] unit-test
+[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval( -- ) ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval( -- ) ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval( -- ) ] unit-test
[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
@@ -576,7 +561,7 @@ GENERIC: break-me ( obj -- )
[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval( -- ) ] unit-test
[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
@@ -599,7 +584,7 @@ must-fail-with
: foo ( a b -- c ) declared-types boa ;
-\ foo must-infer
+\ foo def>> must-infer
[ T{ declared-types f 0 "hi" } ] [ 0.0 "hi" foo ] unit-test
@@ -623,7 +608,7 @@ must-fail-with
: blah ( -- vec ) vector new ;
-\ blah must-infer
+[ vector new ] must-infer
[ V{ } ] [ blah ] unit-test
@@ -632,7 +617,7 @@ TUPLE: reshape-test x ;
T{ reshape-test f "hi" } "tuple" set
-[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test
[ f ] [ \ reshape-test \ (>>x) method ] unit-test
@@ -640,11 +625,11 @@ T{ reshape-test f "hi" } "tuple" set
[ "hi" ] [ "tuple" get x>> ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test
-[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test
[ 0 ] [ "tuple" get x>> ] unit-test
@@ -660,20 +645,20 @@ ERROR: error-class-test a b c ;
[ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test
[ f ] [ \ error-class-test "inline" word-prop ] unit-test
-[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ]
+[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ]
[ error>> error>> redefine-error? ] must-fail-with
DEFER: error-y
[ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test
-[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test
[ f ] [ \ error-y tuple-class? ] unit-test
[ t ] [ \ error-y generic? ] unit-test
-[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test
[ t ] [ \ error-y tuple-class? ] unit-test
@@ -694,7 +679,7 @@ DEFER: error-y
] unit-test
[ ] [
- "IN: sequences TUPLE: reversed { seq read-only } ;" eval
+ "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- )
] unit-test
TUPLE: bogus-hashcode-1 x ;
@@ -735,14 +720,14 @@ SLOT: kex
DEFER: redefine-tuple-twice
-[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
-[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test
[ t ] [ \ redefine-tuple-twice deferred? ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test
+[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
-[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
\ No newline at end of file
+[ t ] [ \ redefine-tuple-twice symbol? ] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index fb7a073205..225176f4e5 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -165,7 +165,7 @@ ERROR: bad-superclass class ;
{
[ , ]
[ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
- [ superclasses length 1- , ]
+ [ superclasses length 1 - , ]
[ superclasses [ [ , ] [ hashcode , ] bi ] each ]
} cleave
] { } make ;
@@ -243,7 +243,7 @@ M: tuple-class update-class
2drop
[
[ update-tuples-after ]
- [ redefined ]
+ [ changed-definition ]
bi
] each-subclass
]
@@ -331,7 +331,7 @@ GENERIC: tuple-hashcode ( n tuple -- x )
M: tuple tuple-hashcode
[
- [ class hashcode ] [ tuple-size ] [ ] tri
+ [ class hashcode ] [ tuple-size iota ] [ ] tri
[ rot ] dip [
swapd array-nth hashcode* sequence-hashcode-step
] 2curry each
diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor
index 57b742595f..52550b2356 100644
--- a/core/classes/union/union-tests.factor
+++ b/core/classes/union/union-tests.factor
@@ -26,13 +26,13 @@ M: union-1 generic-update-test drop "union-1" ;
[ t ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ 1.0 generic-update-test ] unit-test
-"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
+"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval( -- )
[ t ] [ bignum union-1 class<= ] unit-test
[ f ] [ union-1 number class<= ] unit-test
[ "union-1" ] [ { 1.0 } generic-update-test ] unit-test
-"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval
+"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval( -- )
[ f ] [ union-1 union-class? ] unit-test
[ t ] [ union-1 predicate-class? ] unit-test
@@ -58,7 +58,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
[ t ] [ fixnum redefine-bug-2 class<= ] unit-test
[ t ] [ quotation redefine-bug-2 class<= ] unit-test
-[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
+[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval( -- ) ] unit-test
[ t ] [ bignum redefine-bug-1 class<= ] unit-test
[ f ] [ fixnum redefine-bug-2 class<= ] unit-test
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
old mode 100644
new mode 100755
index cc502140ad..8b301affbd
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@@ -4,46 +4,309 @@ math assocs sequences sequences.private combinators.private
effects words ;
IN: combinators
+ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
+"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
+{ $code
+ ": keep [ ] bi ;"
+ ": 2keep [ ] 2bi ;"
+ ": 3keep [ ] 3bi ;"
+ ""
+ ": dup [ ] [ ] bi ;"
+ ": 2dup [ ] [ ] 2bi ;"
+ ": 3dup [ ] [ ] 3bi ;"
+ ""
+ ": tuck [ nip ] [ ] 2bi ;"
+ ": swap [ nip ] [ drop ] 2bi ;"
+ ""
+ ": over [ ] [ drop ] 2bi ;"
+ ": pick [ ] [ 2drop ] 3bi ;"
+ ": 2over [ ] [ drop ] 3bi ;"
+} ;
+
+ARTICLE: "cleave-combinators" "Cleave combinators"
+"The cleave combinators apply multiple quotations to a single value."
+$nl
+"Two quotations:"
+{ $subsection bi }
+{ $subsection 2bi }
+{ $subsection 3bi }
+"Three quotations:"
+{ $subsection tri }
+{ $subsection 2tri }
+{ $subsection 3tri }
+"An array of quotations:"
+{ $subsection cleave }
+{ $subsection 2cleave }
+{ $subsection 3cleave }
+"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
+{ $code
+ "! First alternative; uses keep"
+ "[ 1 + ] keep"
+ "[ 1 - ] keep"
+ "2 *"
+ "! Second alternative: uses tri"
+ "[ 1 + ]"
+ "[ 1 - ]"
+ "[ 2 * ] tri"
+}
+"The latter is more aesthetically pleasing than the former."
+{ $subsection "cleave-shuffle-equivalence" } ;
+
+ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
+"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "."
+$nl
+"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
+{ $code
+ ": dip [ ] bi* ;"
+ ": 2dip [ ] [ ] tri* ;"
+ ""
+ ": slip [ call ] [ ] bi* ;"
+ ": 2slip [ call ] [ ] [ ] tri* ;"
+ ""
+ ": nip [ drop ] [ ] bi* ;"
+ ": 2nip [ drop ] [ drop ] [ ] tri* ;"
+ ""
+ ": rot"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": -rot"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " 3tri ;"
+ ""
+ ": spin"
+ " [ [ drop ] [ drop ] [ ] tri* ]"
+ " [ [ drop ] [ ] [ drop ] tri* ]"
+ " [ [ ] [ drop ] [ drop ] tri* ]"
+ " 3tri ;"
+} ;
+
+ARTICLE: "spread-combinators" "Spread combinators"
+"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
+$nl
+"Two quotations:"
+{ $subsection bi* }
+{ $subsection 2bi* }
+"Three quotations:"
+{ $subsection tri* }
+{ $subsection 2tri* }
+"An array of quotations:"
+{ $subsection spread }
+"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
+{ $code
+ "! First alternative; uses dip"
+ "[ [ 1 + ] dip 1 - ] dip 2 *"
+ "! Second alternative: uses tri*"
+ "[ 1 + ] [ 1 - ] [ 2 * ] tri*"
+}
+"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
+{ $subsection "spread-shuffle-equivalence" } ;
+
+ARTICLE: "apply-combinators" "Apply combinators"
+"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
+$nl
+"Two quotations:"
+{ $subsection bi@ }
+{ $subsection 2bi@ }
+"Three quotations:"
+{ $subsection tri@ }
+{ $subsection 2tri@ }
+"A pair of utility words built from " { $link bi@ } ":"
+{ $subsection both? }
+{ $subsection either? } ;
+
+ARTICLE: "slip-keep-combinators" "Retain stack combinators"
+"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
+$nl
+"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
+{ $subsection dip }
+{ $subsection 2dip }
+{ $subsection 3dip }
+{ $subsection 4dip }
+"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
+{ $subsection slip }
+{ $subsection 2slip }
+{ $subsection 3slip }
+"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
+{ $subsection keep }
+{ $subsection 2keep }
+{ $subsection 3keep } ;
+
+ARTICLE: "curried-dataflow" "Curried dataflow combinators"
+"Curried cleave combinators:"
+{ $subsection bi-curry }
+{ $subsection tri-curry }
+"Curried spread combinators:"
+{ $subsection bi-curry* }
+{ $subsection tri-curry* }
+"Curried apply combinators:"
+{ $subsection bi-curry@ }
+{ $subsection tri-curry@ }
+{ $see-also "dataflow-combinators" } ;
+
+ARTICLE: "compositional-examples" "Examples of compositional combinator usage"
+"Consider printing the same message ten times:"
+{ $code ": print-10 ( -- ) 10 [ \"Hello, world.\" print ] times ;" }
+"if we wanted to abstract out the message into a parameter, we could keep it on the stack between iterations:"
+{ $code ": print-10 ( message -- ) 10 [ dup print ] times drop ;" }
+"However, keeping loop-invariant values on the stack doesn't always work out nicely. For example, a word to subtract a value from each element of a sequence:"
+{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" }
+"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":"
+{ $example
+ "USING: kernel math prettyprint sequences ;"
+ ": subtract-n ( seq n -- seq' ) [ - ] curry map ;"
+ "{ 10 20 30 } 5 subtract-n ."
+ "{ 5 15 25 }"
+}
+"Now consider the word that is dual to the one above; instead of subtracting " { $snippet "n" } " from each stack element, it subtracts each element from " { $snippet "n" } "."
+$nl
+"One way to write this is with a pair of " { $link swap } "s:"
+{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" }
+"Since this pattern comes up often, " { $link with } " encapsulates it:"
+{ $example
+ "USING: kernel math prettyprint sequences ;"
+ ": n-subtract ( n seq -- seq' ) [ - ] with map ;"
+ "30 { 10 20 30 } n-subtract ."
+ "{ 20 10 0 }"
+}
+{ $see-also "fry.examples" } ;
+
+ARTICLE: "compositional-combinators" "Compositional combinators"
+"Certain combinators transform quotations to produce a new quotation."
+{ $subsection "compositional-examples" }
+"Fundamental operations:"
+{ $subsection curry }
+{ $subsection compose }
+"Derived operations:"
+{ $subsection 2curry }
+{ $subsection 3curry }
+{ $subsection with }
+{ $subsection prepose }
+"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words."
+$nl
+"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways."
+{ $subsection "curried-dataflow" }
+"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ;
+
+ARTICLE: "booleans" "Booleans"
+"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
+{ $subsection f }
+{ $subsection t }
+"A union class of the above:"
+{ $subsection boolean }
+"There are some logical operations on booleans:"
+{ $subsection >boolean }
+{ $subsection not }
+{ $subsection and }
+{ $subsection or }
+{ $subsection xor }
+"Boolean values are most frequently used for " { $link "conditionals" } "."
+{ $heading "The f object and f class" }
+"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
+$nl
+"Here is the " { $link f } " object:"
+{ $example "f ." "f" }
+"Here is the " { $link f } " class:"
+{ $example "\\ f ." "POSTPONE: f" }
+"They are not equal:"
+{ $example "f \\ f = ." "f" }
+"Here is an array containing the " { $link f } " object:"
+{ $example "{ f } ." "{ f }" }
+"Here is an array containing the " { $link f } " class:"
+{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
+"The " { $link f } " object is an instance of the " { $link f } " class:"
+{ $example "USE: classes" "f class ." "POSTPONE: f" }
+"The " { $link f } " class is an instance of " { $link word } ":"
+{ $example "USE: classes" "\\ f class ." "word" }
+"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
+{ $example "t \\ t eq? ." "t" }
+"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
+
+ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
+"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
+$nl
+"The following two lines are equivalent:"
+{ $code "[ drop f ] unless" "swap and" }
+"The following two lines are equivalent:"
+{ $code "[ ] [ ] ?if" "swap or" }
+"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
+{ $code "[ L ] unless*" "L or" } ;
+
+ARTICLE: "conditionals" "Conditional combinators"
+"The basic conditionals:"
+{ $subsection if }
+{ $subsection when }
+{ $subsection unless }
+"Forms abstracting a common stack shuffle pattern:"
+{ $subsection if* }
+{ $subsection when* }
+{ $subsection unless* }
+"Another form abstracting a common stack shuffle pattern:"
+{ $subsection ?if }
+"Sometimes instead of branching, you just need to pick one of two values:"
+{ $subsection ? }
+"Two combinators which abstract out nested chains of " { $link if } ":"
+{ $subsection cond }
+{ $subsection case }
+{ $subsection "conditionals-boolean-equivalence" }
+{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
+
+ARTICLE: "dataflow-combinators" "Data flow combinators"
+"Data flow combinators pass values between quotations:"
+{ $subsection "slip-keep-combinators" }
+{ $subsection "cleave-combinators" }
+{ $subsection "spread-combinators" }
+{ $subsection "apply-combinators" }
+{ $see-also "curried-dataflow" } ;
+
ARTICLE: "combinators-quot" "Quotation construction utilities"
"Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
{ $subsection cond>quot }
{ $subsection case>quot }
{ $subsection alist>quot } ;
-ARTICLE: "call" "Calling code with known stack effects"
-"Arbitrary quotations and words can be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
-$nl
-"Quotations:"
-{ $subsection POSTPONE: call( }
-{ $subsection call-effect }
-"Words:"
-{ $subsection POSTPONE: execute( }
-{ $subsection execute-effect }
-"Unsafe calls:"
+ARTICLE: "call-unsafe" "Unsafe combinators"
+"Unsafe calls declare an effect statically without any runtime checking:"
{ $subsection call-effect-unsafe }
{ $subsection execute-effect-unsafe } ;
-ARTICLE: "combinators" "Additional combinators"
-"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
+ARTICLE: "call" "Fundamental combinators"
+"The most basic combinators are those that take either a quotation or word, and invoke it immediately."
$nl
-"Generalization of " { $link bi } " and " { $link tri } ":"
-{ $subsection cleave }
-"Generalization of " { $link 2bi } " and " { $link 2tri } ":"
-{ $subsection 2cleave }
-"Generalization of " { $link 3bi } " and " { $link 3tri } ":"
-{ $subsection 3cleave }
-"Generalization of " { $link bi* } " and " { $link tri* } ":"
-{ $subsection spread }
-"Two combinators which abstract out nested chains of " { $link if } ":"
-{ $subsection cond }
-{ $subsection case }
-"The " { $vocab-link "combinators" } " also provides some less frequently-used features."
+"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared."
$nl
-"A combinator which can help with implementing methods on " { $link hashcode* } ":"
-{ $subsection recursive-hashcode }
+"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
+{ $subsection call }
+{ $subsection execute }
+"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:"
+{ $subsection POSTPONE: call( }
+{ $subsection POSTPONE: execute( }
+"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
+{ $subsection call-effect }
+{ $subsection execute-effect }
+"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "."
+{ $subsection "call-unsafe" }
+{ $see-also "effects" "inference" } ;
+
+ARTICLE: "combinators" "Combinators"
+"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
{ $subsection "call" }
+{ $subsection "dataflow-combinators" }
+{ $subsection "conditionals" }
+{ $subsection "looping-combinators" }
+{ $subsection "compositional-combinators" }
+{ $subsection "combinators.short-circuit" }
+{ $subsection "combinators.smart" }
+"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
{ $subsection "combinators-quot" }
-{ $see-also "quotations" "dataflow" } ;
+{ $subsection "generalizations" }
+{ $see-also "quotations" } ;
ABOUT: "combinators"
diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor
old mode 100644
new mode 100755
index 76f9f63c49..aae6618ee8
--- a/core/combinators/combinators-tests.factor
+++ b/core/combinators/combinators-tests.factor
@@ -16,12 +16,12 @@ IN: combinators.tests
: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ;
-[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test
+[ t ] [ \ compile-execute(-test-1 optimized? ] unit-test
[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test
: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ;
-[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test
+[ t ] [ \ compile-execute(-test-2 optimized? ] unit-test
[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test
[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test
[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test
@@ -29,7 +29,7 @@ IN: combinators.tests
: compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ;
-[ t ] [ \ compile-call(-test-1 optimized>> ] unit-test
+[ t ] [ \ compile-call(-test-1 optimized? ] unit-test
[ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test
[ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test
[ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test
@@ -42,7 +42,7 @@ IN: combinators.tests
{ [ dup 2 mod 1 = ] [ drop "odd" ] }
} cond ;
-\ cond-test-1 must-infer
+\ cond-test-1 def>> must-infer
[ "even" ] [ 2 cond-test-1 ] unit-test
[ "odd" ] [ 3 cond-test-1 ] unit-test
@@ -54,7 +54,7 @@ IN: combinators.tests
[ drop "something else" ]
} cond ;
-\ cond-test-2 must-infer
+\ cond-test-2 def>> must-infer
[ "true" ] [ t cond-test-2 ] unit-test
[ "false" ] [ f cond-test-2 ] unit-test
@@ -67,7 +67,7 @@ IN: combinators.tests
{ [ dup f = ] [ drop "false" ] }
} cond ;
-\ cond-test-3 must-infer
+\ cond-test-3 def>> must-infer
[ "something else" ] [ t cond-test-3 ] unit-test
[ "something else" ] [ f cond-test-3 ] unit-test
@@ -77,7 +77,7 @@ IN: combinators.tests
{
} cond ;
-\ cond-test-4 must-infer
+\ cond-test-4 def>> must-infer
[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
@@ -168,7 +168,7 @@ IN: combinators.tests
{ 4 [ "four" ] }
} case ;
-\ case-test-1 must-infer
+\ case-test-1 def>> must-infer
[ "two" ] [ 2 case-test-1 ] unit-test
@@ -186,7 +186,7 @@ IN: combinators.tests
[ sq ]
} case ;
-\ case-test-2 must-infer
+\ case-test-2 def>> must-infer
[ 25 ] [ 5 case-test-2 ] unit-test
@@ -204,7 +204,7 @@ IN: combinators.tests
[ sq ]
} case ;
-\ case-test-3 must-infer
+\ case-test-3 def>> must-infer
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
@@ -222,7 +222,7 @@ CONSTANT: case-const-2 2
[ drop "demasiado" ]
} case ;
-\ case-test-4 must-infer
+\ case-test-4 def>> must-infer
[ "uno" ] [ 1 case-test-4 ] unit-test
[ "dos" ] [ 2 case-test-4 ] unit-test
@@ -239,7 +239,7 @@ CONSTANT: case-const-2 2
[ drop "demasiado" print ]
} case ;
-\ case-test-5 must-infer
+\ case-test-5 def>> must-infer
[ ] [ 1 case-test-5 ] unit-test
@@ -296,7 +296,7 @@ CONSTANT: case-const-2 2
{ 3 [ "three" ] }
} case ;
-\ test-case-6 must-infer
+\ test-case-6 def>> must-infer
[ "three" ] [ 3 test-case-6 ] unit-test
[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test
@@ -343,7 +343,7 @@ CONSTANT: case-const-2 2
{ \ ] [ "KFC" ] }
} case ;
-\ test-case-7 must-infer
+\ test-case-7 def>> must-infer
[ "plus" ] [ \ + test-case-7 ] unit-test
@@ -352,12 +352,12 @@ DEFER: corner-case-1
<< \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >>
-[ t ] [ \ corner-case-1 optimized>> ] unit-test
+[ t ] [ \ corner-case-1 optimized? ] unit-test
[ 4 ] [ 2 corner-case-1 ] unit-test
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
-: test-case-8 ( n -- )
+: test-case-8 ( n -- string )
{
{ 1 [ "foo" ] }
} case ;
diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor
index 4c600e06ca..7bf76fea30 100755
--- a/core/combinators/combinators.factor
+++ b/core/combinators/combinators.factor
@@ -86,6 +86,8 @@ ERROR: no-case object ;
] [ callable? ] if
] find nip ;
+\ case-find t "no-compile" set-word-prop
+
: case ( obj assoc -- )
case-find {
{ [ dup array? ] [ nip second call ] }
@@ -121,7 +123,7 @@ ERROR: no-case object ;
[ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot )
- [ length 1- [ fixnum-bitand ] curry ] keep
+ [ length 1 - [ fixnum-bitand ] curry ] keep
[ dispatch ] curry append ;
: hash-case-quot ( default assoc -- quot )
@@ -160,7 +162,7 @@ ERROR: no-case object ;
! recursive-hashcode
: recursive-hashcode ( n obj quot -- code )
- pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline
+ pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
! These go here, not in sequences and hashtables, since those
! two cannot depend on us
diff --git a/core/compiler/errors/errors-docs.factor b/core/compiler/errors/errors-docs.factor
deleted file mode 100644
index 8368afeb19..0000000000
--- a/core/compiler/errors/errors-docs.factor
+++ /dev/null
@@ -1,52 +0,0 @@
-IN: compiler.errors
-USING: help.markup help.syntax vocabs.loader words io
-quotations words.symbol ;
-
-ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"After loading a vocabulary, you might see messages like:"
-{ $code
- ":errors - print 2 compiler errors."
- ":warnings - print 50 compiler warnings."
-}
-"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
-$nl
-"The precise warning and error conditions are documented in " { $link "inference-errors" } "."
-$nl
-"Words to view warnings and errors:"
-{ $subsection :errors }
-{ $subsection :warnings }
-{ $subsection :linkage }
-"Words such as " { $link require } " use a combinator which counts errors and prints a report at the end:"
-{ $subsection with-compiler-errors } ;
-
-HELP: compiler-errors
-{ $var-description "Global variable holding an assoc mapping words to compiler errors. This variable is set by " { $link with-compiler-errors } "." } ;
-
-ABOUT: "compiler-errors"
-
-HELP: compiler-error
-{ $values { "error" "an error" } { "word" word } }
-{ $description "If inside a " { $link with-compiler-errors } ", saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } ". If not inside a " { $link with-compiler-errors } ", ignores the error." } ;
-
-HELP: compiler-error.
-{ $values { "error" "an error" } { "word" word } }
-{ $description "Prints a compiler error to " { $link output-stream } "." } ;
-
-HELP: compiler-errors.
-{ $values { "type" symbol } }
-{ $description "Prints compiler errors to " { $link output-stream } ". The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
-HELP: :errors
-{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :warnings
-{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :linkage
-{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
-
-{ :errors :warnings } related-words
-
-HELP: with-compiler-errors
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation and collects any compiler warnings and errors. Compiler warnings and errors are summarized at the end and can be viewed with " { $link :errors } ", " { $link :warnings } ", and " { $link :linkage } "." }
-{ $notes "Nested calls to " { $link with-compiler-errors } " are ignored, and only the outermost call collects warnings and errors." } ;
diff --git a/core/compiler/errors/errors.factor b/core/compiler/errors/errors.factor
deleted file mode 100644
index 1ea497c3fc..0000000000
--- a/core/compiler/errors/errors.factor
+++ /dev/null
@@ -1,67 +0,0 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces make assocs io sequences
-sorting continuations math math.parser ;
-IN: compiler.errors
-
-SYMBOL: +error+
-SYMBOL: +warning+
-SYMBOL: +linkage+
-
-GENERIC: compiler-error-type ( error -- ? )
-
-M: object compiler-error-type drop +error+ ;
-
-GENERIC# compiler-error. 1 ( error word -- )
-
-SYMBOL: compiler-errors
-
-SYMBOL: with-compiler-errors?
-
-: errors-of-type ( type -- assoc )
- compiler-errors get-global
- swap [ [ nip compiler-error-type ] dip eq? ] curry
- assoc-filter ;
-
-: compiler-errors. ( type -- )
- errors-of-type >alist sort-keys
- [ swap compiler-error. ] assoc-each ;
-
-: (compiler-report) ( what type word -- )
- over errors-of-type assoc-empty? [ 3drop ] [
- [
- ":" %
- %
- " - print " %
- errors-of-type assoc-size #
- " " %
- %
- "." %
- ] "" make print
- ] if ;
-
-: compiler-report ( -- )
- "semantic errors" +error+ "errors" (compiler-report)
- "semantic warnings" +warning+ "warnings" (compiler-report)
- "linkage errors" +linkage+ "linkage" (compiler-report) ;
-
-: :errors ( -- ) +error+ compiler-errors. ;
-
-: :warnings ( -- ) +warning+ compiler-errors. ;
-
-: :linkage ( -- ) +linkage+ compiler-errors. ;
-
-: compiler-error ( error word -- )
- with-compiler-errors? get [
- compiler-errors get pick
- [ set-at ] [ delete-at drop ] if
- ] [ 2drop ] if ;
-
-: with-compiler-errors ( quot -- )
- with-compiler-errors? get "quiet" get or [ call ] [
- [
- with-compiler-errors? on
- V{ } clone compiler-errors set-global
- [ compiler-report ] [ ] cleanup
- ] with-scope
- ] if ; inline
diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor
index bf3b4a7171..94a95ac9c3 100644
--- a/core/compiler/units/units-docs.factor
+++ b/core/compiler/units/units-docs.factor
@@ -60,8 +60,8 @@ HELP: modify-code-heap ( alist -- )
{ $values { "alist" "an alist" } }
{ $description "Stores compiled code definitions in the code heap. The alist maps words to the following:"
{ $list
- { { $link f } " - in this case, the word is compiled with the non-optimizing compiler part of the VM." }
- { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." }
+ { "a quotation - in this case, the quotation is compiled with the non-optimizing compiler and the word will call the quotation when executed." }
+ { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data and the word will call the code block when executed." }
} }
{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;
diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor
index d84b377f36..8dce12f411 100644
--- a/core/compiler/units/units-tests.factor
+++ b/core/compiler/units/units-tests.factor
@@ -1,6 +1,6 @@
+USING: compiler definitions compiler.units tools.test arrays sequences words kernel
+accessors namespaces fry eval ;
IN: compiler.units.tests
-USING: definitions compiler.units tools.test arrays sequences words kernel
-accessors namespaces fry ;
[ [ [ ] define-temp ] with-compilation-unit ] must-infer
[ [ [ ] define-temp ] with-nested-compilation-unit ] must-infer
@@ -14,11 +14,13 @@ accessors namespaces fry ;
! Non-optimizing compiler bugs
[ 1 1 ] [
- "A" "B" <word> [ [ 1 ] dip ] >>def dup f 2array 1array modify-code-heap
+ "A" "B" <word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
1 swap execute
] unit-test
[ "A" "B" ] [
+ disable-optimizer
+
gensym "a" set
gensym "b" set
[
@@ -30,4 +32,34 @@ accessors namespaces fry ;
"a" get [ "B" ] define
] with-compilation-unit
"b" get execute
-] unit-test
\ No newline at end of file
+
+ enable-optimizer
+] unit-test
+
+! Check that we notify observers
+SINGLETON: observer
+
+observer add-definition-observer
+
+SYMBOL: counter
+
+0 counter set-global
+
+M: observer definitions-changed 2drop global [ counter inc ] bind ;
+
+[ gensym [ ] (( -- )) define-declared ] with-compilation-unit
+
+[ 1 ] [ counter get-global ] unit-test
+
+observer remove-definition-observer
+
+! Notify observers with nested compilation units
+observer add-definition-observer
+
+0 counter set-global
+
+DEFER: nesting-test
+
+[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test
+
+observer remove-definition-observer
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index afa05f9442..f1f9131f08 100644
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -3,7 +3,7 @@
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
math math.order classes classes.algebra classes.tuple
-classes.tuple.private generic ;
+classes.tuple.private generic source-files.errors ;
IN: compiler.units
SYMBOL: old-definitions
@@ -41,7 +41,10 @@ SYMBOL: compiler-impl
HOOK: recompile compiler-impl ( words -- alist )
! Non-optimizing compiler
-M: f recompile [ f ] { } map>assoc ;
+M: f recompile [ dup def>> ] { } map>assoc ;
+
+: without-optimizer ( quot -- )
+ [ f compiler-impl ] dip with-variable ; inline
! Trivial compiler. We don't want to touch the code heap
! during stage1 bootstrap, it would just waste time.
@@ -58,11 +61,15 @@ GENERIC: definitions-changed ( assoc obj -- )
[ V{ } clone definition-observers set-global ]
"compiler.units" add-init-hook
+! This goes here because vocabs cannot depend on init
+[ V{ } clone vocab-observers set-global ]
+"vocabs" add-init-hook
+
: add-definition-observer ( obj -- )
definition-observers get push ;
: remove-definition-observer ( obj -- )
- definition-observers get delete ;
+ definition-observers get delq ;
: notify-definition-observers ( assoc -- )
definition-observers get
@@ -132,17 +139,20 @@ GENERIC: definitions-changed ( assoc obj -- )
changed-generics get compiled-generic-usages
append assoc-combine keys ;
-: unxref-forgotten-definitions ( -- )
- forgotten-definitions get
- keys [ word? ] filter
- [ delete-compiled-xref ] each ;
+: process-forgotten-definitions ( -- )
+ forgotten-definitions get keys
+ [ [ word? ] filter [ delete-compiled-xref ] each ]
+ [ [ delete-definition-errors ] each ]
+ bi ;
: finish-compilation-unit ( -- )
remake-generics
to-recompile recompile
update-tuples
- unxref-forgotten-definitions
- modify-code-heap ;
+ process-forgotten-definitions
+ modify-code-heap
+ updated-definitions dup assoc-empty?
+ [ drop ] [ notify-definition-observers notify-error-observers ] if ;
: with-nested-compilation-unit ( quot -- )
[
@@ -166,9 +176,5 @@ GENERIC: definitions-changed ( assoc obj -- )
H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
- [
- finish-compilation-unit
- updated-definitions
- notify-definition-observers
- ] [ ] cleanup
+ [ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor
index 0627ed5265..2c91981f13 100644
--- a/core/continuations/continuations-docs.factor
+++ b/core/continuations/continuations-docs.factor
@@ -30,7 +30,7 @@ $nl
{ $heading "Anti-pattern #4: Logging and rethrowing" }
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
-ARTICLE: "errors" "Error handling"
+ARTICLE: "errors" "Exception handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl
"Two words raise an error in the innermost error handler for the current dynamic extent:"
@@ -81,8 +81,6 @@ $nl
{ $subsection attempt-all }
{ $subsection retry }
{ $subsection with-return }
-"Reflecting the datastack:"
-{ $subsection with-datastack }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
@@ -211,7 +209,7 @@ $low-level-note ;
HELP: with-datastack
{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
-{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
+{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
{ $examples
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
} ;
diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor
index 34a4ed2879..6409fc588e 100644
--- a/core/continuations/continuations-tests.factor
+++ b/core/continuations/continuations-tests.factor
@@ -3,8 +3,8 @@ continuations debugger parser memory arrays words
kernel.private accessors eval ;
IN: continuations.tests
-: (callcc1-test) ( -- )
- [ 1- dup ] dip ?push
+: (callcc1-test) ( n obj -- n' obj )
+ [ 1 - dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ;
@@ -50,21 +50,19 @@ IN: continuations.tests
gc
] unit-test
-[ f ] [ { } kernel-error? ] unit-test
-[ f ] [ { "A" "B" } kernel-error? ] unit-test
-
! ! See how well callstack overflow is handled
! [ clear drop ] must-fail
!
! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail
-: don't-compile-me ( -- ) { } [ ] each ;
-
-: foo ( -- ) callstack "c" set 3 don't-compile-me ;
+: don't-compile-me ( -- ) ;
+: foo ( -- ) callstack "c" set don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ;
-[ 1 3 2 ] [ bar ] unit-test
+<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
+
+[ 1 2 ] [ bar ] unit-test
[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
@@ -107,4 +105,4 @@ SYMBOL: error-counter
[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
-\ with-datastack must-infer
+[ with-datastack ] must-infer
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index 051d28d8c2..56ac4a71e9 100644
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays vectors kernel kernel.private sequences
namespaces make math splitting sorting quotations assocs
-combinators combinators.private accessors ;
+combinators combinators.private accessors words ;
IN: continuations
SYMBOL: error
@@ -74,12 +74,14 @@ C: <continuation> continuation
<PRIVATE
: (continue) ( continuation -- * )
- >continuation<
- set-catchstack
- set-namestack
- set-retainstack
- [ set-datastack ] dip
- set-callstack ;
+ [
+ >continuation<
+ set-catchstack
+ set-namestack
+ set-retainstack
+ [ set-datastack ] dip
+ set-callstack
+ ] (( continuation -- * )) call-effect-unsafe ;
PRIVATE>
diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor
index b53ab28cbc..b1575cc1e4 100644
--- a/core/definitions/definitions-docs.factor
+++ b/core/definitions/definitions-docs.factor
@@ -10,21 +10,11 @@ $nl
{ $subsection set-where }
"Definitions can be removed:"
{ $subsection forget }
-"Definitions can answer a sequence of definitions they directly depend on:"
-{ $subsection uses }
"Definitions must implement a few operations used for printing them in source form:"
{ $subsection definer }
{ $subsection definition }
{ $see-also "see" } ;
-ARTICLE: "definition-crossref" "Definition cross referencing"
-"A common cross-referencing system is used to track definition usages:"
-{ $subsection crossref }
-{ $subsection xref }
-{ $subsection unxref }
-{ $subsection delete-xref }
-{ $subsection usage } ;
-
ARTICLE: "definition-checking" "Definition sanity checking"
"When a source file is reloaded, the parser compares the previous list of definitions with the current list; any definitions which are no longer present in the file are removed by a call to " { $link forget } ". A warning message is printed if any other definitions still depend on the removed definitions."
$nl
@@ -56,11 +46,23 @@ $nl
{ $subsection redefine-error } ;
ARTICLE: "definitions" "Definitions"
-"A " { $emphasis "definition" } " is an artifact read from a source file. This includes words, methods, help articles, and path names (which represent the source file at that location). Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary."
+"A " { $emphasis "definition" } " is an artifact read from a source file. Words for working with definitions are found in the " { $vocab-link "definitions" } " vocabulary."
+$nl
+"Definitions are defined using parsing words. Examples of definitions together with their defining parsing words are words (" { $link POSTPONE: : } "), methods (" { $link POSTPONE: M: } "), and vocabularies (" { $link POSTPONE: IN: } ")."
+$nl
+"All definitions share some common traits:"
+{ $list
+ "There is a word to list all definitions of a given type"
+ "There is a parsing word for creating new definitions"
+ "There is an ordinary word which is the runtime equivalent of the parsing word, for introspection"
+ "Instances of the definition may be introspected and modified with the definition protocol"
+}
+"For every source file loaded into the system, a list of definitions is maintained. Pathname objects implement the definition protocol, acting over the definitions their source files contain. See " { $link "source-files" } " for details."
{ $subsection "definition-protocol" }
-{ $subsection "definition-crossref" }
{ $subsection "definition-checking" }
{ $subsection "compilation-units" }
+"A parsing word to remove definitions:"
+{ $subsection POSTPONE: FORGET: }
{ $see-also "see" "parser" "source-files" "words" "generic" "help-impl" } ;
ABOUT: "definitions"
@@ -83,36 +85,3 @@ HELP: forget-all
{ $values { "definitions" "a sequence of definition specifiers" } }
{ $description "Forgets every definition in a sequence." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
-
-HELP: uses
-{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
-{ $description "Outputs a sequence of definitions directory called by the given definition." }
-{ $notes "The sequence might include the definition itself, if it is a recursive word." }
-{ $examples
- "We can ask the " { $link sq } " word to produce a list of words it calls:"
- { $unchecked-example "\ sq uses ." "{ dup * }" }
-} ;
-
-HELP: crossref
-{ $var-description "A graph whose vertices are definition specifiers and edges are usages. See " { $link "graphs" } "." } ;
-
-HELP: xref
-{ $values { "defspec" "a definition specifier" } }
-{ $description "Adds a vertex representing this definition, along with edges representing dependencies to the " { $link crossref } " graph." }
-$low-level-note ;
-
-HELP: usage
-{ $values { "defspec" "a definition specifier" } { "seq" "a sequence of definition specifiers" } }
-{ $description "Outputs a sequence of definitions that directly call the given definition." }
-{ $notes "The sequence might include the definition itself, if it is a recursive word." } ;
-
-HELP: unxref
-{ $values { "defspec" "a definition specifier" } }
-{ $description "Remove edges leaving the vertex which represents the definition from the " { $link crossref } " graph." }
-{ $notes "This word is called before a word is redefined." } ;
-
-HELP: delete-xref
-{ $values { "defspec" "a definition specifier" } }
-{ $description "Remove the vertex which represents the definition from the " { $link crossref } " graph." }
-{ $notes "This word is called before a word is forgotten." }
-{ $see-also forget } ;
diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
index b2d265a2e3..558b259103 100644
--- a/core/definitions/definitions-tests.factor
+++ b/core/definitions/definitions-tests.factor
@@ -20,14 +20,11 @@ TUPLE: some-class ;
M: some-class some-generic ;
-TUPLE: another-class some-generic ;
-
[ ] [
[
- {
- some-generic
- some-class
- { another-class some-generic }
- } forget-all
+ \ some-generic
+ \ some-class
+ 2array
+ forget-all
] with-compilation-unit
] unit-test
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index c95c5816ac..6f9fdaecf5 100644
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences namespaces assocs graphs math math.order ;
+USING: kernel sequences namespaces assocs math accessors ;
IN: definitions
MIXIN: definition
@@ -19,9 +19,6 @@ SYMBOL: changed-definitions
SYMBOL: changed-effects
-: changed-effect ( word -- )
- dup changed-effects get set-in-unit ;
-
SYMBOL: changed-generics
SYMBOL: outdated-generics
@@ -42,7 +39,9 @@ GENERIC: set-where ( loc defspec -- )
GENERIC: forget* ( defspec -- )
-M: object forget* drop ;
+M: f forget* drop ;
+
+M: wrapper forget* wrapped>> forget* ;
SYMBOL: forgotten-definitions
@@ -53,34 +52,6 @@ SYMBOL: forgotten-definitions
: forget-all ( definitions -- ) [ forget ] each ;
-GENERIC: synopsis* ( defspec -- )
-
GENERIC: definer ( defspec -- start end )
GENERIC: definition ( defspec -- seq )
-
-SYMBOL: crossref
-
-GENERIC: uses ( defspec -- seq )
-
-M: object uses drop f ;
-
-: xref ( defspec -- ) dup uses crossref get add-vertex ;
-
-: usage ( defspec -- seq ) crossref get at keys ;
-
-GENERIC: irrelevant? ( defspec -- ? )
-
-M: object irrelevant? drop f ;
-
-GENERIC: smart-usage ( defspec -- seq )
-
-M: f smart-usage drop \ f smart-usage ;
-
-M: object smart-usage usage [ irrelevant? not ] filter ;
-
-: unxref ( defspec -- )
- dup uses crossref get remove-vertex ;
-
-: delete-xref ( defspec -- )
- dup unxref crossref get delete-at ;
diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor
index b209dcf259..38b8ab4dad 100644
--- a/core/effects/effects-docs.factor
+++ b/core/effects/effects-docs.factor
@@ -1,16 +1,20 @@
-USING: help.markup help.syntax math strings words kernel ;
+USING: help.markup help.syntax math strings words kernel combinators ;
IN: effects
-ARTICLE: "effect-declaration" "Stack effect declaration"
-"Stack effects of words must be declared, with the exception of words which only push literals on the stack."
-$nl
-"A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Here is an example:"
-{ $synopsis sq }
+ARTICLE: "effects" "Stack effect declarations"
+"Word definition words such as " { $link POSTPONE: : } " and " { $link POSTPONE: GENERIC: } " have a " { $emphasis "stack effect declaration" } " as part of their syntax. A stack effect declaration takes the following form:"
+{ $code "( input1 input2 ... -- output1 ... )" }
+"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Here is an example:"
+{ $synopsis + }
"Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration:"
{ $synopsis while }
-"Stack effect declarations are read in using a parsing word:"
-{ $subsection POSTPONE: ( }
-"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Each value can be named by a data type or description. The following are some examples of value names:"
+"Only the number of inputs and outputs carries semantic meaning."
+$nl
+"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. See " { $link "inference-recursive-combinators" } "."
+$nl
+"In concatenative code, input and output names are for documentation purposes only and certain conventions have been established to make them more descriptive. For code written with " { $link "locals" } ", stack values are bound to local variables named by the stack effect's input parameters."
+$nl
+"Inputs and outputs are typically named after some pun on their data type, or a description of the value's purpose if the type is very general. The following are some examples of value names:"
{ $table
{ { { $snippet "?" } } "a boolean" }
{ { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } }
@@ -26,25 +30,6 @@ $nl
{ { $snippet "dim" } "a screen dimension specified as a two-element array holding width and height values" }
{ { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" }
}
-"The stack effect inferencer verifies stack effect comments to ensure the correct number of inputs and outputs is listed. Value names are ignored; only their number matters. An error is thrown if a word's declared stack effect does not match its inferred stack effect. See " { $link "inference" } "." ;
-
-ARTICLE: "effects" "Stack effects"
-"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output."
-$nl
-"Stack effects of words can be declared."
-{ $subsection "effect-declaration" }
-"Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary."
-{ $subsection effect }
-{ $subsection effect? }
-"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } "."
-{ $subsection POSTPONE: (( }
-"Getting a word's declared stack effect:"
-{ $subsection stack-effect }
-"Converting a stack effect to a string form:"
-{ $subsection effect>string }
-"Comparing effects:"
-{ $subsection effect-height }
-{ $subsection effect<= }
{ $see-also "inference" } ;
ABOUT: "effects"
@@ -57,8 +42,15 @@ HELP: effect-height
{ $description "Outputs the number of objects added to the data stack by the stack effect. This will be negative if the stack effect only removes objects from the stack." } ;
HELP: effect<=
-{ $values { "eff1" effect } { "eff2" effect } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "eff1" } " is substitutable for " { $snippet "eff2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ;
+{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "effect1" } " is substitutable for " { $snippet "effect2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ;
+
+HELP: effect=
+{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "effect1" } " and " { $snippet "effect2" } " represent the same stack transformation, without looking parameter names." }
+{ $examples
+ { $example "USING: effects prettyprint ;" "(( a -- b )) (( x -- y )) effect= ." "t" }
+} ;
HELP: effect>string
{ $values { "obj" object } { "str" string } }
diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor
index 316add54c0..3eb9273859 100644
--- a/core/effects/effects-tests.factor
+++ b/core/effects/effects-tests.factor
@@ -18,4 +18,8 @@ USING: effects tools.test prettyprint accessors sequences ;
[ { "x" "y" } ] [ { "y" "x" } (( a b -- b a )) shuffle ] unit-test
[ { "y" "x" "y" } ] [ { "y" "x" } (( a b -- a b a )) shuffle ] unit-test
-[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test
\ No newline at end of file
+[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test
+
+[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
+[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
+[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
\ No newline at end of file
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index 142b9120a8..cab1e531b7 100644
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser namespaces make sequences strings
+USING: kernel math math.parser math.order namespaces make sequences strings
words assocs combinators accessors arrays ;
IN: effects
@@ -13,7 +13,7 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
: effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline
-: effect<= ( eff1 eff2 -- ? )
+: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
@@ -22,6 +22,12 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
[ t ]
} cond 2nip ; inline
+: effect= ( effect1 effect2 -- ? )
+ [ [ in>> length ] bi@ = ]
+ [ [ out>> length ] bi@ = ]
+ [ [ terminated?>> ] bi@ = ]
+ 2tri and and ;
+
GENERIC: effect>string ( obj -- str )
M: string effect>string ;
M: object effect>string drop "object" ;
@@ -66,3 +72,13 @@ M: effect clone
: add-effect-input ( effect -- effect' )
[ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
+
+: compose-effects ( effect1 effect2 -- effect' )
+ over terminated?>> [
+ drop
+ ] [
+ [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
+ [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
+ [ nip terminated?>> ] 2tri
+ effect boa
+ ] if ; inline
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 06a8fa87a3..73002a5d89 100644
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -1,6 +1,7 @@
USING: help.markup help.syntax words classes classes.algebra
definitions kernel alien sequences math quotations
-generic.standard generic.math combinators prettyprint effects ;
+generic.single generic.standard generic.hook generic.math
+combinators prettyprint effects ;
IN: generic
ARTICLE: "method-order" "Method precedence"
@@ -45,8 +46,8 @@ $nl
{ $subsection make-generic }
"Low-level method constructor:"
{ $subsection <method> }
-"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
-{ $subsection method-spec }
+"Methods may be pushed on the stack with a literal syntax:"
+{ $subsection POSTPONE: M\ }
{ $see-also "see" } ;
ARTICLE: "method-combination" "Custom method combination"
@@ -95,11 +96,11 @@ $nl
{ $subsection POSTPONE: MATH: }
"Method definition:"
{ $subsection POSTPONE: M: }
-"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "."
+"Generic words must declare their stack effect in order to compile. See " { $link "effects" } "."
{ $subsection "method-order" }
{ $subsection "call-next-method" }
-{ $subsection "generic-introspection" }
{ $subsection "method-combination" }
+{ $subsection "generic-introspection" }
"Generic words specialize behavior based on the class of an object; sometimes behavior needs to be specialized on the object's " { $emphasis "structure" } "; this is known as " { $emphasis "pattern matching" } " and is implemented in the " { $vocab-link "match" } " vocabulary." ;
ABOUT: "generic"
@@ -119,9 +120,10 @@ HELP: define-generic
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
{ $contract "The method combination quotation is called each time the generic word has to be updated (for example, when a method is added), and thus must be side-effect free." } ;
-HELP: method-spec
-{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
-{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
+HELP: M\
+{ $syntax "M\\ class generic" }
+{ $class-description "Pushes a method on the stack." }
+{ $examples { $code "M\\ fixnum + see" } { $code "USING: ui.gadgets ui.gadgets.editors ;" "M\\ editor draw-gadget* edit" } } ;
HELP: method-body
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index aadc44833f..a63cab1c5c 100755
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -65,11 +65,11 @@ M: number union-containment drop 2 ;
[ 2 ] [ 1.0 union-containment ] unit-test
! Testing recovery from bad method definitions
-"IN: generic.tests GENERIC: unhappy ( x -- x )" eval
+"IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- )
[
- "IN: generic.tests M: dictionary unhappy ;" eval
+ "IN: generic.tests M: dictionary unhappy ;" eval( -- )
] must-fail
-[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
+[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test
GENERIC# complex-combination 1 ( a b -- c )
M: string complex-combination drop ;
@@ -96,18 +96,6 @@ M: shit big-generic-test "shit" ;
[ t ] [ \ + math-generic? ] unit-test
-! Test math-combination
-[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
-[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
-[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
-[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
-[ number ] [ \ number \ float math-class-max ] unit-test
-[ float ] [ \ real \ float math-class-max ] unit-test
-[ fixnum ] [ \ fixnum \ null math-class-max ] unit-test
-
-[ t ] [ { hashtable equal? } method-spec? ] unit-test
-[ f ] [ { word = } method-spec? ] unit-test
-
! Regression
TUPLE: first-one ;
TUPLE: second-one ;
@@ -136,69 +124,19 @@ M: f tag-and-f 4 ;
[ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
! Issues with forget
-GENERIC: generic-forget-test-1 ( a b -- c )
+GENERIC: generic-forget-test ( a -- b )
-M: integer generic-forget-test-1 / ;
+M: f generic-forget-test ;
-[ t ] [
- \ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] any?
-] unit-test
-
-[ ] [
- [ \ generic-forget-test-1 forget ] with-compilation-unit
-] unit-test
-
-[ f ] [
- \ / usage [ word? ] filter
- [ name>> "integer=>generic-forget-test-1" = ] any?
-] unit-test
-
-GENERIC: generic-forget-test-2 ( a b -- c )
-
-M: sequence generic-forget-test-2 = ;
-
-[ t ] [
- \ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] any?
-] unit-test
-
-[ ] [
- [ { sequence generic-forget-test-2 } forget ] with-compilation-unit
-] unit-test
-
-[ f ] [
- \ = usage [ word? ] filter
- [ name>> "sequence=>generic-forget-test-2" = ] any?
-] unit-test
-
-GENERIC: generic-forget-test-3 ( a -- b )
-
-M: f generic-forget-test-3 ;
-
-[ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
+[ ] [ \ f \ generic-forget-test method "m" set ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
-[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
+[ ] [ "IN: generic.tests M: f generic-forget-test ;" eval( -- ) ] unit-test
[ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
-[ f ] [ f generic-forget-test-3 ] unit-test
-
-: a-word ( -- ) ;
-
-GENERIC: a-generic ( a -- b )
-
-M: integer a-generic a-word ;
-
-[ ] [ \ integer \ a-generic method "m" set ] unit-test
-
-[ t ] [ "m" get \ a-word usage memq? ] unit-test
-
-[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test
-
-[ f ] [ "m" get \ a-word usage memq? ] unit-test
+[ f ] [ f generic-forget-test ] unit-test
! erg's regression
[ ] [
@@ -210,31 +148,31 @@ M: integer a-generic a-word ;
M: boii jeah ;
GENERIC: jeah* ( a -- b )
M: boii jeah* jeah ;
- "> eval
+ "> eval( -- )
<"
IN: compiler.tests
FORGET: boii
- "> eval
+ "> eval( -- )
<"
IN: compiler.tests
TUPLE: boii ;
M: boii jeah ;
- "> eval
+ "> eval( -- )
] unit-test
! call-next-method cache test
GENERIC: c-n-m-cache ( a -- b )
! Force it to be unoptimized
-M: fixnum c-n-m-cache { } [ ] like call call-next-method ;
+M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ;
M: integer c-n-m-cache 1 + ;
M: number c-n-m-cache ;
[ 3 ] [ 2 c-n-m-cache ] unit-test
-[ ] [ [ { integer c-n-m-cache } forget ] with-compilation-unit ] unit-test
+[ ] [ [ M\ integer c-n-m-cache forget ] with-compilation-unit ] unit-test
[ 2 ] [ 2 c-n-m-cache ] unit-test
@@ -247,4 +185,4 @@ GENERIC: move-method-generic ( a -- b )
[ ] [ "IN: generic.tests.a" <string-reader> "move-method-test-1" parse-stream drop ] unit-test
-[ { string } ] [ \ move-method-generic order ] unit-test
\ No newline at end of file
+[ { string } ] [ \ move-method-generic order ] unit-test
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index c22641d439..4b398f6532 100644
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -24,11 +24,6 @@ M: generic definition drop f ;
: method ( class generic -- method/f )
"methods" word-prop at ;
-PREDICATE: method-spec < pair
- first2 generic? swap class? and ;
-
-INSTANCE: method-spec definition
-
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
@@ -38,6 +33,8 @@ INSTANCE: method-spec definition
GENERIC: effective-method ( generic -- method )
+\ effective-method t "no-compile" set-word-prop
+
: next-method-class ( class generic -- class/f )
order [ class<= ] with filter reverse dup length 1 =
[ drop f ] [ second ] if ;
@@ -90,9 +87,6 @@ TUPLE: check-method class generic ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
-M: method-spec stack-effect
- first2 method stack-effect ;
-
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
@@ -129,8 +123,6 @@ M: method-body crossref?
PREDICATE: default-method < word "default" word-prop ;
-M: default-method irrelevant? drop t ;
-
: <default-method> ( generic combination -- method )
[ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
[ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
@@ -139,24 +131,6 @@ M: default-method irrelevant? drop t ;
dupd <default-method> "default-method" set-word-prop ;
! Definition protocol
-M: method-spec where
- dup first2 method [ ] [ second ] ?if where ;
-
-M: method-spec set-where
- first2 method set-where ;
-
-M: method-spec definer
- first2 method definer ;
-
-M: method-spec definition
- first2 method definition ;
-
-M: method-spec forget*
- first2 method [ forgotten-definition ] [ forget* ] bi ;
-
-M: method-spec smart-usage
- second smart-usage ;
-
M: method-body definer
drop \ M: \ ; ;
@@ -179,9 +153,6 @@ M: method-body forget*
[ call-next-method ] bi
] if ;
-M: method-body smart-usage
- "method-generic" word-prop smart-usage ;
-
M: sequence update-methods ( class seq -- )
implementors [
[ changed-generic ] [ remake-generic drop ] 2bi
@@ -193,8 +164,8 @@ M: sequence update-methods ( class seq -- )
drop
2dup [ "combination" word-prop ] dip = [ 2drop ] [
{
+ [ drop reset-generic ]
[ "combination" set-word-prop ]
- [ drop "methods" word-prop values forget-all ]
[ drop H{ } clone "methods" set-word-prop ]
[ define-default-method ]
}
@@ -214,5 +185,5 @@ M: generic subwords
M: generic forget*
[ subwords forget-all ] [ call-next-method ] bi ;
-: xref-generics ( -- )
- all-words [ subwords [ xref ] each ] each ;
+M: class forget-methods
+ [ implementors ] [ [ swap method ] curry ] bi map forget-all ;
diff --git a/core/generic/hook/authors.txt b/core/generic/hook/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/core/generic/hook/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/core/generic/hook/hook-docs.factor b/core/generic/hook/hook-docs.factor
new file mode 100644
index 0000000000..9b57d941c0
--- /dev/null
+++ b/core/generic/hook/hook-docs.factor
@@ -0,0 +1,10 @@
+USING: generic generic.single generic.standard help.markup help.syntax sequences math
+math.parser effects ;
+IN: generic.hook
+
+HELP: hook-combination
+{ $class-description
+ "Performs hook method combination . See " { $link POSTPONE: HOOK: } "."
+} ;
+
+{ standard-combination hook-combination } related-words
\ No newline at end of file
diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor
new file mode 100644
index 0000000000..fe5b62f6c0
--- /dev/null
+++ b/core/generic/hook/hook.factor
@@ -0,0 +1,28 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors definitions generic generic.single
+generic.single.private kernel namespaces words kernel.private
+quotations sequences ;
+IN: generic.hook
+
+TUPLE: hook-combination < single-combination var ;
+
+C: <hook-combination> hook-combination
+
+PREDICATE: hook-generic < generic
+ "combination" word-prop hook-combination? ;
+
+M: hook-combination picker
+ combination get var>> [ get ] curry ;
+
+M: hook-combination dispatch# drop 0 ;
+
+M: hook-combination inline-cache-quot 2drop f ;
+
+M: hook-combination mega-cache-quot
+ 1quotation picker [ lookup-method (execute) ] surround ;
+
+M: hook-generic definer drop \ HOOK: f ;
+
+M: hook-generic effective-method
+ [ "combination" word-prop var>> get ] keep (effective-method) ;
\ No newline at end of file
diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor
index 4323f91bc3..7d7d6e725b 100644
--- a/core/generic/math/math-docs.factor
+++ b/core/generic/math/math-docs.factor
@@ -1,5 +1,5 @@
USING: kernel generic help.markup help.syntax math classes
-sequences quotations ;
+sequences quotations generic.math.private ;
IN: generic.math
HELP: math-upgrade
@@ -15,7 +15,7 @@ HELP: no-math-method
HELP: math-method
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
-{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ { fixnum float } declare [ >float ] dip float=>+ ]" } } ;
+{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ { fixnum float } declare [ >float ] dip M\\ float + ]" } } ;
HELP: math-class
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
diff --git a/core/generic/math/math-tests.factor b/core/generic/math/math-tests.factor
new file mode 100644
index 0000000000..51e122431c
--- /dev/null
+++ b/core/generic/math/math-tests.factor
@@ -0,0 +1,21 @@
+IN: generic.math.tests
+USING: generic.math math tools.test kernel ;
+
+! Test math-combination
+[ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
+[ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
+
+[ number ] [ number float math-class-max ] unit-test
+[ number ] [ float number math-class-max ] unit-test
+[ float ] [ real float math-class-max ] unit-test
+[ float ] [ float real math-class-max ] unit-test
+[ fixnum ] [ fixnum null math-class-max ] unit-test
+[ fixnum ] [ null fixnum math-class-max ] unit-test
+[ bignum ] [ fixnum bignum math-class-max ] unit-test
+[ bignum ] [ bignum fixnum math-class-max ] unit-test
+[ number ] [ fixnum number math-class-max ] unit-test
+[ number ] [ number fixnum math-class-max ] unit-test
+
+
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 8d4610dabe..c96050ad03 100644
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic hashtables kernel kernel.private math
-namespaces make sequences words quotations layouts combinators
+namespaces sequences words quotations layouts combinators
sequences.private classes classes.builtin classes.algebra
-definitions math.order math.private ;
+definitions math.order math.private assocs ;
IN: generic.math
PREDICATE: math-class < class
@@ -13,24 +13,30 @@ PREDICATE: math-class < class
number bootstrap-word class<=
] if ;
+<PRIVATE
+
: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
-: math-precedence ( class -- pair )
- {
- { [ dup null class<= ] [ drop { -1 -1 } ] }
- { [ dup math-class? ] [ class-types last/first ] }
- [ drop { 100 100 } ]
- } cond ;
-
-: math-class<=> ( class1 class2 -- class )
- [ math-precedence ] compare +gt+ eq? ;
+: bootstrap-words ( classes -- classes' )
+ [ bootstrap-word ] map ;
-: math-class-max ( class1 class2 -- class )
- [ math-class<=> ] most ;
+: math-precedence ( class -- pair )
+ [
+ { fixnum integer rational real number object } bootstrap-words
+ swap [ swap class<= ] curry find drop -1 or
+ ] [
+ { fixnum bignum ratio float complex object } bootstrap-words
+ swap [ class<= ] curry find drop -1 or
+ ] bi 2array ;
: (math-upgrade) ( max class -- quot )
dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
+PRIVATE>
+
+: math-class-max ( class1 class2 -- class )
+ [ [ math-precedence ] bi@ after? ] most ;
+
: math-upgrade ( class1 class2 -- quot )
[ math-class-max ] 2keep
[
@@ -44,33 +50,57 @@ ERROR: no-math-method left right generic ;
: default-math-method ( generic -- quot )
[ no-math-method ] curry [ ] like ;
+<PRIVATE
+
: applicable-method ( generic class -- quot )
over method
[ 1quotation ]
[ default-math-method ] ?if ;
+PRIVATE>
+
: object-method ( generic -- quot )
object bootstrap-word applicable-method ;
: math-method ( word class1 class2 -- quot )
2dup and [
- [
- 2dup 2array , \ declare ,
- 2dup math-upgrade %
- math-class-max over order min-class applicable-method %
- ] [ ] make
+ [ 2array [ declare ] curry nip ]
+ [ math-upgrade nip ]
+ [ math-class-max over order min-class applicable-method ]
+ 3tri 3append
] [
2drop object-method
] if ;
-SYMBOL: picker
+<PRIVATE
-: math-vtable ( picker quot -- quot )
- [
- [ , \ tag , ]
- [ num-tags get swap [ bootstrap-type>class ] prepose map , ] bi*
- \ dispatch ,
- ] [ ] make ; inline
+SYMBOL: generic-word
+
+: make-math-method-table ( classes quot: ( class -- quot ) -- alist )
+ [ bootstrap-words ] dip
+ [ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline
+
+: math-alist>quot ( alist -- quot )
+ [ generic-word get object-method ] dip alist>quot ;
+
+: tag-dispatch-entry ( tag picker -- quot )
+ [ "type" word-prop 1quotation [ tag ] [ eq? ] surround ] dip prepend ;
+
+: tag-dispatch ( picker alist -- alist' )
+ swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
+
+: tuple-dispatch-entry ( class picker -- quot )
+ [ 1quotation [ { tuple } declare class ] [ eq? ] surround ] dip prepend ;
+
+: tuple-dispatch ( picker alist -- alist' )
+ swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
+
+: math-dispatch-step ( picker quot: ( class -- quot ) -- quot )
+ [ [ { bignum float fixnum } ] dip make-math-method-table ]
+ [ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi
+ tuple swap 2array prefix tag-dispatch ; inline
+
+PRIVATE>
SINGLETON: math-combination
@@ -78,20 +108,21 @@ M: math-combination make-default-method
drop default-math-method ;
M: math-combination perform-combination
- drop
- dup
- [
- [ 2dup both-fixnums? ] %
- dup fixnum bootstrap-word dup math-method ,
- \ over [
- dup math-class? [
- \ dup [ [ 2dup ] dip math-method ] math-vtable
- ] [
- over object-method
- ] if nip
- ] math-vtable nip ,
- \ if ,
- ] [ ] make define ;
+ drop dup generic-word [
+ dup
+ [ fixnum bootstrap-word dup math-method ]
+ [
+ [ over ] [
+ dup math-class? [
+ [ dup ] [ math-method ] with with math-dispatch-step
+ ] [
+ drop object-method
+ ] if
+ ] with math-dispatch-step
+ ] bi
+ [ if ] 2curry [ 2dup both-fixnums? ] prepend
+ define
+ ] with-variable ;
PREDICATE: math-generic < generic ( word -- ? )
"combination" word-prop math-combination? ;
diff --git a/core/generic/single/authors.txt b/core/generic/single/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/core/generic/single/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/core/generic/single/single-docs.factor b/core/generic/single/single-docs.factor
new file mode 100644
index 0000000000..8f81be762c
--- /dev/null
+++ b/core/generic/single/single-docs.factor
@@ -0,0 +1,27 @@
+USING: generic help.markup help.syntax sequences math
+math.parser effects ;
+IN: generic.single
+
+HELP: no-method
+{ $values { "object" "an object" } { "generic" "a generic word" } }
+{ $description "Throws a " { $link no-method } " error." }
+{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ;
+
+HELP: inconsistent-next-method
+{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
+{ $examples
+ "The following code throws this error:"
+ { $code
+ "GENERIC: error-test ( object -- )"
+ ""
+ "M: string error-test print ;"
+ ""
+ "M: integer error-test number>string call-next-method ;"
+ ""
+ "123 error-test"
+ }
+ "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
+ $nl
+ "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
+ { $code "M: integer error-test number>string error-test ;" }
+} ;
\ No newline at end of file
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/single/single-tests.factor
similarity index 82%
rename from core/generic/standard/standard-tests.factor
rename to core/generic/single/single-tests.factor
index a6269135f4..c8cab970fd 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/core/generic/single/single-tests.factor
@@ -1,11 +1,10 @@
-IN: generic.standard.tests
-USING: tools.test math math.functions math.constants
-generic.standard strings sequences arrays kernel accessors words
-specialized-arrays.double byte-arrays bit-arrays parser
-namespaces make quotations stack-checker vectors growable
-hashtables sbufs prettyprint byte-vectors bit-vectors
-specialized-vectors.double definitions generic sets graphs assocs
-grouping see ;
+IN: generic.single.tests
+USING: tools.test math math.functions math.constants generic.standard
+generic.single strings sequences arrays kernel accessors words
+specialized-arrays.double byte-arrays bit-arrays parser namespaces
+make quotations stack-checker vectors growable hashtables sbufs
+prettyprint byte-vectors bit-vectors specialized-vectors.double
+definitions generic sets graphs assocs grouping see eval ;
GENERIC: lo-tag-test ( obj -- obj' )
@@ -66,7 +65,7 @@ M: circle area radius>> sq pi * ;
GENERIC: perimiter ( shape -- n )
-: rectangle-perimiter ( n -- n ) + 2 * ;
+: rectangle-perimiter ( l w -- n ) + 2 * ;
M: rectangle perimiter
[ width>> ] [ height>> ] bi
@@ -249,23 +248,6 @@ M: string my-hook "a string" ;
[ "a string" ] [ my-hook my-var set my-hook ] unit-test
[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
-HOOK: my-tuple-hook my-var ( -- x )
-
-M: sequence my-tuple-hook my-hook ;
-
-TUPLE: m-t-h-a ;
-
-M: m-t-h-a my-tuple-hook "foo" ;
-
-TUPLE: m-t-h-b < m-t-h-a ;
-
-M: m-t-h-b my-tuple-hook "bar" ;
-
-[ f ] [
- \ my-tuple-hook [ "engines" word-prop ] keep prefix
- [ 1quotation infer ] map all-equal?
-] unit-test
-
HOOK: call-next-hooker my-var ( -- x )
M: sequence call-next-hooker "sequence" ;
@@ -280,31 +262,16 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
V{ } my-var [ call-next-hooker ] with-variable
] unit-test
-! Cross-referencing with generic words
-TUPLE: xref-tuple-1 ;
-TUPLE: xref-tuple-2 < xref-tuple-1 ;
-
-: (xref-test) ( obj -- ) drop ;
-
-GENERIC: xref-test ( obj -- )
-
-M: xref-tuple-1 xref-test (xref-test) ;
-M: xref-tuple-2 xref-test (xref-test) ;
-
[ t ] [
- \ xref-test
- \ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
-] unit-test
-
-[ t ] [
- \ xref-test
- \ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
-] unit-test
-
-[ t ] [
- { } \ nth effective-method nip \ sequence \ nth method eq?
+ { } \ nth effective-method nip M\ sequence nth eq?
] unit-test
[ t ] [
\ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
] unit-test
+
+[ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
+[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
+
+[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test
+[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
\ No newline at end of file
diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor
new file mode 100644
index 0000000000..d8fa04edd6
--- /dev/null
+++ b/core/generic/single/single.factor
@@ -0,0 +1,256 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes classes.algebra
+combinators definitions generic hashtables kernel
+kernel.private layouts math namespaces quotations
+sequences words generic.single.private effects make ;
+IN: generic.single
+
+ERROR: no-method object generic ;
+
+ERROR: inconsistent-next-method class generic ;
+
+TUPLE: single-combination ;
+
+PREDICATE: single-generic < generic
+ "combination" word-prop single-combination? ;
+
+GENERIC: dispatch# ( word -- n )
+
+M: generic dispatch# "combination" word-prop dispatch# ;
+
+SYMBOL: assumed
+SYMBOL: default
+SYMBOL: generic-word
+SYMBOL: combination
+
+: with-combination ( combination quot -- )
+ [ combination ] dip with-variable ; inline
+
+HOOK: picker combination ( -- quot )
+
+M: single-combination next-method-quot* ( class generic combination -- quot )
+ [
+ 2dup next-method dup [
+ [
+ pick "predicate" word-prop %
+ 1quotation ,
+ [ inconsistent-next-method ] 2curry ,
+ \ if ,
+ ] [ ] make picker prepend
+ ] [ 3drop f ] if
+ ] with-combination ;
+
+: (effective-method) ( obj word -- method )
+ [ [ order [ instance? ] with find-last nip ] keep method ]
+ [ "default-method" word-prop ]
+ bi or ;
+
+M: single-combination make-default-method
+ [ [ picker ] dip [ no-method ] curry append ] with-combination ;
+
+! ! ! Build an engine ! ! !
+
+: find-default ( methods -- default )
+ #! Side-effects methods.
+ [ object bootstrap-word ] dip delete-at* [
+ drop generic-word get "default-method" word-prop
+ ] unless ;
+
+! 1. Flatten methods
+TUPLE: predicate-engine methods ;
+
+: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
+
+: push-method ( method specializer atomic assoc -- )
+ [
+ [ H{ } clone <predicate-engine> ] unless*
+ [ methods>> set-at ] keep
+ ] change-at ;
+
+: flatten-method ( class method assoc -- )
+ [ [ flatten-class keys ] keep ] 2dip [
+ [ spin ] dip push-method
+ ] 3curry each ;
+
+: flatten-methods ( assoc -- assoc' )
+ H{ } clone [ [ flatten-method ] curry assoc-each ] keep ;
+
+! 2. Convert methods
+: split-methods ( assoc class -- first second )
+ [ [ nip class<= not ] curry assoc-filter ]
+ [ [ nip class<= ] curry assoc-filter ] 2bi ;
+
+: convert-methods ( assoc class word -- assoc' )
+ over [ split-methods ] 2dip pick assoc-empty?
+ [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline
+
+! 2.1 Convert tuple methods
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> echelon-dispatch-engine
+
+TUPLE: tuple-dispatch-engine echelons ;
+
+: push-echelon ( class method assoc -- )
+ [ swap dup "layout" word-prop third ] dip
+ [ ?set-at ] change-at ;
+
+: echelon-sort ( assoc -- assoc' )
+ #! Convert an assoc mapping classes to methods into an
+ #! assoc mapping echelons to assocs. The first echelon
+ #! is always there
+ H{ { 0 f } } clone [ [ push-echelon ] curry assoc-each ] keep ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+ echelon-sort
+ [ dupd <echelon-dispatch-engine> ] assoc-map
+ \ tuple-dispatch-engine boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+ tuple bootstrap-word
+ \ <tuple-dispatch-engine> convert-methods ;
+
+! 2.2 Convert hi-tag methods
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+ \ hi-tag bootstrap-word
+ \ <hi-tag-dispatch-engine> convert-methods ;
+
+! 3 Tag methods
+TUPLE: tag-dispatch-engine methods ;
+
+C: <tag-dispatch-engine> tag-dispatch-engine
+
+: <engine> ( assoc -- engine )
+ flatten-methods
+ convert-tuple-methods
+ convert-hi-tag-methods
+ <tag-dispatch-engine> ;
+
+! ! ! Compile engine ! ! !
+GENERIC: compile-engine ( engine -- obj )
+
+: compile-engines ( assoc -- assoc' )
+ [ compile-engine ] assoc-map ;
+
+: compile-engines* ( assoc -- assoc' )
+ [ over assumed [ compile-engine ] with-variable ] assoc-map ;
+
+: direct-dispatch-table ( assoc n -- table )
+ default get <array> [ <enum> swap update ] keep ;
+
+: lo-tag-number ( class -- n )
+ "type" word-prop dup num-tags get member?
+ [ drop object tag-number ] unless ;
+
+M: tag-dispatch-engine compile-engine
+ methods>> compile-engines*
+ [ [ lo-tag-number ] dip ] assoc-map
+ num-tags get direct-dispatch-table ;
+
+: num-hi-tags ( -- n ) num-types get num-tags get - ;
+
+: hi-tag-number ( class -- n ) "type" word-prop ;
+
+M: hi-tag-dispatch-engine compile-engine
+ methods>> compile-engines*
+ [ [ hi-tag-number num-tags get - ] dip ] assoc-map
+ num-hi-tags direct-dispatch-table ;
+
+: build-fast-hash ( methods -- buckets )
+ >alist V{ } clone [ hashcode 1array ] distribute-buckets
+ [ compile-engines* >alist >array ] map ;
+
+M: echelon-dispatch-engine compile-engine
+ dup n>> 0 = [
+ methods>> dup assoc-size {
+ { 0 [ drop default get ] }
+ { 1 [ >alist first second compile-engine ] }
+ } case
+ ] [
+ methods>> compile-engines* build-fast-hash
+ ] if ;
+
+M: tuple-dispatch-engine compile-engine
+ tuple assumed [
+ echelons>> compile-engines
+ dup keys supremum 1 + f <array>
+ [ <enum> swap update ] keep
+ ] with-variable ;
+
+: sort-methods ( assoc -- assoc' )
+ >alist [ keys sort-classes ] keep extract-keys ;
+
+: quote-methods ( assoc -- assoc' )
+ [ 1quotation \ drop prefix ] assoc-map ;
+
+: methods-with-default ( engine -- assoc )
+ methods>> clone default get object bootstrap-word pick set-at ;
+
+: keep-going? ( assoc -- ? )
+ assumed get swap second first class<= ;
+
+: prune-redundant-predicates ( assoc -- default assoc' )
+ {
+ { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
+ { [ dup length 1 = ] [ first second { } ] }
+ { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
+ [ [ first second ] [ rest-slice ] bi ]
+ } cond ;
+
+: class-predicates ( assoc -- assoc )
+ [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
+
+PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
+
+: <predicate-engine-word> ( -- word )
+ generic-word get name>> "/predicate-engine" append f <word>
+ dup generic-word get "owner-generic" set-word-prop ;
+
+M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
+
+: define-predicate-engine ( alist -- word )
+ [ <predicate-engine-word> ] dip
+ [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
+
+M: predicate-engine compile-engine
+ methods-with-default
+ sort-methods
+ quote-methods
+ prune-redundant-predicates
+ class-predicates
+ [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
+
+M: word compile-engine ;
+
+M: f compile-engine ;
+
+: build-decision-tree ( generic -- methods )
+ [ "engines" word-prop forget-all ]
+ [ V{ } clone "engines" set-word-prop ]
+ [
+ "methods" word-prop clone
+ [ find-default default set ]
+ [ <engine> compile-engine ] bi
+ ] tri ;
+
+HOOK: inline-cache-quot combination ( word methods -- quot/f )
+
+: define-inline-cache-quot ( word methods -- )
+ [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ;
+
+HOOK: mega-cache-quot combination ( methods -- quot/f )
+
+M: single-combination perform-combination
+ [
+ dup generic-word set
+ dup build-decision-tree
+ [ "decision-tree" set-word-prop ]
+ [ mega-cache-quot define ]
+ [ define-inline-cache-quot ]
+ 2tri
+ ] with-combination ;
diff --git a/core/generic/standard/authors.txt b/core/generic/standard/authors.txt
index 1901f27a24..d4f5d6b3ae 100644
--- a/core/generic/standard/authors.txt
+++ b/core/generic/standard/authors.txt
@@ -1 +1 @@
-Slava Pestov
+Slava Pestov
\ No newline at end of file
diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor
deleted file mode 100644
index b6cb9fc9f7..0000000000
--- a/core/generic/standard/engines/engines.factor
+++ /dev/null
@@ -1,53 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel kernel.private namespaces quotations
-generic math sequences combinators words classes.algebra arrays
-;
-IN: generic.standard.engines
-
-SYMBOL: default
-SYMBOL: assumed
-SYMBOL: (dispatch#)
-
-GENERIC: engine>quot ( engine -- quot )
-
-: engines>quots ( assoc -- assoc' )
- [ engine>quot ] assoc-map ;
-
-: engines>quots* ( assoc -- assoc' )
- [ over assumed [ engine>quot ] with-variable ] assoc-map ;
-
-: if-small? ( assoc true false -- )
- [ dup assoc-size 4 <= ] 2dip if ; inline
-
-: linear-dispatch-quot ( alist -- quot )
- default get [ drop ] prepend swap
- [
- [ [ dup ] swap [ eq? ] curry compose ]
- [ [ drop ] prepose ]
- bi* [ ] like
- ] assoc-map
- alist>quot ;
-
-: split-methods ( assoc class -- first second )
- [ [ nip class<= not ] curry assoc-filter ]
- [ [ nip class<= ] curry assoc-filter ] 2bi ;
-
-: convert-methods ( assoc class word -- assoc' )
- over [ split-methods ] 2dip pick assoc-empty? [
- 3drop
- ] [
- [ execute ] dip pick set-at
- ] if ; inline
-
-: (picker) ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- (picker) [ dip swap ] curry ]
- } case ;
-
-: picker ( -- quot ) \ (dispatch#) get (picker) ;
-
-GENERIC: extra-values ( generic -- n )
diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor
deleted file mode 100644
index 152b112c2a..0000000000
--- a/core/generic/standard/engines/predicate/predicate.factor
+++ /dev/null
@@ -1,38 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: generic.standard.engines generic namespaces kernel
-kernel.private sequences classes.algebra accessors words
-combinators assocs arrays ;
-IN: generic.standard.engines.predicate
-
-TUPLE: predicate-dispatch-engine methods ;
-
-C: <predicate-dispatch-engine> predicate-dispatch-engine
-
-: class-predicates ( assoc -- assoc )
- [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ;
-
-: keep-going? ( assoc -- ? )
- assumed get swap second first class<= ;
-
-: prune-redundant-predicates ( assoc -- default assoc' )
- {
- { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] }
- { [ dup length 1 = ] [ first second { } ] }
- { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] }
- [ [ first second ] [ rest-slice ] bi ]
- } cond ;
-
-: sort-methods ( assoc -- assoc' )
- >alist [ keys sort-classes ] keep extract-keys ;
-
-: methods-with-default ( engine -- assoc )
- methods>> clone default get object bootstrap-word pick set-at ;
-
-M: predicate-dispatch-engine engine>quot
- methods-with-default
- engines>quots
- sort-methods
- prune-redundant-predicates
- class-predicates
- alist>quot ;
diff --git a/core/generic/standard/engines/predicate/summary.txt b/core/generic/standard/engines/predicate/summary.txt
deleted file mode 100644
index 47fee09ee5..0000000000
--- a/core/generic/standard/engines/predicate/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Chained-conditional dispatch strategy
diff --git a/core/generic/standard/engines/summary.txt b/core/generic/standard/engines/summary.txt
deleted file mode 100644
index 209190799b..0000000000
--- a/core/generic/standard/engines/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Generic word dispatch strategy implementation
diff --git a/core/generic/standard/engines/tag/summary.txt b/core/generic/standard/engines/tag/summary.txt
deleted file mode 100644
index 3eea4b11cf..0000000000
--- a/core/generic/standard/engines/tag/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Jump table keyed by pointer tag dispatch strategy
diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor
deleted file mode 100644
index 5ed33009c0..0000000000
--- a/core/generic/standard/engines/tag/tag.factor
+++ /dev/null
@@ -1,71 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes.private generic.standard.engines namespaces make
-arrays assocs sequences.private quotations kernel.private
-math slots.private math.private kernel accessors words
-layouts sorting sequences combinators ;
-IN: generic.standard.engines.tag
-
-TUPLE: lo-tag-dispatch-engine methods ;
-
-C: <lo-tag-dispatch-engine> lo-tag-dispatch-engine
-
-: direct-dispatch-quot ( alist n -- quot )
- default get <array>
- [ <enum> swap update ] keep
- [ dispatch ] curry >quotation ;
-
-: lo-tag-number ( class -- n )
- dup \ hi-tag bootstrap-word eq? [
- drop \ hi-tag tag-number
- ] [
- "type" word-prop
- ] if ;
-
-: sort-tags ( assoc -- alist ) >alist sort-keys reverse ;
-
-: tag-dispatch-test ( tag# -- quot )
- picker [ tag ] append swap [ eq? ] curry append ;
-
-: tag-dispatch-quot ( alist -- quot )
- [ default get ] dip
- [ [ tag-dispatch-test ] dip ] assoc-map
- alist>quot ;
-
-M: lo-tag-dispatch-engine engine>quot
- methods>> engines>quots*
- [ [ lo-tag-number ] dip ] assoc-map
- [
- [ sort-tags tag-dispatch-quot ]
- [ picker % [ tag ] % num-tags get direct-dispatch-quot ]
- if-small? %
- ] [ ] make ;
-
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
- \ hi-tag bootstrap-word
- \ <hi-tag-dispatch-engine> convert-methods ;
-
-: num-hi-tags ( -- n ) num-types get num-tags get - ;
-
-: hi-tag-number ( class -- n )
- "type" word-prop ;
-
-: hi-tag-quot ( -- quot )
- \ hi-tag def>> ;
-
-M: hi-tag-dispatch-engine engine>quot
- methods>> engines>quots*
- [ [ hi-tag-number ] dip ] assoc-map
- [
- picker % hi-tag-quot % [
- sort-tags linear-dispatch-quot
- ] [
- num-tags get , \ fixnum-fast ,
- [ [ num-tags get - ] dip ] assoc-map
- num-hi-tags direct-dispatch-quot
- ] if-small? %
- ] [ ] make ;
diff --git a/core/generic/standard/engines/tuple/summary.txt b/core/generic/standard/engines/tuple/summary.txt
deleted file mode 100644
index cb18ac5c78..0000000000
--- a/core/generic/standard/engines/tuple/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Tuple class dispatch strategy
diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor
deleted file mode 100644
index c88bd9d97e..0000000000
--- a/core/generic/standard/engines/tuple/tuple.factor
+++ /dev/null
@@ -1,167 +0,0 @@
-! Copyright (c) 2008 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes.tuple.private hashtables assocs sorting
-accessors combinators sequences slots.private math.parser words
-effects namespaces make generic generic.standard.engines
-classes.algebra math math.private kernel.private
-quotations arrays definitions ;
-IN: generic.standard.engines.tuple
-
-: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline
-
-: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline
-
-: tuple-layout% ( -- )
- [ { tuple } declare 1 slot { array } declare ] % ; inline
-
-: tuple-layout-echelon% ( -- )
- [ 4 slot ] % ; inline
-
-TUPLE: echelon-dispatch-engine n methods ;
-
-C: <echelon-dispatch-engine> echelon-dispatch-engine
-
-TUPLE: trivial-tuple-dispatch-engine n methods ;
-
-C: <trivial-tuple-dispatch-engine> trivial-tuple-dispatch-engine
-
-TUPLE: tuple-dispatch-engine echelons ;
-
-: push-echelon ( class method assoc -- )
- [ swap dup "layout" word-prop third ] dip
- [ ?set-at ] change-at ;
-
-: echelon-sort ( assoc -- assoc' )
- V{ } clone [
- [
- push-echelon
- ] curry assoc-each
- ] keep sort-keys ;
-
-: <tuple-dispatch-engine> ( methods -- engine )
- echelon-sort
- [ dupd <echelon-dispatch-engine> ] assoc-map
- \ tuple-dispatch-engine boa ;
-
-: convert-tuple-methods ( assoc -- assoc' )
- tuple bootstrap-word
- \ <tuple-dispatch-engine> convert-methods ;
-
-M: trivial-tuple-dispatch-engine engine>quot
- [ n>> ] [ methods>> ] bi dup assoc-empty? [
- 2drop default get [ drop ] prepend
- ] [
- [
- [ nth-superclass% ]
- [ engines>quots* linear-dispatch-quot % ] bi*
- ] [ ] make
- ] if ;
-
-: hash-methods ( n methods -- buckets )
- >alist V{ } clone [ hashcode 1array ] distribute-buckets
- [ <trivial-tuple-dispatch-engine> ] with map ;
-
-: class-hash-dispatch-quot ( n methods -- quot )
- [
- \ dup ,
- [ drop nth-hashcode% ]
- [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi
- ] [ ] make ;
-
-: engine-word-name ( -- string )
- generic get name>> "/tuple-dispatch-engine" append ;
-
-PREDICATE: engine-word < word
- "tuple-dispatch-generic" word-prop generic? ;
-
-M: engine-word stack-effect
- "tuple-dispatch-generic" word-prop
- [ extra-values ] [ stack-effect ] bi
- dup [
- [ in>> length + ] [ out>> ] [ terminated?>> ] tri
- effect boa
- ] [ 2drop f ] if ;
-
-M: engine-word crossref? "forgotten" word-prop not ;
-
-M: engine-word irrelevant? drop t ;
-
-: remember-engine ( word -- )
- generic get "engines" word-prop push ;
-
-: <engine-word> ( -- word )
- engine-word-name f <word>
- dup generic get "tuple-dispatch-generic" set-word-prop ;
-
-: define-engine-word ( quot -- word )
- [ <engine-word> dup ] dip define ;
-
-: tuple-dispatch-engine-body ( engine -- quot )
- [
- picker %
- tuple-layout%
- [ n>> ] [ methods>> ] bi
- [ <trivial-tuple-dispatch-engine> engine>quot ]
- [ class-hash-dispatch-quot ]
- if-small? %
- ] [ ] make ;
-
-M: echelon-dispatch-engine engine>quot
- dup n>> zero? [
- methods>> dup assoc-empty?
- [ drop default get ] [ values first engine>quot ] if
- ] [
- tuple-dispatch-engine-body
- ] if ;
-
-: >=-case-quot ( default alist -- quot )
- [ [ drop ] prepend ] dip
- [
- [ [ dup ] swap [ fixnum>= ] curry compose ]
- [ [ drop ] prepose ]
- bi* [ ] like
- ] assoc-map
- alist>quot ;
-
-: simplify-echelon-alist ( default alist -- default' alist' )
- dup empty? [
- dup first first 1 <= [
- nip unclip second swap
- simplify-echelon-alist
- ] when
- ] unless ;
-
-: echelon-case-quot ( alist -- quot )
- #! We don't have to test for echelon 1 since all tuple
- #! classes are at least at depth 1 in the inheritance
- #! hierarchy.
- default get swap simplify-echelon-alist
- [
- [
- picker %
- tuple-layout%
- tuple-layout-echelon%
- >=-case-quot %
- ] [ ] make
- ] unless-empty ;
-
-M: tuple-dispatch-engine engine>quot
- [
- [
- tuple assumed set
- echelons>> unclip-last
- [
- [
- engine>quot
- over 0 = [
- define-engine-word
- [ remember-engine ] [ 1quotation ] bi
- ] unless
- dup default set
- ] assoc-map
- ]
- [ first2 engine>quot 2array ] bi*
- suffix
- ] with-scope
- echelon-case-quot %
- ] [ ] make ;
diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor
index 6e788eb947..33da0037b3 100644
--- a/core/generic/standard/standard-docs.factor
+++ b/core/generic/standard/standard-docs.factor
@@ -1,12 +1,7 @@
-USING: generic help.markup help.syntax sequences math
+USING: generic generic.single help.markup help.syntax sequences math
math.parser effects ;
IN: generic.standard
-HELP: no-method
-{ $values { "object" "an object" } { "generic" "a generic word" } }
-{ $description "Throws a " { $link no-method } " error." }
-{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ;
-
HELP: standard-combination
{ $class-description
"Performs standard method combination."
@@ -22,32 +17,6 @@ HELP: standard-combination
}
} ;
-HELP: hook-combination
-{ $class-description
- "Performs hook method combination . See " { $link POSTPONE: HOOK: } "."
-} ;
-
HELP: define-simple-generic
{ $values { "word" "a word" } { "effect" effect } }
-{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
-
-{ standard-combination hook-combination } related-words
-
-HELP: inconsistent-next-method
-{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
-{ $examples
- "The following code throws this error:"
- { $code
- "GENERIC: error-test ( object -- )"
- ""
- "M: string error-test print ;"
- ""
- "M: integer error-test number>string call-next-method ;"
- ""
- "123 error-test"
- }
- "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method."
- $nl
- "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:"
- { $code "M: integer error-test number>string error-test ;" }
-} ;
+{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ;
\ No newline at end of file
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 5dbc0d17a1..87611a76d0 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -1,180 +1,57 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel kernel.private slots.private math
-namespaces make sequences vectors words quotations definitions
-hashtables layouts combinators sequences.private generic
-classes classes.algebra classes.private generic.standard.engines
-generic.standard.engines.tag generic.standard.engines.predicate
-generic.standard.engines.tuple accessors ;
+USING: accessors definitions generic generic.single kernel
+namespaces words math math.order combinators sequences
+generic.single.private quotations kernel.private
+assocs arrays layouts ;
IN: generic.standard
-GENERIC: dispatch# ( word -- n )
+TUPLE: standard-combination < single-combination # ;
-M: generic dispatch#
- "combination" word-prop dispatch# ;
-
-GENERIC: method-declaration ( class generic -- quot )
-
-M: generic method-declaration
- "combination" word-prop method-declaration ;
-
-M: quotation engine>quot
- assumed get generic get method-declaration prepend ;
-
-ERROR: no-method object generic ;
-
-: error-method ( word -- quot )
- [ picker ] dip [ no-method ] curry append ;
-
-: push-method ( method specializer atomic assoc -- )
- [
- [ H{ } clone <predicate-dispatch-engine> ] unless*
- [ methods>> set-at ] keep
- ] change-at ;
-
-: flatten-method ( class method assoc -- )
- [ [ flatten-class keys ] keep ] 2dip [
- [ spin ] dip push-method
- ] 3curry each ;
-
-: flatten-methods ( assoc -- assoc' )
- H{ } clone [
- [
- flatten-method
- ] curry assoc-each
- ] keep ;
-
-: <big-dispatch-engine> ( assoc -- engine )
- flatten-methods
- convert-tuple-methods
- convert-hi-tag-methods
- <lo-tag-dispatch-engine> ;
-
-: mangle-method ( method -- quot )
- 1quotation generic get extra-values \ drop <repetition>
- prepend [ ] like ;
-
-: find-default ( methods -- quot )
- #! Side-effects methods.
- [ object bootstrap-word ] dip delete-at* [
- drop generic get "default-method" word-prop mangle-method
- ] unless ;
-
-: <standard-engine> ( word -- engine )
- object bootstrap-word assumed set {
- [ generic set ]
- [ "engines" word-prop forget-all ]
- [ V{ } clone "engines" set-word-prop ]
- [
- "methods" word-prop
- [ mangle-method ] assoc-map
- [ find-default default set ]
- [ <big-dispatch-engine> ]
- bi
- ]
- } cleave ;
-
-: single-combination ( word -- quot )
- [ <standard-engine> engine>quot ] with-scope ;
-
-ERROR: inconsistent-next-method class generic ;
-
-: single-next-method-quot ( class generic -- quot/f )
- 2dup next-method dup [
- [
- pick "predicate" word-prop %
- 1quotation ,
- [ inconsistent-next-method ] 2curry ,
- \ if ,
- ] [ ] make
- ] [ 3drop f ] if ;
-
-: single-effective-method ( obj word -- method )
- [ [ order [ instance? ] with find-last nip ] keep method ]
- [ "default-method" word-prop ]
- bi or ;
-
-TUPLE: standard-combination # ;
-
-C: <standard-combination> standard-combination
+: <standard-combination> ( n -- standard-combination )
+ dup 0 2 between? [ "Bad dispatch position" throw ] unless
+ standard-combination boa ;
PREDICATE: standard-generic < generic
"combination" word-prop standard-combination? ;
PREDICATE: simple-generic < standard-generic
- "combination" word-prop #>> zero? ;
+ "combination" word-prop #>> 0 = ;
CONSTANT: simple-combination T{ standard-combination f 0 }
: define-simple-generic ( word effect -- )
[ simple-combination ] dip define-generic ;
-: with-standard ( combination quot -- quot' )
- [ #>> (dispatch#) ] dip with-variable ; inline
+: (picker) ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1 - (picker) [ dip swap ] curry ]
+ } case ;
-M: standard-generic extra-values drop 0 ;
-
-M: standard-combination make-default-method
- [ error-method ] with-standard ;
-
-M: standard-combination perform-combination
- [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
+M: standard-combination picker
+ combination get #>> (picker) ;
M: standard-combination dispatch# #>> ;
-M: standard-combination method-declaration
- dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
-
-M: standard-combination next-method-quot*
- [
- single-next-method-quot
- dup [ picker prepend ] when
- ] with-standard ;
-
M: standard-generic effective-method
- [ dispatch# (picker) call ] keep single-effective-method ;
+ [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
+ (effective-method) ;
-TUPLE: hook-combination var ;
+M: standard-combination inline-cache-quot ( word methods -- )
+ #! Direct calls to the generic word (not tail calls or indirect calls)
+ #! will jump to the inline cache entry point instead of the megamorphic
+ #! dispatch entry point.
+ combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ;
-C: <hook-combination> hook-combination
+: make-empty-cache ( -- array )
+ mega-cache-size get f <array> ;
-PREDICATE: hook-generic < generic
- "combination" word-prop hook-combination? ;
-
-: with-hook ( combination quot -- quot' )
- 0 (dispatch#) [
- [ hook-combination ] dip with-variable
- ] with-variable ; inline
-
-: prepend-hook-var ( quot -- quot' )
- hook-combination get var>> [ get ] curry prepend ;
-
-M: hook-combination dispatch# drop 0 ;
-
-M: hook-combination method-declaration 2drop [ ] ;
-
-M: hook-generic extra-values drop 1 ;
-
-M: hook-generic effective-method
- [ "combination" word-prop var>> get ] keep
- single-effective-method ;
-
-M: hook-combination make-default-method
- [ error-method prepend-hook-var ] with-hook ;
-
-M: hook-combination perform-combination
- [ drop ] [
- [ single-combination prepend-hook-var ] with-hook
- ] 2bi define ;
-
-M: hook-combination next-method-quot*
- [
- single-next-method-quot
- dup [ prepend-hook-var ] when
- ] with-hook ;
-
-M: simple-generic definer drop \ GENERIC: f ;
+M: standard-combination mega-cache-quot
+ combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ;
M: standard-generic definer drop \ GENERIC# f ;
-M: hook-generic definer drop \ HOOK: f ;
+M: simple-generic definer drop \ GENERIC: f ;
diff --git a/core/generic/standard/summary.txt b/core/generic/standard/summary.txt
deleted file mode 100644
index 5e731c6f15..0000000000
--- a/core/generic/standard/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Standard method combination used for most generic words
diff --git a/core/growable/growable.factor b/core/growable/growable.factor
index c4970f98bd..684aab1158 100644
--- a/core/growable/growable.factor
+++ b/core/growable/growable.factor
@@ -35,7 +35,7 @@ M: growable set-length ( n seq -- )
] if
(>>length) ;
-: new-size ( old -- new ) 1+ 3 * ; inline
+: new-size ( old -- new ) 1 + 3 * ; inline
: ensure ( n seq -- n seq )
growable-check
diff --git a/core/hashtables/hashtables-docs.factor b/core/hashtables/hashtables-docs.factor
old mode 100644
new mode 100755
index 5a19cce351..0619e798dc
--- a/core/hashtables/hashtables-docs.factor
+++ b/core/hashtables/hashtables-docs.factor
@@ -116,7 +116,7 @@ HELP: ?set-at
{ $description "If the third input is an assoc, stores the key/value pair into that assoc, or else creates a new hashtable with the key/value pair as its only entry." } ;
HELP: >hashtable
-{ $values { "assoc" "an assoc" } { "hashtable" "a hashtable" } }
+{ $values { "assoc" assoc } { "hashtable" hashtable } }
{ $description "Constructs a hashtable from any assoc." } ;
HELP: rehash
diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
index f95a7a7e67..0914134bb6 100644
--- a/core/hashtables/hashtables.factor
+++ b/core/hashtables/hashtables.factor
@@ -34,7 +34,7 @@ TUPLE: hashtable
[ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array )
- 1+ next-power-of-2 4 * ((empty)) <array> ; inline
+ 1 + next-power-of-2 4 * ((empty)) <array> ; inline
: init-hash ( hash -- )
0 >>count 0 >>deleted drop ; inline
@@ -61,10 +61,10 @@ TUPLE: hashtable
1 fixnum+fast set-slot ; inline
: hash-count+ ( hash -- )
- [ 1+ ] change-count drop ; inline
+ [ 1 + ] change-count drop ; inline
: hash-deleted+ ( hash -- )
- [ 1+ ] change-deleted drop ; inline
+ [ 1 + ] change-deleted drop ; inline
: (rehash) ( hash alist -- )
swap [ swapd set-at ] curry assoc-each ; inline
@@ -77,7 +77,7 @@ TUPLE: hashtable
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
: grow-hash ( hash -- )
- [ [ >alist ] [ assoc-size 1+ ] bi ] keep
+ [ [ >alist ] [ assoc-size 1 + ] bi ] keep
[ reset-hash ] keep
swap (rehash) ;
@@ -139,7 +139,7 @@ M: hashtable set-at ( value key hash -- )
PRIVATE>
M: hashtable >alist
- [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
+ [ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
[
[
[ 1 fixnum-shift-fast ] dip
diff --git a/core/init/init.factor b/core/init/init.factor
index 5d8e88b85f..0140fcc0e8 100644
--- a/core/init/init.factor
+++ b/core/init/init.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations continuations.private kernel
-kernel.private sequences assocs namespaces namespaces.private ;
+kernel.private sequences assocs namespaces namespaces.private
+continuations continuations.private ;
IN: init
SYMBOL: init-hooks
diff --git a/core/io/encodings/encodings-docs.factor b/core/io/encodings/encodings-docs.factor
index 204441c19a..d0f968a791 100644
--- a/core/io/encodings/encodings-docs.factor
+++ b/core/io/encodings/encodings-docs.factor
@@ -80,12 +80,12 @@ ARTICLE: "encodings-descriptors" "Encoding descriptors"
"An encoding descriptor is something which can be used with binary input or output streams to encode or decode bytes stored in a certain representation. It must conform to the " { $link "encodings-protocol" } ". Encodings which you can use are defined in the following vocabularies:"
{ $subsection "io.encodings.binary" }
{ $subsection "io.encodings.utf8" }
-{ $subsection "io.encodings.utf16" }
+{ $vocab-subsection "UTF-16 encoding" "io.encodings.utf16" }
{ $vocab-subsection "UTF-32 encoding" "io.encodings.utf32" }
{ $vocab-subsection "Strict encodings" "io.encodings.strict" }
"Legacy encodings:"
{ $vocab-subsection "8-bit encodings" "io.encodings.8-bit" }
-{ $vocab-subsection "ASCII" "io.encodings.ascii" }
+{ $vocab-subsection "ASCII encoding" "io.encodings.ascii" }
{ $see-also "encodings-introduction" } ;
ARTICLE: "encodings-protocol" "Encoding protocol"
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 696de9af69..174816dd34 100644
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -130,7 +130,9 @@ M: encoder stream-element-type
M: encoder stream-write1
>encoder< encode-char ;
-: encoder-write ( string stream encoding -- )
+GENERIC# encoder-write 2 ( string stream encoding -- )
+
+M: string encoder-write
[ encode-char ] 2curry each ;
M: encoder stream-write
diff --git a/basis/io/encodings/utf16/authors.txt b/core/io/encodings/utf16/authors.txt
similarity index 100%
rename from basis/io/encodings/utf16/authors.txt
rename to core/io/encodings/utf16/authors.txt
diff --git a/basis/io/encodings/utf16/summary.txt b/core/io/encodings/utf16/summary.txt
similarity index 100%
rename from basis/io/encodings/utf16/summary.txt
rename to core/io/encodings/utf16/summary.txt
diff --git a/basis/io/encodings/utf16/utf16-docs.factor b/core/io/encodings/utf16/utf16-docs.factor
similarity index 100%
rename from basis/io/encodings/utf16/utf16-docs.factor
rename to core/io/encodings/utf16/utf16-docs.factor
diff --git a/core/io/encodings/utf16/utf16-tests.factor b/core/io/encodings/utf16/utf16-tests.factor
new file mode 100644
index 0000000000..e16c1f822e
--- /dev/null
+++ b/core/io/encodings/utf16/utf16-tests.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test io.encodings.utf16 arrays sbufs
+io.streams.byte-array sequences io.encodings io strings
+io.encodings.string alien.c-types alien.strings accessors classes ;
+IN: io.encodings.utf16.tests
+
+[ { CHAR: x } ] [ B{ 0 CHAR: x } utf16be decode >array ] unit-test
+[ { HEX: 1D11E } ] [ B{ HEX: D8 HEX: 34 HEX: DD HEX: 1E } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ BIN: 11011111 CHAR: q } utf16be decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ B{ BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } utf16be decode >array ] unit-test
+
+[ { 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } >string utf16be encode >array ] unit-test
+
+[ { CHAR: x } ] [ B{ CHAR: x 0 } utf16le decode >array ] unit-test
+[ { 119070 } ] [ B{ HEX: 34 HEX: D8 HEX: 1E HEX: DD } >string utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011111 } >string utf16le decode >array ] unit-test
+[ { CHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } >string utf16le decode >array ] unit-test
+
+[ { 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16le encode >array ] unit-test
+
+[ { CHAR: x } ] [ B{ HEX: ff HEX: fe CHAR: x 0 } utf16 decode >array ] unit-test
+[ { CHAR: x } ] [ B{ HEX: fe HEX: ff 0 CHAR: x } utf16 decode >array ] unit-test
+
+[ { HEX: ff HEX: fe 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } >string utf16 encode >array ] unit-test
diff --git a/basis/io/encodings/utf16/utf16.factor b/core/io/encodings/utf16/utf16.factor
similarity index 94%
rename from basis/io/encodings/utf16/utf16.factor
rename to core/io/encodings/utf16/utf16.factor
index d61c07f806..a6ccc95bf5 100644
--- a/basis/io/encodings/utf16/utf16.factor
+++ b/core/io/encodings/utf16/utf16.factor
@@ -1,21 +1,15 @@
! Copyright (C) 2006, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting io byte-arrays io.encodings.iana ;
+io.encodings combinators splitting io byte-arrays ;
IN: io.encodings.utf16
SINGLETON: utf16be
-utf16be "UTF-16BE" register-encoding
-
SINGLETON: utf16le
-utf16le "UTF-16LE" register-encoding
-
SINGLETON: utf16
-utf16 "UTF-16" register-encoding
-
ERROR: missing-bom ;
<PRIVATE
diff --git a/basis/io/encodings/utf16n/authors.txt b/core/io/encodings/utf16n/authors.txt
similarity index 100%
rename from basis/io/encodings/utf16n/authors.txt
rename to core/io/encodings/utf16n/authors.txt
diff --git a/basis/io/encodings/utf16n/summary.txt b/core/io/encodings/utf16n/summary.txt
similarity index 100%
rename from basis/io/encodings/utf16n/summary.txt
rename to core/io/encodings/utf16n/summary.txt
diff --git a/basis/io/encodings/utf16n/utf16n-docs.factor b/core/io/encodings/utf16n/utf16n-docs.factor
similarity index 100%
rename from basis/io/encodings/utf16n/utf16n-docs.factor
rename to core/io/encodings/utf16n/utf16n-docs.factor
diff --git a/basis/io/encodings/utf16n/utf16n-tests.factor b/core/io/encodings/utf16n/utf16n-tests.factor
similarity index 100%
rename from basis/io/encodings/utf16n/utf16n-tests.factor
rename to core/io/encodings/utf16n/utf16n-tests.factor
diff --git a/basis/io/encodings/utf16n/utf16n.factor b/core/io/encodings/utf16n/utf16n.factor
similarity index 67%
rename from basis/io/encodings/utf16n/utf16n.factor
rename to core/io/encodings/utf16n/utf16n.factor
index cc6e7e2baa..5664f24fda 100644
--- a/basis/io/encodings/utf16n/utf16n.factor
+++ b/core/io/encodings/utf16n/utf16n.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.encodings io.encodings.utf16 kernel ;
+USING: io.encodings io.encodings.utf16 kernel alien.accessors ;
IN: io.encodings.utf16n
! Native-order UTF-16
@@ -8,7 +8,7 @@ IN: io.encodings.utf16n
SINGLETON: utf16n
: utf16n ( -- descriptor )
- little-endian? utf16le utf16be ? ; foldable
+ B{ 1 0 0 0 } 0 alien-unsigned-4 1 = utf16le utf16be ? ; foldable
M: utf16n <decoder> drop utf16n <decoder> ;
diff --git a/core/io/encodings/utf8/utf8-tests.factor b/core/io/encodings/utf8/utf8-tests.factor
index 6cd3ee8033..088131acf9 100755
--- a/core/io/encodings/utf8/utf8-tests.factor
+++ b/core/io/encodings/utf8/utf8-tests.factor
@@ -6,7 +6,7 @@ IN: io.encodings.utf8.tests
utf8 decode >array ;
: encode-utf8-w/stream ( array -- newarray )
- utf8 encode >array ;
+ >string utf8 encode >array ;
[ { CHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8-w/stream ] unit-test
diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor
index cf0aea787b..9989d889a8 100644
--- a/core/io/files/files-docs.factor
+++ b/core/io/files/files-docs.factor
@@ -2,7 +2,20 @@ USING: help.markup help.syntax io strings arrays io.backend
io.files.private quotations sequences ;
IN: io.files
+ARTICLE: "io.files.examples" "Examples of reading and writing files"
+"Sort the lines in a file and write them back to the same file:"
+{ $code
+ "USING: io io.encodings.utf8 io.files sequences sorting ;"
+ "\"lines.txt\" utf8 [ file-lines natural-sort ] 2keep set-file-lines"
+}
+"Read 1024 bytes from a file:"
+{ $code
+ "USING: io io.encodings.binary io.files ;"
+ "\"data.bin\" binary [ 1024 read ] with-file-reader"
+} ;
+
ARTICLE: "io.files" "Reading and writing files"
+{ $subsection "io.files.examples" }
"File streams:"
{ $subsection <file-reader> }
{ $subsection <file-writer> }
diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index ce15a69773..f57dafbdc6 100644
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -1,12 +1,9 @@
USING: arrays debugger.threads destructors io io.directories
io.encodings.8-bit io.encodings.ascii io.encodings.binary
io.files io.files.private io.files.temp io.files.unique kernel
-make math sequences system threads tools.test ;
+make math sequences system threads tools.test generic.single ;
IN: io.files.tests
-\ exists? must-infer
-\ (exists?) must-infer
-
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
[ ] [ "append-test" temp-file ascii <file-appender> dispose ] unit-test
@@ -144,3 +141,15 @@ USE: debugger.threads
-10 seek-absolute seek-input
] with-file-reader
] must-fail
+
+[
+ "non-string-error" unique-file ascii [
+ { } write
+ ] with-file-writer
+] [ no-method? ] must-fail-with
+
+[
+ "non-byte-array-error" unique-file binary [
+ "" write
+ ] with-file-writer
+] [ no-method? ] must-fail-with
\ No newline at end of file
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index 1bc282e956..6779c6d094 100644
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -1,7 +1,8 @@
-! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences init namespaces system io
-io.backend io.pathnames io.encodings io.files.private ;
+io.backend io.pathnames io.encodings io.files.private
+alien.strings ;
IN: io.files
HOOK: (file-reader) io-backend ( path -- stream )
@@ -20,13 +21,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
swap normalize-path (file-appender) swap <encoder> ;
: file-lines ( path encoding -- seq )
- <file-reader> lines ;
+ <file-reader> stream-lines ;
: with-file-reader ( path encoding quot -- )
[ <file-reader> ] dip with-input-stream ; inline
: file-contents ( path encoding -- seq )
- <file-reader> contents ;
+ <file-reader> stream-contents ;
: with-file-writer ( path encoding quot -- )
[ <file-writer> ] dip with-output-stream ; inline
@@ -40,7 +41,8 @@ HOOK: (file-appender) io-backend ( path -- stream )
: with-file-appender ( path encoding quot -- )
[ <file-appender> ] dip with-output-stream ; inline
-: exists? ( path -- ? ) normalize-path (exists?) ;
+: exists? ( path -- ? )
+ normalize-path native-string>alien (exists?) ;
! Current directory
<PRIVATE
@@ -55,7 +57,7 @@ PRIVATE>
[
cwd current-directory set-global
- 13 getenv cwd prepend-path \ image set-global
- 14 getenv cwd prepend-path \ vm set-global
+ 13 getenv alien>native-string cwd prepend-path \ image set-global
+ 14 getenv alien>native-string cwd prepend-path \ vm set-global
image parent-directory "resource-path" set-global
] "io.files" add-init-hook
diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
index ebc248bbbf..3469a81064 100644
--- a/core/io/io-docs.factor
+++ b/core/io/io-docs.factor
@@ -221,10 +221,14 @@ HELP: bl
{ $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." }
$io-error ;
-HELP: lines
+HELP: stream-lines
{ $values { "stream" "an input stream" } { "seq" "a sequence of strings" } }
{ $description "Reads lines of text until the stream is exhausted, collecting them in a sequence of strings." } ;
+HELP: lines
+{ $values { "seq" "a sequence of strings" } }
+{ $description "Reads lines of text until from the " { $link input-stream } " until it is exhausted, collecting them in a sequence of strings." } ;
+
HELP: each-line
{ $values { "quot" { $quotation "( str -- )" } } }
{ $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ;
@@ -233,9 +237,14 @@ HELP: each-block
{ $values { "quot" { $quotation "( block -- )" } } }
{ $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ;
-HELP: contents
+HELP: stream-contents
{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." }
+{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." }
+$io-error ;
+
+HELP: contents
+{ $values { "seq" "a string, byte array or " { $link f } } }
+{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." }
$io-error ;
ARTICLE: "stream-protocol" "Stream protocol"
@@ -347,17 +356,37 @@ $nl
"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
{ $subsection stream-print }
"Processing lines one by one:"
+{ $subsection stream-lines }
{ $subsection lines }
{ $subsection each-line }
"Processing blocks of data:"
+{ $subsection stream-contents }
{ $subsection contents }
{ $subsection each-block }
"Copying the contents of one stream to another:"
{ $subsection stream-copy } ;
+ARTICLE: "stream-examples" "Stream example"
+"Ask the user for their age, and print it back:"
+{ $code
+ "USING: io math.parser ;"
+ ""
+ ": ask-age ( -- ) \"How old are you?\" print ;"
+ ""
+ ": read-age ( -- n ) readln string>number ;"
+ ""
+ ": print-age ( n -- )"
+ " \"You are \" write"
+ " number>string write"
+ " \" years old.\" print ;"
+ ": example ( -- ) ask-age read-age print-age ;"
+ ""
+ "example"
+} ;
+
ARTICLE: "streams" "Streams"
"Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of " { $emphasis "elements" } "."
-$nl
+{ $subsection "stream-examples" }
"A stream can either be passed around on the stack or bound to a dynamic variable and used as one of the two implicit " { $emphasis "default streams" } "."
{ $subsection "stream-protocol" }
{ $subsection "stdio" }
diff --git a/core/io/io.factor b/core/io/io.factor
index 74bba7769e..b43098bcd4 100644
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -68,9 +68,12 @@ SYMBOL: error-stream
: bl ( -- ) " " write ;
-: lines ( stream -- seq )
+: stream-lines ( stream -- seq )
[ [ readln dup ] [ ] produce nip ] with-input-stream ;
+: lines ( -- seq )
+ input-stream get stream-lines ;
+
<PRIVATE
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
@@ -81,11 +84,14 @@ PRIVATE>
: each-line ( quot -- )
[ readln ] each-morsel ; inline
-: contents ( stream -- seq )
+: stream-contents ( stream -- seq )
[
[ 65536 read-partial dup ] [ ] produce nip concat f like
] with-input-stream ;
+: contents ( -- seq )
+ input-stream get stream-contents ;
+
: each-block ( quot: ( block -- ) -- )
[ 8192 read-partial ] each-morsel ; inline
diff --git a/core/io/pathnames/pathnames.factor b/core/io/pathnames/pathnames.factor
index eba3e6a19f..30e9e6c206 100644
--- a/core/io/pathnames/pathnames.factor
+++ b/core/io/pathnames/pathnames.factor
@@ -17,7 +17,7 @@ SYMBOL: current-directory
[ path-separator? ] trim-head ;
: last-path-separator ( path -- n ? )
- [ length 1- ] keep [ path-separator? ] find-last-from ;
+ [ length 1 - ] keep [ path-separator? ] find-last-from ;
HOOK: root-directory? io-backend ( path -- ? )
@@ -30,7 +30,7 @@ ERROR: no-parent-directory path ;
dup root-directory? [
trim-tail-separators
dup last-path-separator [
- 1+ cut
+ 1 + cut
] [
drop "." swap
] if
@@ -113,7 +113,7 @@ PRIVATE>
: file-name ( path -- string )
dup root-directory? [
trim-tail-separators
- dup last-path-separator [ 1+ tail ] [
+ dup last-path-separator [ 1 + tail ] [
drop special-path? [ file-name ] when
] if
] unless ;
diff --git a/basis/io/streams/byte-array/byte-array-docs.factor b/core/io/streams/byte-array/byte-array-docs.factor
similarity index 100%
rename from basis/io/streams/byte-array/byte-array-docs.factor
rename to core/io/streams/byte-array/byte-array-docs.factor
diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor
similarity index 78%
rename from basis/io/streams/byte-array/byte-array-tests.factor
rename to core/io/streams/byte-array/byte-array-tests.factor
index 44290bfb47..0cd35dfa21 100644
--- a/basis/io/streams/byte-array/byte-array-tests.factor
+++ b/core/io/streams/byte-array/byte-array-tests.factor
@@ -1,12 +1,12 @@
USING: tools.test io.streams.byte-array io.encodings.binary
io.encodings.utf8 io kernel arrays strings namespaces ;
-[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
+[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
-[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
-[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
+[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
+[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
[ B{ 121 120 } 0 ] [
B{ 0 121 120 0 0 0 0 0 0 } binary
@@ -26,4 +26,4 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
0 seek-end input-stream get stream-seek
read1
] with-byte-reader
-] unit-test
\ No newline at end of file
+] unit-test
diff --git a/basis/io/streams/byte-array/byte-array.factor b/core/io/streams/byte-array/byte-array.factor
similarity index 90%
rename from basis/io/streams/byte-array/byte-array.factor
rename to core/io/streams/byte-array/byte-array.factor
index 2ffb9b9a63..4cb50dfbc1 100644
--- a/basis/io/streams/byte-array/byte-array.factor
+++ b/core/io/streams/byte-array/byte-array.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
-sequences io namespaces io.encodings.private accessors sequences.private
+USING: byte-arrays byte-vectors kernel io.encodings sequences io
+namespaces io.encodings.private accessors sequences.private
io.streams.sequence destructors math combinators ;
IN: io.streams.byte-array
diff --git a/basis/io/streams/byte-array/summary.txt b/core/io/streams/byte-array/summary.txt
similarity index 100%
rename from basis/io/streams/byte-array/summary.txt
rename to core/io/streams/byte-array/summary.txt
diff --git a/core/io/streams/c/c-tests.factor b/core/io/streams/c/c-tests.factor
index 3dde9152d0..6a82d6d545 100644
--- a/core/io/streams/c/c-tests.factor
+++ b/core/io/streams/c/c-tests.factor
@@ -5,6 +5,6 @@ IN: io.streams.c.tests
[ "hello world" ] [
"hello world" "test.txt" temp-file ascii set-file-contents
- "test.txt" temp-file "rb" fopen <c-reader> contents
+ "test.txt" temp-file "rb" fopen <c-reader> stream-contents
>string
] unit-test
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
index bec3bdc6bf..e25db47cdf 100755
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private namespaces make io io.encodings
-sequences math generic threads.private classes io.backend
-io.files continuations destructors byte-arrays accessors
-combinators ;
+USING: kernel kernel.private namespaces make io io.encodings sequences
+math generic threads.private classes io.backend io.files
+io.encodings.utf8 alien.strings continuations destructors byte-arrays
+accessors combinators ;
IN: io.streams.c
TUPLE: c-stream handle disposed ;
@@ -69,6 +69,9 @@ M: c-io-backend (init-stdio) init-c-stdio t ;
M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ;
+: fopen ( path mode -- handle )
+ [ utf8 string>alien ] bi@ (fopen) ;
+
M: c-io-backend (file-reader)
"rb" fopen <c-reader> ;
diff --git a/basis/io/streams/memory/memory.factor b/core/io/streams/memory/memory.factor
similarity index 62%
rename from basis/io/streams/memory/memory.factor
rename to core/io/streams/memory/memory.factor
index 52169de6f8..ad5453af61 100644
--- a/basis/io/streams/memory/memory.factor
+++ b/core/io/streams/memory/memory.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors alien alien.c-types alien.accessors math io ;
+USING: kernel accessors alien alien.accessors math io ;
IN: io.streams.memory
TUPLE: memory-stream alien index ;
@@ -13,9 +13,3 @@ M: memory-stream stream-element-type drop +byte+ ;
M: memory-stream stream-read1
[ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
[ [ 1+ ] change-index drop ] bi ;
-
-M: memory-stream stream-read
- [
- [ index>> ] [ alien>> ] bi <displaced-alien>
- swap memory>byte-array
- ] [ [ + ] change-index drop ] 2bi ;
diff --git a/basis/io/streams/memory/summary.txt b/core/io/streams/memory/summary.txt
similarity index 100%
rename from basis/io/streams/memory/summary.txt
rename to core/io/streams/memory/summary.txt
diff --git a/core/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor
index 0f922a37cc..036bab2213 100644
--- a/core/io/streams/sequence/sequence.factor
+++ b/core/io/streams/sequence/sequence.factor
@@ -12,7 +12,7 @@ SLOT: i
[ i>> ] [ underlying>> ] bi ; inline
: next ( stream -- )
- [ 1+ ] change-i drop ; inline
+ [ 1 + ] change-i drop ; inline
: sequence-read1 ( stream -- elt/f )
[ >sequence-stream< ?nth ] [ next ] bi ; inline
@@ -45,4 +45,4 @@ M: growable stream-write1 push ;
M: growable stream-write push-all ;
M: growable stream-flush drop ;
-INSTANCE: growable plain-writer
\ No newline at end of file
+INSTANCE: growable plain-writer
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index c178573a0a..e67e2bc0dd 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -129,6 +129,9 @@ HELP: ?
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
+HELP: boolean
+{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ;
+
HELP: >boolean
{ $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
{ $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ;
@@ -180,14 +183,30 @@ HELP: either?
{ $example "USING: kernel math prettyprint ;" "5 7 [ even? ] either? ." "f" }
} ;
+HELP: execute
+{ $values { "word" word } }
+{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." }
+{ $examples
+ { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
+} ;
+
+{ execute POSTPONE: execute( } related-words
+
+HELP: (execute)
+{ $values { "word" word } }
+{ $description "Executes a word without checking if it is a word first." }
+{ $warning "This word is in the " { $vocab-link "kernel.private" } " vocabulary because it is unsafe. Calling with a parameter that is not a word will crash Factor. Use " { $link execute } " instead." } ;
+
HELP: call
{ $values { "callable" callable } }
-{ $description "Calls a quotation." }
+{ $description "Calls a quotation. Words which " { $link call } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal quotation can have a static stack effect." }
{ $examples
"The following two lines are equivalent:"
{ $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" }
} ;
+{ call POSTPONE: call( } related-words
+
HELP: call-clear ( quot -- )
{ $values { "quot" callable } }
{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
@@ -841,260 +860,6 @@ $nl
{ $subsection roll }
{ $subsection -roll } ;
-ARTICLE: "cleave-shuffle-equivalence" "Expressing shuffle words with cleave combinators"
-"Cleave combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to cleave combinators are discussed in the documentation for " { $link bi } ", " { $link 2bi } ", " { $link 3bi } ", " { $link tri } ", " { $link 2tri } " and " { $link 3tri } "."
-$nl
-"Certain shuffle words can also be expressed in terms of the cleave combinators. Internalizing such identities can help with understanding and writing code using cleave combinators:"
-{ $code
- ": keep [ ] bi ;"
- ": 2keep [ ] 2bi ;"
- ": 3keep [ ] 3bi ;"
- ""
- ": dup [ ] [ ] bi ;"
- ": 2dup [ ] [ ] 2bi ;"
- ": 3dup [ ] [ ] 3bi ;"
- ""
- ": tuck [ nip ] [ ] 2bi ;"
- ": swap [ nip ] [ drop ] 2bi ;"
- ""
- ": over [ ] [ drop ] 2bi ;"
- ": pick [ ] [ 2drop ] 3bi ;"
- ": 2over [ ] [ drop ] 3bi ;"
-} ;
-
-ARTICLE: "cleave-combinators" "Cleave combinators"
-"The cleave combinators apply multiple quotations to a single value."
-$nl
-"Two quotations:"
-{ $subsection bi }
-{ $subsection 2bi }
-{ $subsection 3bi }
-"Three quotations:"
-{ $subsection tri }
-{ $subsection 2tri }
-{ $subsection 3tri }
-"Technically, the cleave combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on the top of the stack can be written in one of two ways:"
-{ $code
- "! First alternative; uses keep"
- "[ 1 + ] keep"
- "[ 1 - ] keep"
- "2 *"
- "! Second alternative: uses tri"
- "[ 1 + ]"
- "[ 1 - ]"
- "[ 2 * ] tri"
-}
-"The latter is more aesthetically pleasing than the former."
-$nl
-"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
-{ $subsection "cleave-shuffle-equivalence" } ;
-
-ARTICLE: "spread-shuffle-equivalence" "Expressing shuffle words with spread combinators"
-"Spread combinators are defined in terms of shuffle words, and mappings from certain shuffle idioms to spread combinators are discussed in the documentation for " { $link bi* } ", " { $link 2bi* } ", " { $link tri* } ", and " { $link 2tri* } "."
-$nl
-"Certain shuffle words can also be expressed in terms of the spread combinators. Internalizing such identities can help with understanding and writing code using spread combinators:"
-{ $code
- ": dip [ ] bi* ;"
- ": 2dip [ ] [ ] tri* ;"
- ""
- ": slip [ call ] [ ] bi* ;"
- ": 2slip [ call ] [ ] [ ] tri* ;"
- ""
- ": nip [ drop ] [ ] bi* ;"
- ": 2nip [ drop ] [ drop ] [ ] tri* ;"
- ""
- ": rot"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " 3tri ;"
- ""
- ": -rot"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " 3tri ;"
- ""
- ": spin"
- " [ [ drop ] [ drop ] [ ] tri* ]"
- " [ [ drop ] [ ] [ drop ] tri* ]"
- " [ [ ] [ drop ] [ drop ] tri* ]"
- " 3tri ;"
-} ;
-
-ARTICLE: "spread-combinators" "Spread combinators"
-"The spread combinators apply multiple quotations to multiple values. The " { $snippet "*" } " suffix signifies spreading."
-$nl
-"Two quotations:"
-{ $subsection bi* }
-{ $subsection 2bi* }
-"Three quotations:"
-{ $subsection tri* }
-{ $subsection 2tri* }
-"Technically, the spread combinators are redundant because they can be simulated using shuffle words and other combinators, and in addition, they do not reduce token counts by much, if at all. However, they can make code more readable by expressing intention and exploiting any inherent symmetry. For example, a piece of code which performs three operations on three related values can be written in one of two ways:"
-{ $code
- "! First alternative; uses dip"
- "[ [ 1 + ] dip 1 - ] dip 2 *"
- "! Second alternative: uses tri*"
- "[ 1 + ] [ 1 - ] [ 2 * ] tri*"
-}
-"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "."
-{ $subsection "spread-shuffle-equivalence" } ;
-
-ARTICLE: "apply-combinators" "Apply combinators"
-"The apply combinators apply a single quotation to multiple values. The " { $snippet "@" } " suffix signifies application."
-$nl
-"Two quotations:"
-{ $subsection bi@ }
-{ $subsection 2bi@ }
-"Three quotations:"
-{ $subsection tri@ }
-{ $subsection 2tri@ }
-"A pair of utility words built from " { $link bi@ } ":"
-{ $subsection both? }
-{ $subsection either? } ;
-
-ARTICLE: "slip-keep-combinators" "Retain stack combinators"
-"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
-$nl
-"The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
-{ $subsection dip }
-{ $subsection 2dip }
-{ $subsection 3dip }
-{ $subsection 4dip }
-"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
-{ $subsection slip }
-{ $subsection 2slip }
-{ $subsection 3slip }
-"The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
-{ $subsection keep }
-{ $subsection 2keep }
-{ $subsection 3keep } ;
-
-ARTICLE: "curried-dataflow" "Curried dataflow combinators"
-"Curried cleave combinators:"
-{ $subsection bi-curry }
-{ $subsection tri-curry }
-"Curried spread combinators:"
-{ $subsection bi-curry* }
-{ $subsection tri-curry* }
-"Curried apply combinators:"
-{ $subsection bi-curry@ }
-{ $subsection tri-curry@ }
-{ $see-also "dataflow-combinators" } ;
-
-ARTICLE: "compositional-examples" "Examples of compositional combinator usage"
-"Consider printing the same message ten times:"
-{ $code ": print-10 ( -- ) 10 [ \"Hello, world.\" print ] times ;" }
-"if we wanted to abstract out the message into a parameter, we could keep it on the stack between iterations:"
-{ $code ": print-10 ( message -- ) 10 [ dup print ] times drop ;" }
-"However, keeping loop-invariant values on the stack doesn't always work out nicely. For example, a word to subtract a value from each element of a sequence:"
-{ $code ": subtract-n ( seq n -- seq' ) swap [ over - ] map nip ;" }
-"Three shuffle words are required to pass the value around. Instead, the loop-invariant value can be partially applied to a quotation using " { $link curry } ", yielding a new quotation that is passed to " { $link map } ":"
-{ $example
- "USING: kernel math prettyprint sequences ;"
- ": subtract-n ( seq n -- seq' ) [ - ] curry map ;"
- "{ 10 20 30 } 5 subtract-n ."
- "{ 5 15 25 }"
-}
-"Now consider the word that is dual to the one above; instead of subtracting " { $snippet "n" } " from each stack element, it subtracts each element from " { $snippet "n" } "."
-$nl
-"One way to write this is with a pair of " { $link swap } "s:"
-{ $code ": n-subtract ( n seq -- seq' ) swap [ swap - ] curry map ;" }
-"Since this pattern comes up often, " { $link with } " encapsulates it:"
-{ $example
- "USING: kernel math prettyprint sequences ;"
- ": n-subtract ( n seq -- seq' ) [ - ] with map ;"
- "30 { 10 20 30 } n-subtract ."
- "{ 20 10 0 }"
-}
-{ $see-also "fry.examples" } ;
-
-ARTICLE: "compositional-combinators" "Compositional combinators"
-"Certain combinators transform quotations to produce a new quotation."
-{ $subsection "compositional-examples" }
-"Fundamental operations:"
-{ $subsection curry }
-{ $subsection compose }
-"Derived operations:"
-{ $subsection 2curry }
-{ $subsection 3curry }
-{ $subsection with }
-{ $subsection prepose }
-"These operations run in constant time, and in many cases are optimized out altogether by the " { $link "compiler" } ". " { $link "fry" } " are an abstraction built on top of these operations, and code that uses this abstraction is often clearer than direct calls to the below words."
-$nl
-"Curried dataflow combinators can be used to build more complex dataflow by combining cleave, spread and apply patterns in various ways."
-{ $subsection "curried-dataflow" }
-"Quotations also implement the sequence protocol, and can be manipulated with sequence words; see " { $link "quotations" } ". However, such runtime quotation manipulation will not be optimized by the optimizing compiler." ;
-
-ARTICLE: "implementing-combinators" "Implementing combinators"
-"The following pair of words invoke words and quotations reflectively:"
-{ $subsection call }
-{ $subsection execute }
-"These words are used to implement combinators. Note that combinator definitions must be followed by the " { $link POSTPONE: inline } " declaration in order to compile in the optimizing compiler; for example:"
-{ $code
- ": keep ( x quot -- x )"
- " over [ call ] dip ; inline"
-}
-"Word inlining is documented in " { $link "declarations" } "." ;
-
-ARTICLE: "booleans" "Booleans"
-"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
-{ $subsection f }
-{ $subsection t }
-"The " { $link f } " object is the unique instance of the " { $link f } " class; the two are distinct objects. The latter is also a parsing word which adds the " { $link f } " object to the parse tree at parse time. To refer to the class itself you must use " { $link POSTPONE: POSTPONE: } " or " { $link POSTPONE: \ } " to prevent the parsing word from executing."
-$nl
-"Here is the " { $link f } " object:"
-{ $example "f ." "f" }
-"Here is the " { $link f } " class:"
-{ $example "\\ f ." "POSTPONE: f" }
-"They are not equal:"
-{ $example "f \\ f = ." "f" }
-"Here is an array containing the " { $link f } " object:"
-{ $example "{ f } ." "{ f }" }
-"Here is an array containing the " { $link f } " class:"
-{ $example "{ POSTPONE: f } ." "{ POSTPONE: f }" }
-"The " { $link f } " object is an instance of the " { $link f } " class:"
-{ $example "USE: classes" "f class ." "POSTPONE: f" }
-"The " { $link f } " class is an instance of " { $link word } ":"
-{ $example "USE: classes" "\\ f class ." "word" }
-"On the other hand, " { $link t } " is just a word, and there is no class which it is a unique instance of."
-{ $example "t \\ t eq? ." "t" }
-"Many words which search collections confuse the case of no element being present with an element being found equal to " { $link f } ". If this distinction is imporant, there is usually an alternative word which can be used; for example, compare " { $link at } " with " { $link at* } "." ;
-
-ARTICLE: "conditionals-boolean-equivalence" "Expressing conditionals with boolean logic"
-"Certain simple conditional forms can be expressed in a simpler manner using boolean logic."
-$nl
-"The following two lines are equivalent:"
-{ $code "[ drop f ] unless" "swap and" }
-"The following two lines are equivalent:"
-{ $code "[ ] [ ] ?if" "swap or" }
-"The following two lines are equivalent, where " { $snippet "L" } " is a literal:"
-{ $code "[ L ] unless*" "L or" } ;
-
-ARTICLE: "conditionals" "Conditionals and logic"
-"The basic conditionals:"
-{ $subsection if }
-{ $subsection when }
-{ $subsection unless }
-"Forms abstracting a common stack shuffle pattern:"
-{ $subsection if* }
-{ $subsection when* }
-{ $subsection unless* }
-"Another form abstracting a common stack shuffle pattern:"
-{ $subsection ?if }
-"Sometimes instead of branching, you just need to pick one of two values:"
-{ $subsection ? }
-"There are some logical operations on booleans:"
-{ $subsection >boolean }
-{ $subsection not }
-{ $subsection and }
-{ $subsection or }
-{ $subsection xor }
-{ $subsection "conditionals-boolean-equivalence" }
-"See " { $link "combinators" } " for forms which abstract away common patterns involving multiple nested branches."
-{ $see-also "booleans" "bitwise-arithmetic" both? either? } ;
-
ARTICLE: "equality" "Equality"
"There are two distinct notions of “sameness” when it comes to objects."
$nl
@@ -1116,34 +881,3 @@ ARTICLE: "assertions" "Assertions"
{ $subsection assert }
{ $subsection assert= } ;
-ARTICLE: "dataflow-combinators" "Data flow combinators"
-"Data flow combinators pass values between quotations:"
-{ $subsection "slip-keep-combinators" }
-{ $subsection "cleave-combinators" }
-{ $subsection "spread-combinators" }
-{ $subsection "apply-combinators" }
-{ $see-also "curried-dataflow" } ;
-
-ARTICLE: "dataflow" "Data and control flow"
-{ $subsection "evaluator" }
-{ $subsection "words" }
-{ $subsection "effects" }
-{ $subsection "booleans" }
-{ $subsection "shuffle-words" }
-"A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input."
-{ $subsection "dataflow-combinators" }
-{ $subsection "conditionals" }
-{ $subsection "looping-combinators" }
-{ $subsection "compositional-combinators" }
-{ $subsection "combinators" }
-"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
-$nl
-"Advanced topics:"
-{ $subsection "assertions" }
-{ $subsection "implementing-combinators" }
-{ $subsection "macros" }
-{ $subsection "errors" }
-{ $subsection "continuations" } ;
-
-ABOUT: "dataflow"
-
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 63346f4701..5a88db4f9e 100644
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -1,7 +1,7 @@
USING: arrays byte-arrays kernel kernel.private math memory
namespaces sequences tools.test math.private quotations
continuations prettyprint io.streams.string debugger assocs
-sequences.private accessors locals.backend grouping ;
+sequences.private accessors locals.backend grouping words ;
IN: kernel.tests
[ 0 ] [ f size ] unit-test
@@ -23,20 +23,25 @@ IN: kernel.tests
: overflow-d ( -- ) 3 overflow-d ;
+: (overflow-d-alt) ( -- n ) 3 ;
+
+: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
+
+: overflow-r ( -- ) 3 load-local overflow-r ;
+
+<<
+{ overflow-d (overflow-d-alt) overflow-d-alt overflow-r }
+[ t "no-compile" set-word-prop ] each
+>>
+
[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ :c ] unit-test
-: (overflow-d-alt) ( -- ) 3 ;
-
-: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
-
[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with
[ ] [ [ :c ] with-string-writer drop ] unit-test
-: overflow-r ( -- ) 3 load-local overflow-r ;
-
[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with
[ ] [ :c ] unit-test
@@ -99,7 +104,9 @@ IN: kernel.tests
[ ] [ :c ] unit-test
! Doesn't compile; important
-: foo ( a -- b ) 5 + 0 [ ] each ;
+: foo ( a -- b ) ;
+
+<< \ foo t "no-compile" set-word-prop >>
[ drop foo ] must-fail
[ ] [ :c ] unit-test
@@ -107,15 +114,15 @@ IN: kernel.tests
! Regression
: (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap
- < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline
+ < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
-: loop ( obj obj -- )
+: loop ( obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
[ loop ] must-fail
! Discovered on Windows
-: total-failure-1 ( -- ) "" [ ] map unimplemented ;
+: total-failure-1 ( -- a ) "" [ ] map unimplemented ;
[ total-failure-1 ] must-fail
@@ -168,4 +175,4 @@ IN: kernel.tests
[ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test
-[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
\ No newline at end of file
+[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index baccf56059..6245080225 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -176,12 +176,14 @@ PRIVATE>
: tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline
! Booleans
+UNION: boolean POSTPONE: t POSTPONE: f ;
+
+: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
+
: not ( obj -- ? ) [ f ] [ t ] if ; inline
: and ( obj1 obj2 -- ? ) over ? ; inline
-: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
-
: or ( obj1 obj2 -- ? ) dupd ? ; inline
: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
diff --git a/core/layouts/layouts.factor b/core/layouts/layouts.factor
index 5a32ca2dce..42898fc085 100644
--- a/core/layouts/layouts.factor
+++ b/core/layouts/layouts.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces math words kernel assocs classes
math.order kernel.private ;
@@ -16,12 +16,14 @@ SYMBOL: tag-numbers
SYMBOL: type-numbers
-: tag-number ( class -- n )
- tag-numbers get at [ object tag-number ] unless* ;
+SYMBOL: mega-cache-size
: type-number ( class -- n )
type-numbers get at ;
+: tag-number ( class -- n )
+ type-number dup num-tags get >= [ drop object tag-number ] when ;
+
: tag-fixnum ( n -- tagged )
tag-bits get shift ;
@@ -47,13 +49,13 @@ SYMBOL: type-numbers
cell-bits (first-bignum) ; inline
: most-positive-fixnum ( -- n )
- first-bignum 1- ; inline
+ first-bignum 1 - ; inline
: most-negative-fixnum ( -- n )
first-bignum neg ; inline
: (max-array-capacity) ( b -- n )
- 5 - 2^ 1- ; inline
+ 5 - 2^ 1 - ; inline
: max-array-capacity ( -- n )
cell-bits (max-array-capacity) ; inline
@@ -62,7 +64,7 @@ SYMBOL: type-numbers
bootstrap-cell-bits (first-bignum) ;
: bootstrap-most-positive-fixnum ( -- n )
- bootstrap-first-bignum 1- ;
+ bootstrap-first-bignum 1 - ;
: bootstrap-most-negative-fixnum ( -- n )
bootstrap-first-bignum neg ;
diff --git a/core/lexer/lexer.factor b/core/lexer/lexer.factor
index 75341f0204..60157033d7 100644
--- a/core/lexer/lexer.factor
+++ b/core/lexer/lexer.factor
@@ -9,7 +9,7 @@ TUPLE: lexer text line line-text line-length column ;
: next-line ( lexer -- )
dup [ line>> ] [ text>> ] bi ?nth >>line-text
dup line-text>> length >>line-length
- [ 1+ ] change-line
+ [ 1 + ] change-line
0 >>column
drop ;
@@ -39,7 +39,7 @@ GENERIC: skip-word ( lexer -- )
M: lexer skip-word ( lexer -- )
[
- 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
+ 2dup nth CHAR: " eq? [ drop 1 + ] [ f skip ] if
] change-lexer-column ;
: still-parsing? ( lexer -- ? )
diff --git a/core/math/floats/floats-tests.factor b/core/math/floats/floats-tests.factor
index 27cc510ea2..097e2c14aa 100644
--- a/core/math/floats/floats-tests.factor
+++ b/core/math/floats/floats-tests.factor
@@ -50,14 +50,12 @@ IN: math.floats.tests
[ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ]
unit-test
-[ 2.0 ] [ 1.0 1+ ] unit-test
-[ 0.0 ] [ 1.0 1- ] unit-test
+[ 2.0 ] [ 1.0 1 + ] unit-test
+[ 0.0 ] [ 1.0 1 - ] unit-test
[ t ] [ 0.0 zero? ] unit-test
[ t ] [ -0.0 zero? ] unit-test
-! [ f ] [ 0.0/0.0 0.0/0.0 number= ] unit-test
-
[ 0 ] [ 1/0. >bignum ] unit-test
[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor
index 6bd3e9b094..a9469ae91a 100644
--- a/core/math/integers/integers-tests.factor
+++ b/core/math/integers/integers-tests.factor
@@ -206,8 +206,8 @@ unit-test
[ 2. ] [ 2 1 ratio>float ] unit-test
[ .5 ] [ 1 2 ratio>float ] unit-test
[ .75 ] [ 3 4 ratio>float ] unit-test
-[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
-[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
+[ 1. ] [ 2000 2^ 2000 2^ 1 + ratio>float ] unit-test
+[ -1. ] [ 2000 2^ neg 2000 2^ 1 + ratio>float ] unit-test
[ 0.4 ] [ 6 15 ratio>float ] unit-test
[ HEX: 3fe553522d230931 ]
diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor
index e88caa7703..bb7fc107b2 100644
--- a/core/math/integers/integers.factor
+++ b/core/math/integers/integers.factor
@@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ;
M: fixnum bit? neg shift 1 bitand 0 > ;
: fixnum-log2 ( x -- n )
- 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ;
+ 0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;
M: fixnum (log2) fixnum-log2 ;
@@ -86,7 +86,7 @@ M: bignum (log2) bignum-log2 ;
! provided with absolutely no warranty."
! First step: pre-scaling
-: twos ( x -- y ) dup 1- bitxor log2 ; inline
+: twos ( x -- y ) dup 1 - bitxor log2 ; inline
: scale-denonimator ( den -- scaled-den scale' )
dup twos neg [ shift ] keep ; inline
@@ -98,7 +98,7 @@ M: bignum (log2) bignum-log2 ;
! Second step: loop
: shift-mantissa ( scale mantissa -- scale' mantissa' )
- [ 1+ ] [ 2/ ] bi* ; inline
+ [ 1 + ] [ 2/ ] bi* ; inline
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ]
@@ -107,7 +107,7 @@ M: bignum (log2) bignum-log2 ;
! Third step: post-scaling
: unscaled-float ( mantissa -- n )
- 52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
+ 52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline
: scale-float ( scale mantissa -- float' )
[ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
@@ -122,11 +122,11 @@ M: bignum (log2) bignum-log2 ;
2drop 0.0
] [
dup zero? [
- 2drop 1.0/0.0
+ 2drop 1/0.
] [
pre-scale
/f-loop over odd?
- [ zero? [ 1+ ] unless ] [ drop ] if
+ [ zero? [ 1 + ] unless ] [ drop ] if
post-scale
] if
] if ; inline
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index f79dcb5481..c28bf062c1 100644
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -355,8 +355,9 @@ ARTICLE: "bitwise-arithmetic" "Bitwise arithmetic"
{ $subsection 2/ }
{ $subsection 2^ }
{ $subsection bit? }
-"The " { $vocab-link "math.bitwise" } " vocabulary implements additional bitwise integer operations."
-{ $see-also "conditionals" } ;
+{ $subsection "math.bitwise" }
+{ $subsection "math.bits" }
+{ $see-also "booleans" } ;
ARTICLE: "arithmetic" "Arithmetic"
"Factor attempts to preserve natural mathematical semantics for numbers. Multiplying two large integers never results in overflow, and dividing two integers yields an exact ratio. Floating point numbers are also supported, along with complex numbers."
diff --git a/core/math/math.factor b/core/math/math.factor
index 42786ffc9d..8e0000326f 100755
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private ;
IN: math
@@ -63,23 +63,22 @@ PRIVATE>
: neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
-
-: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline
-
+: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline
: rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
-
: 2^ ( n -- 2^n ) 1 swap shift ; inline
-
: even? ( n -- ? ) 1 bitand zero? ;
-
: odd? ( n -- ? ) 1 bitand 1 number= ;
UNION: integer fixnum bignum ;
+TUPLE: ratio { numerator integer read-only } { denominator integer read-only } ;
+
UNION: rational integer ratio ;
UNION: real rational float ;
+TUPLE: complex { real real read-only } { imaginary real read-only } ;
+
UNION: number real complex ;
GENERIC: fp-nan? ( x -- ? )
@@ -104,13 +103,13 @@ M: float fp-infinity? ( float -- ? )
] if ;
: next-power-of-2 ( m -- n )
- dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline
+ dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
: power-of-2? ( n -- ? )
- dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
+ dup 0 <= [ drop f ] [ dup 1 - bitand zero? ] if ; foldable
: align ( m w -- n )
- 1- [ + ] keep bitnot bitand ; inline
+ 1 - [ + ] keep bitnot bitand ; inline
<PRIVATE
@@ -122,7 +121,7 @@ M: float fp-infinity? ( float -- ? )
#! Apply quot to i, keep i and quot, hide n.
[ nip call ] 3keep ; inline
-: iterate-next ( i n quot -- i' n quot ) [ 1+ ] 2dip ; inline
+: iterate-next ( i n quot -- i' n quot ) [ 1 + ] 2dip ; inline
PRIVATE>
@@ -161,6 +160,6 @@ PRIVATE>
[ call ] 2keep rot [
drop
] [
- [ 1- ] dip find-last-integer
+ [ 1 - ] dip find-last-integer
] if
] if ; inline recursive
diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor
index 1bdd1009e9..8b2200aa67 100644
--- a/core/math/order/order-docs.factor
+++ b/core/math/order/order-docs.factor
@@ -87,7 +87,14 @@ ARTICLE: "order-specifiers" "Ordering specifiers"
{ $subsection +lt+ }
{ $subsection +eq+ }
{ $subsection +gt+ } ;
-
+
+ARTICLE: "math.order.example" "Linear order example"
+"A tuple class which defines an ordering among instances by comparing the values of the " { $snippet "id" } " slot:"
+{ $code
+ "TUPLE: sprite id name bitmap ;"
+ "M: sprite <=> [ id>> ] compare ;"
+} ;
+
ARTICLE: "math.order" "Linear order protocol"
"Some classes have an intrinsic order amongst instances:"
{ $subsection <=> }
@@ -101,6 +108,8 @@ ARTICLE: "math.order" "Linear order protocol"
{ $subsection before? }
{ $subsection after=? }
{ $subsection before=? }
+"Out of the above generic words, it suffices to implement " { $link <=> } " alone. The others may be provided as an optimization."
+{ $subsection "math.order.example" }
{ $see-also "sequences-sorting" } ;
ABOUT: "math.order"
diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor
index bcc75a842a..beb2312f2a 100644
--- a/core/math/parser/parser-docs.factor
+++ b/core/math/parser/parser-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax math math.private prettyprint
+USING: help.markup help.syntax math math.parser.private prettyprint
namespaces make strings ;
IN: math.parser
@@ -25,7 +25,7 @@ $nl
ABOUT: "number-strings"
HELP: digits>integer
-{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } }
+{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n/f" { $maybe integer } } }
{ $description "Converts a sequence of digits (with most significant digit first) into an integer." }
{ $notes "This is one of the factors of " { $link string>number } "." } ;
diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor
index 0fb2559854..c655965e35 100644
--- a/core/math/parser/parser-tests.factor
+++ b/core/math/parser/parser-tests.factor
@@ -95,17 +95,17 @@ unit-test
[ 1 0 >base ] must-fail
[ 1 -1 >base ] must-fail
-[ "0.0/0.0" ] [ 0.0 0.0 / number>string ] unit-test
+[ "0/0." ] [ 0.0 0.0 / number>string ] unit-test
-[ "1.0/0.0" ] [ 1.0 0.0 / number>string ] unit-test
+[ "1/0." ] [ 1.0 0.0 / number>string ] unit-test
-[ "-1.0/0.0" ] [ -1.0 0.0 / number>string ] unit-test
+[ "-1/0." ] [ -1.0 0.0 / number>string ] unit-test
[ t ] [ "0/0." string>number fp-nan? ] unit-test
-[ 1.0/0.0 ] [ "1/0." string>number ] unit-test
+[ 1/0. ] [ "1/0." string>number ] unit-test
-[ -1.0/0.0 ] [ "-1/0." string>number ] unit-test
+[ -1/0. ] [ "-1/0." string>number ] unit-test
[ "-0.0" ] [ -0.0 number>string ] unit-test
diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor
index 0d8f0c0b08..1736a00be4 100644
--- a/core/math/parser/parser.factor
+++ b/core/math/parser/parser.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.private namespaces sequences strings
-arrays combinators splitting math assocs make ;
+USING: kernel math.private namespaces sequences sequences.private
+strings arrays combinators splitting math assocs byte-arrays make ;
IN: math.parser
: digit> ( ch -- n )
@@ -28,13 +28,19 @@ IN: math.parser
{ CHAR: d 13 }
{ CHAR: e 14 }
{ CHAR: f 15 }
- } at ;
+ } at 255 or ; inline
: string>digits ( str -- digits )
- [ digit> ] { } map-as ;
+ [ digit> ] B{ } map-as ; inline
-: digits>integer ( seq radix -- n )
- 0 swap [ swapd * + ] curry reduce ;
+: (digits>integer) ( valid? accum digit radix -- valid? accum )
+ 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
+
+: each-digit ( seq radix quot -- n/f )
+ [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
+
+: digits>integer ( seq radix -- n/f )
+ [ (digits>integer) ] each-digit ; inline
DEFER: base>
@@ -43,6 +49,11 @@ DEFER: base>
SYMBOL: radix
SYMBOL: negative?
+: string>natural ( seq radix -- n/f )
+ over empty? [ 2drop f ] [
+ [ [ digit> ] dip (digits>integer) ] each-digit
+ ] if ; inline
+
: sign ( -- str ) negative? get "-" "+" ? ;
: with-radix ( radix quot -- )
@@ -54,37 +65,33 @@ SYMBOL: negative?
sign split1 [ (base>) ] dip
dup [ (base>) ] [ drop 0 swap ] if ;
-: string>ratio ( str -- a/b )
- "-" ?head dup negative? set swap
- "/" split1 (base>) [ whole-part ] dip
- 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if ;
+: string>ratio ( str radix -- a/b )
+ [
+ "-" ?head dup negative? set swap
+ "/" split1 (base>) [ whole-part ] dip
+ 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
+ ] with-radix ;
-: valid-digits? ( seq -- ? )
- {
- { [ dup empty? ] [ drop f ] }
- { [ f over memq? ] [ drop f ] }
- [ radix get [ < ] curry all? ]
- } cond ;
+: string>integer ( str radix -- n/f )
+ over first-unsafe CHAR: - = [
+ [ rest-slice ] dip string>natural dup [ neg ] when
+ ] [
+ string>natural
+ ] if ; inline
-: string>integer ( str -- n/f )
- "-" ?head swap
- string>digits dup valid-digits?
- [ radix get digits>integer swap [ neg ] when ] [ 2drop f ] if ;
+: string>float ( str -- n/f )
+ >byte-array 0 suffix (string>float) ;
PRIVATE>
: base> ( str radix -- n/f )
- [
- CHAR: / over member? [
- string>ratio
- ] [
- CHAR: . over member? [
- string>float
- ] [
- string>integer
- ] if
- ] if
- ] with-radix ;
+ over empty? [ 2drop f ] [
+ over [ "/." member? ] find nip {
+ { CHAR: / [ string>ratio ] }
+ { CHAR: . [ drop string>float ] }
+ [ drop string>integer ]
+ } case
+ ] if ;
: string>number ( str -- n/f ) 10 base> ;
: bin> ( str -- n/f ) 2 base> ;
@@ -145,13 +152,18 @@ M: ratio >base
[ ".0" append ]
} cond ;
+: float>string ( x -- str )
+ (float>string)
+ [ 0 = ] trim-tail >string
+ fix-float ;
+
M: float >base
drop {
- { [ dup fp-nan? ] [ drop "0.0/0.0" ] }
- { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] }
- { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] }
+ { [ dup fp-nan? ] [ drop "0/0." ] }
+ { [ dup 1/0. = ] [ drop "1/0." ] }
+ { [ dup -1/0. = ] [ drop "-1/0." ] }
{ [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
- [ float>string fix-float ]
+ [ float>string ]
} cond ;
: number>string ( n -- str ) 10 >base ;
diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor
index 995c7e6064..a6ecdc005e 100644
--- a/core/memory/memory-tests.factor
+++ b/core/memory/memory-tests.factor
@@ -3,6 +3,8 @@ sequences tools.test words namespaces layouts classes
classes.builtin arrays quotations io.launcher system ;
IN: memory.tests
+[ ] [ { } { } become ] unit-test
+
! LOL
[ ] [
vm
@@ -15,7 +17,7 @@ IN: memory.tests
[ [ ] instances ] must-infer
! Code GC wasn't kicking in when needed
-: leak-step ( -- ) 800000 f <array> 1quotation call drop ;
+: leak-step ( -- ) 800000 f <array> 1quotation call( -- obj ) drop ;
: leak-loop ( -- ) 100 [ leak-step ] times ;
diff --git a/core/memory/memory.factor b/core/memory/memory.factor
index 4b873ef6ec..c748f71c8e 100644
--- a/core/memory/memory.factor
+++ b/core/memory/memory.factor
@@ -1,6 +1,7 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel continuations sequences vectors arrays system math ;
+USING: kernel continuations sequences vectors arrays system math
+io.backend alien.strings memory.private ;
IN: memory
: (each-object) ( quot: ( obj -- ) -- )
@@ -21,4 +22,10 @@ IN: memory
[ count-instances 100 + <vector> ] keep swap
[ [ push-if ] 2curry each-object ] keep >array ; inline
+: save-image ( path -- )
+ normalize-path native-string>alien (save-image) ;
+
+: save-image-and-exit ( path -- )
+ normalize-path native-string>alien (save-image) ;
+
: save ( -- ) image save-image ;
diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor
old mode 100644
new mode 100755
index ff0542a7b8..cd66e781d2
--- a/core/namespaces/namespaces-docs.factor
+++ b/core/namespaces/namespaces-docs.factor
@@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private
sequences words namespaces.private quotations vectors
-math.parser math words.symbol ;
+math.parser math words.symbol assocs ;
IN: namespaces
ARTICLE: "namespaces-combinators" "Namespace combinators"
@@ -14,7 +14,8 @@ ARTICLE: "namespaces-change" "Changing variable values"
{ $subsection off }
{ $subsection inc }
{ $subsection dec }
-{ $subsection change } ;
+{ $subsection change }
+{ $subsection change-global } ;
ARTICLE: "namespaces-global" "Global variables"
{ $subsection namespace }
@@ -32,7 +33,7 @@ ARTICLE: "namespaces.private" "Namespace implementation details"
{ $subsection >n }
{ $subsection ndrop } ;
-ARTICLE: "namespaces" "Variables and namespaces"
+ARTICLE: "namespaces" "Dynamic variables and namespaces"
"The " { $vocab-link "namespaces" } " vocabulary implements simple dynamically-scoped variables."
$nl
"A variable is an entry in an assoc of bindings, where the assoc is implicit rather than passed on the stack. These assocs are termed " { $emphasis "namespaces" } ". Nesting of scopes is implemented with a search order on namespaces, defined by a " { $emphasis "namestack" } ". Since namespaces are just assoc, any object can be used as a variable, however by convention, variables are keyed by symbols (see " { $link "words.symbol" } ")."
@@ -43,7 +44,6 @@ $nl
"Various utility words abstract away common variable access patterns:"
{ $subsection "namespaces-change" }
{ $subsection "namespaces-combinators" }
-{ $subsection "namespaces-global" }
"Implementation details your code probably does not care about:"
{ $subsection "namespaces.private" }
"An alternative to dynamic scope is lexical scope. Lexically-scoped values and closures are implemented in the " { $vocab-link "locals" } " vocabulary." ;
@@ -74,6 +74,11 @@ HELP: change
{ $description "Applies the quotation to the old value of the variable, and assigns the resulting value to the variable." }
{ $side-effects "variable" } ;
+HELP: change-global
+{ $values { "variable" "a variable, by convention a symbol" } { "quot" { $quotation "( old -- new )" } } }
+{ $description "Applies the quotation to the old value of the global variable, and assigns the resulting value to the global variable." }
+{ $side-effects "variable" } ;
+
HELP: +@
{ $values { "n" "a number" } { "variable" "a variable, by convention a symbol" } }
{ $description "Adds " { $snippet "n" } " to the value of the variable. A variable value of " { $link f } " is interpreted as being zero." }
@@ -114,19 +119,19 @@ HELP: with-variable
} ;
HELP: make-assoc
-{ $values { "quot" quotation } { "exemplar" "an assoc" } { "hash" "a new hashtable" } }
+{ $values { "quot" quotation } { "exemplar" assoc } { "hash" "a new assoc" } }
{ $description "Calls the quotation in a new namespace of the same type as " { $snippet "exemplar" } ", and outputs this namespace when the quotation returns. Useful for quickly building assocs." } ;
HELP: bind
-{ $values { "ns" "a hashtable" } { "quot" quotation } }
+{ $values { "ns" assoc } { "quot" quotation } }
{ $description "Calls the quotation in the dynamic scope of " { $snippet "ns" } ". When variables are looked up by the quotation, " { $snippet "ns" } " is checked first, and setting variables in the quotation stores them in " { $snippet "ns" } "." } ;
HELP: namespace
-{ $values { "namespace" "an assoc" } }
+{ $values { "namespace" assoc } }
{ $description "Outputs the current namespace. Calls to " { $link set } " modify this namespace." } ;
HELP: global
-{ $values { "g" "an assoc" } }
+{ $values { "g" assoc } }
{ $description "Outputs the global namespace. The global namespace is always checked last when looking up variable values." } ;
HELP: get-global
@@ -151,7 +156,7 @@ HELP: set-namestack
{ $description "Replaces the name stack with a copy of the given vector." } ;
HELP: >n
-{ $values { "namespace" "an assoc" } }
+{ $values { "namespace" assoc } }
{ $description "Pushes a namespace on the name stack." } ;
HELP: ndrop
diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor
index b0e764c94d..64cc328d19 100644
--- a/core/namespaces/namespaces.factor
+++ b/core/namespaces/namespaces.factor
@@ -24,12 +24,13 @@ PRIVATE>
: get-global ( variable -- value ) global at ;
: set-global ( value variable -- ) global set-at ;
: change ( variable quot -- ) [ [ get ] keep ] dip dip set ; inline
+: change-global ( variable quot -- ) [ global ] dip change-at ; inline
: +@ ( n variable -- ) [ 0 or + ] change ;
: inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline
: bind ( ns quot -- ) swap >n call ndrop ; inline
-: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
+: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ;
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
-: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline
\ No newline at end of file
+: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor
index 547f7c0490..98f41ae39a 100644
--- a/core/parser/parser-docs.factor
+++ b/core/parser/parser-docs.factor
@@ -92,15 +92,12 @@ ARTICLE: "parser" "The parser"
"This parser is a general facility for reading textual representations of objects and definitions. The parser is implemented in the " { $vocab-link "parser" } " and " { $vocab-link "syntax" } " vocabularies."
$nl
"This section concerns itself with usage and extension of the parser. Standard syntax is described in " { $link "syntax" } "."
-{ $subsection "vocabulary-search" }
{ $subsection "parser-files" }
-{ $subsection "top-level-forms" }
"The parser can be extended."
-{ $subsection "parsing-words" }
{ $subsection "parser-lexer" }
"The parser can be invoked reflectively;"
{ $subsection parse-stream }
-{ $see-also "definitions" "definition-checking" } ;
+{ $see-also "parsing-words" "definitions" "definition-checking" } ;
ABOUT: "parser"
@@ -113,7 +110,7 @@ HELP: save-location
{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
HELP: parser-notes
-{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
+{ $var-description "A boolean controlling whether the parser will print various notes. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
HELP: parser-notes?
{ $values { "?" "a boolean" } }
@@ -263,7 +260,7 @@ HELP: forget-smudged
HELP: finish-parsing
{ $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } }
-{ $description "Records information to the current " { $link file } " and prints warnings about any removed definitions which are still in use." }
+{ $description "Records information to the current " { $link file } "." }
{ $notes "This is one of the factors of " { $link parse-stream } "." } ;
HELP: parse-stream
diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor
index 3ba414fe6b..e944ecc6f2 100644
--- a/core/parser/parser-tests.factor
+++ b/core/parser/parser-tests.factor
@@ -3,50 +3,49 @@ io.streams.string namespaces classes effects source-files assocs
sequences strings io.files io.pathnames definitions
continuations sorting classes.tuple compiler.units debugger
vocabs vocabs.loader accessors eval combinators lexer
-vocabs.parser words.symbol multiline ;
+vocabs.parser words.symbol multiline source-files.errors
+tools.crossref ;
IN: parser.tests
-\ run-file must-infer
-
[
[ 1 [ 2 [ 3 ] 4 ] 5 ]
- [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
+ [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ]
unit-test
[ t t f f ]
- [ "t t f f" eval ]
+ [ "t t f f" eval( -- ? ? ? ? ) ]
unit-test
[ "hello world" ]
- [ "\"hello world\"" eval ]
+ [ "\"hello world\"" eval( -- string ) ]
unit-test
[ "\n\r\t\\" ]
- [ "\"\\n\\r\\t\\\\\"" eval ]
+ [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ]
unit-test
[ "hello world" ]
[
"IN: parser.tests : hello ( -- str ) \"hello world\" ;"
- eval "USE: parser.tests hello" eval
+ eval( -- ) "USE: parser.tests hello" eval( -- string )
] unit-test
[ ]
- [ "! This is a comment, people." eval ]
+ [ "! This is a comment, people." eval( -- ) ]
unit-test
! Test escapes
[ " " ]
- [ "\"\\u000020\"" eval ]
+ [ "\"\\u000020\"" eval( -- string ) ]
unit-test
[ "'" ]
- [ "\"\\u000027\"" eval ]
+ [ "\"\\u000027\"" eval( -- string ) ]
unit-test
! Test EOL comments in multiline strings.
- [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test
+ [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test
[ word ] [ \ f class ] unit-test
@@ -68,7 +67,7 @@ IN: parser.tests
[ \ baz "declared-effect" word-prop terminated?>> ]
unit-test
- [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test
+ [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test
[ t ] [
"effect-parsing-test" "parser.tests" lookup
@@ -79,14 +78,14 @@ IN: parser.tests
[ \ effect-parsing-test "declared-effect" word-prop ] unit-test
! Funny bug
- [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test
+ [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test
- [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail
+ [ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail
! These should throw errors
- [ "HEX: zzz" eval ] must-fail
- [ "OCT: 999" eval ] must-fail
- [ "BIN: --0" eval ] must-fail
+ [ "HEX: zzz" eval( -- obj ) ] must-fail
+ [ "OCT: 999" eval( -- obj ) ] must-fail
+ [ "BIN: --0" eval( -- obj ) ] must-fail
! Another funny bug
[ t ] [
@@ -102,14 +101,14 @@ IN: parser.tests
] unit-test
DEFER: foo
- "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval
+ "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- )
- [ ] [ "USE: parser.tests foo" eval ] unit-test
+ [ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test
- "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval
+ "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- )
[ t ] [
- "USE: parser.tests \\ foo" eval
+ "USE: parser.tests \\ foo" eval( -- word )
"foo" "parser.tests" lookup eq?
] unit-test
@@ -269,12 +268,12 @@ IN: parser.tests
] unit-test
[ ] [
- "IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- ) <bogus-error> ;"
+ "IN: parser.tests : <bogus-error> ( -- ) ; : bogus ( -- error ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop
] unit-test
[ ] [
- "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- ) <bogus-error> ;"
+ "IN: parser.tests TUPLE: bogus-error ; C: <bogus-error> bogus-error : bogus ( -- error ) <bogus-error> ;"
<string-reader> "bogus-error" parse-stream drop
] unit-test
@@ -339,16 +338,16 @@ IN: parser.tests
] [ error>> error>> error>> redefine-error? ] must-fail-with
[ ] [
- "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
+ "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- )
] unit-test
[
- "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
+ "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- )
] must-fail
] with-file-vocabs
[ ] [
- "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval
+ "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval( -- )
] unit-test
[ t ] [
@@ -422,31 +421,31 @@ IN: parser.tests
] unit-test
[
- "USE: this-better-not-exist" eval
+ "USE: this-better-not-exist" eval( -- )
] must-fail
-[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
+[ ": foo ;" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with
-[ 92 ] [ "CHAR: \\" eval ] unit-test
-[ 92 ] [ "CHAR: \\\\" eval ] unit-test
+[ 92 ] [ "CHAR: \\" eval( -- n ) ] unit-test
+[ 92 ] [ "CHAR: \\\\" eval( -- n ) ] unit-test
[ ] [
{
"IN: parser.tests"
- "USING: math arrays ;"
- "GENERIC: change-combination ( a -- b )"
- "M: integer change-combination 1 ;"
- "M: array change-combination 2 ;"
+ "USING: math arrays kernel ;"
+ "GENERIC: change-combination ( obj a -- b )"
+ "M: integer change-combination 2drop 1 ;"
+ "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test
[ ] [
{
"IN: parser.tests"
- "USING: math arrays ;"
- "GENERIC# change-combination 1 ( a -- b )"
- "M: integer change-combination 1 ;"
- "M: array change-combination 2 ;"
+ "USING: math arrays kernel ;"
+ "GENERIC# change-combination 1 ( obj a -- b )"
+ "M: integer change-combination 2drop 1 ;"
+ "M: array change-combination 2drop 2 ;"
} "\n" join <string-reader> "change-combination-test" parse-stream drop
] unit-test
@@ -463,7 +462,7 @@ IN: parser.tests
] unit-test
[ [ ] ] [
- "IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
+ "IN: parser.tests : staging-problem-test-1 ( -- a ) 1 ; : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream
] unit-test
@@ -472,7 +471,7 @@ IN: parser.tests
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
[ [ ] ] [
- "IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;"
+ "IN: parser.tests << : staging-problem-test-1 ( -- a ) 1 ; >> : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;"
<string-reader> "staging-problem-test" parse-stream
] unit-test
@@ -480,10 +479,10 @@ IN: parser.tests
[ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test
-[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with
+[ "DEFER: blahy" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with
[
- "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval
+ "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval( -- )
] [
error>> staging-violation?
] must-fail-with
@@ -491,12 +490,12 @@ IN: parser.tests
! Bogus error message
DEFER: blahy
-[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ]
+[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval( -- ) ]
[ error>> error>> def>> \ blahy eq? ] must-fail-with
[ ] [ f lexer set f file set "Hello world" note. ] unit-test
-[ "CHAR: \\u9999999999999" eval ] must-fail
+[ "CHAR: \\u9999999999999" eval( -- n ) ] must-fail
SYMBOLS: a b c ;
@@ -506,15 +505,15 @@ SYMBOLS: a b c ;
DEFER: blah
-[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test
-[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test
+[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval( -- ) ] unit-test
+[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval( -- ) ] unit-test
[ f ] [ \ blah generic? ] unit-test
[ t ] [ \ blah symbol? ] unit-test
DEFER: blah1
-[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ]
+[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval( -- ) ]
[ error>> error>> def>> \ blah1 eq? ]
must-fail-with
@@ -545,10 +544,10 @@ EXCLUDE: qualified.tests.bar => x ;
[ 3 ] [ x ] unit-test
[ 4 ] [ y ] unit-test
-[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ]
+[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval( -- ) ]
[ error>> no-word-error? ] must-fail-with
-[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
+[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval( -- ) ]
[ error>> no-word-error? ] must-fail-with
! Two similar bugs
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 6d613a8b24..01e0b18887 100644
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -1,10 +1,11 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces
-sequences strings vectors words words.symbol quotations io combinators
-sorting splitting math.parser effects continuations io.files vocabs
-io.encodings.utf8 source-files classes hashtables compiler.errors
-compiler.units accessors sets lexer vocabs.parser effects.parser slots ;
+sequences strings vectors words words.symbol quotations io
+combinators sorting splitting math.parser effects continuations
+io.files vocabs io.encodings.utf8 source-files classes
+hashtables compiler.units accessors sets lexer vocabs.parser
+effects.parser slots ;
IN: parser
: location ( -- loc )
@@ -179,6 +180,7 @@ SYMBOL: interactive-vocabs
"math.order"
"memory"
"namespaces"
+ "parser"
"prettyprint"
"see"
"sequences"
@@ -190,14 +192,16 @@ SYMBOL: interactive-vocabs
"tools.annotations"
"tools.crossref"
"tools.disassembler"
+ "tools.errors"
"tools.memory"
"tools.profiler"
"tools.test"
"tools.threads"
"tools.time"
- "tools.vocabs"
"vocabs"
"vocabs.loader"
+ "vocabs.refresh"
+ "vocabs.hierarchy"
"words"
"scratchpad"
} interactive-vocabs set-global
@@ -261,7 +265,7 @@ print-use-hook [ [ ] ] initialize
: finish-parsing ( lines quot -- )
file get
- [ record-form ]
+ [ record-top-level-form ]
[ record-definitions ]
[ record-checksum ]
tri ;
@@ -269,7 +273,7 @@ print-use-hook [ [ ] ] initialize
: parse-stream ( stream name -- quot )
[
[
- lines dup parse-fresh
+ stream-lines dup parse-fresh
[ nip ] [ finish-parsing ] 2bi
forget-smudged
] with-source-file
@@ -280,11 +284,9 @@ print-use-hook [ [ ] ] initialize
: parse-file ( file -- quot )
[
- [
- [ parsing-file ] keep
- [ utf8 <file-reader> ] keep
- parse-stream
- ] with-compiler-errors
+ [ parsing-file ] keep
+ [ utf8 <file-reader> ] keep
+ parse-stream
] [
over parse-file-restarts rethrow-restarts
drop parse-file
diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor
index 2a03b7c74f..364f186d52 100644
--- a/core/quotations/quotations-docs.factor
+++ b/core/quotations/quotations-docs.factor
@@ -24,7 +24,14 @@ ARTICLE: "wrappers" "Wrappers"
"Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:"
{ $subsection wrapper }
{ $subsection literalize }
-{ $see-also "dataflow" "combinators" } ;
+"Wrapper literal syntax is documented in " { $link "syntax-words" } "."
+{ $example
+ "IN: scratchpad"
+ "DEFER: my-word"
+ "\\ my-word name>> ."
+ "\"my-word\""
+}
+{ $see-also "combinators" } ;
ABOUT: "quotations"
diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor
index 2c3b41ca4e..3245ac1e20 100644
--- a/core/quotations/quotations.factor
+++ b/core/quotations/quotations.factor
@@ -48,12 +48,12 @@ M: object literalize ;
M: wrapper literalize <wrapper> ;
-M: curry length quot>> length 1+ ;
+M: curry length quot>> length 1 + ;
M: curry nth
over 0 =
[ nip obj>> literalize ]
- [ [ 1- ] dip quot>> nth ]
+ [ [ 1 - ] dip quot>> nth ]
if ;
INSTANCE: curry immutable-sequence
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index c171555737..cfd96789b4 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -1,6 +1,6 @@
USING: arrays help.markup help.syntax math
sequences.private vectors strings kernel math.order layouts
-quotations generic.standard ;
+quotations generic.single ;
IN: sequences
HELP: sequence
@@ -311,7 +311,7 @@ HELP: each-index
HELP: map-index
{ $values
- { "seq" sequence } { "quot" quotation } }
+ { "seq" sequence } { "quot" quotation } { "newseq" sequence } }
{ $description "Calls the quotation with the element of the sequence and its index on the stack, with the index on the top of the stack. Collects the outputs of the quotation and outputs them in a sequence of the same type as the input sequence." }
{ $examples { $example "USING: sequences prettyprint math ;"
"{ 10 20 30 } [ + ] map-index ."
@@ -1354,14 +1354,16 @@ ARTICLE: "virtual-sequences" "Virtual sequences"
"Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "virtual-sequences-protocol" } "."
{ $subsection "virtual-sequences-protocol" } ;
-ARTICLE: "sequences-integers" "Integer sequences and counted loops"
+ARTICLE: "sequences-integers" "Counted loops"
"Integers support the sequence protocol in a trivial fashion; a non-negative integer presents its non-negative predecessors as elements. For example, the integer 3, when viewed as a sequence, contains the elements 0, 1, and 2. This is very useful for performing counted loops."
$nl
"For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:"
{ $example "3 [ . ] each" "0\n1\n2" }
"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "."
$nl
-"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ;
+"Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer."
+$nl
+"More elaborate counted loops can be performed with " { $link "math.ranges" } "." ;
ARTICLE: "sequences-access" "Accessing sequence elements"
{ $subsection ?nth }
@@ -1464,8 +1466,8 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
{ $subsection produce }
{ $subsection produce-as }
"Filtering:"
-{ $subsection push-if }
{ $subsection filter }
+{ $subsection partition }
"Testing if a sequence contains elements satisfying a predicate:"
{ $subsection any? }
{ $subsection all? }
@@ -1593,7 +1595,6 @@ $nl
"Sequences implement a protocol:"
{ $subsection "sequence-protocol" }
{ $subsection "sequences-f" }
-{ $subsection "sequences-integers" }
"Sequence utility words can operate on any object whose class implements the sequence protocol. Most implementations are backed by storage. Some implementations obtain their elements from an underlying sequence, or compute them on the fly. These are known as " { $link "virtual-sequences" } "."
{ $subsection "sequences-access" }
{ $subsection "sequences-combinators" }
@@ -1612,6 +1613,10 @@ $nl
{ $subsection "binary-search" }
{ $subsection "sets" }
{ $subsection "sequences-trimming" }
+{ $subsection "sequences.deep" }
+"Using sequences for looping:"
+{ $subsection "sequences-integers" }
+{ $subsection "math.ranges" }
"For inner loops:"
{ $subsection "sequences-unsafe" } ;
diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor
index da495f410f..85f9d56596 100644
--- a/core/sequences/sequences-tests.factor
+++ b/core/sequences/sequences-tests.factor
@@ -227,7 +227,7 @@ unit-test
[ -3 10 nth ] must-fail
[ 11 10 nth ] must-fail
-[ -1./0. 0 delete-nth ] must-fail
+[ -1/0. 0 delete-nth ] must-fail
[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
[ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index f352705e85..d60602fc71 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -198,7 +198,7 @@ C: <reversed> reversed
M: reversed virtual-seq seq>> ;
-M: reversed virtual@ seq>> [ length swap - 1- ] keep ;
+M: reversed virtual@ seq>> [ length swap - 1 - ] keep ;
M: reversed length seq>> length ;
@@ -276,7 +276,7 @@ INSTANCE: repetition immutable-sequence
] 3keep ; inline
: (copy) ( dst i src j n -- dst )
- dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ;
+ dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ;
inline recursive
: prepare-subseq ( from to seq -- dst i src j n )
@@ -460,7 +460,7 @@ PRIVATE>
[ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt )
- [ [ 1- ] dip find-last-integer ] (find) ; inline
+ [ [ 1 - ] dip find-last-integer ] (find) ; inline
: all? ( seq quot -- ? )
(each) all-integers? ; inline
@@ -506,7 +506,7 @@ PRIVATE>
[ [ 0 = ] 2dip if ] 2curry
each-index ; inline
-: map-index ( seq quot -- )
+: map-index ( seq quot -- newseq )
prepare-index 2map ; inline
: reduce-index ( seq identity quot -- )
@@ -556,7 +556,7 @@ PRIVATE>
[ empty? not ] filter ;
: mismatch ( seq1 seq2 -- i )
- [ min-length ] 2keep
+ [ min-length iota ] 2keep
[ 2nth-unsafe = not ] 2curry
find drop ; inline
@@ -568,6 +568,11 @@ M: sequence <=>
2dup [ length ] bi@ =
[ mismatch not ] [ 2drop f ] if ; inline
+ERROR: assert-sequence got expected ;
+
+: assert-sequence= ( a b -- )
+ 2dup sequence= [ 2drop ] [ assert-sequence ] if ;
+
: sequence-hashcode-step ( oldhash newpart -- newhash )
>fixnum swap [
[ -2 fixnum-shift-fast ] [ 5 fixnum-shift-fast ] bi
@@ -590,8 +595,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: (filter-here) ( quot: ( elt -- ? ) store scan seq -- )
2dup length < [
[ move ] 3keep
- [ nth-unsafe pick call [ 1+ ] when ] 2keep
- [ 1+ ] dip
+ [ nth-unsafe pick call [ 1 + ] when ] 2keep
+ [ 1 + ] dip
(filter-here)
] [ nip set-length drop ] if ; inline recursive
@@ -607,20 +612,20 @@ PRIVATE>
[ eq? not ] with filter-here ;
: prefix ( seq elt -- newseq )
- over [ over length 1+ ] dip [
+ over [ over length 1 + ] dip [
[ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep
] new-like ;
: suffix ( seq elt -- newseq )
- over [ over length 1+ ] dip [
+ over [ over length 1 + ] dip [
[ [ over length ] dip set-nth-unsafe ] keep
[ 0 swap copy ] keep
] new-like ;
-: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
+: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
-: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
+: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
<PRIVATE
@@ -628,7 +633,7 @@ PRIVATE>
2over = [
2drop 2drop
] [
- [ [ 2over + pick ] dip move [ 1+ ] dip ] keep
+ [ [ 2over + pick ] dip move [ 1 + ] dip ] keep
move-backward
] if ;
@@ -636,13 +641,13 @@ PRIVATE>
2over = [
2drop 2drop
] [
- [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep
+ [ [ pick [ dup dup ] dip + swap ] dip move 1 - ] keep
move-forward
] if ;
: (open-slice) ( shift from to seq ? -- )
[
- [ [ 1- ] bi@ ] dip move-forward
+ [ [ 1 - ] bi@ ] dip move-forward
] [
[ over - ] 2dip move-backward
] if ;
@@ -662,7 +667,7 @@ PRIVATE>
check-slice [ over [ - ] dip ] dip open-slice ;
: delete-nth ( n seq -- )
- [ dup 1+ ] dip delete-slice ;
+ [ dup 1 + ] dip delete-slice ;
: snip ( from to seq -- head tail )
[ swap head ] [ swap tail ] bi-curry bi* ; inline
@@ -674,10 +679,10 @@ PRIVATE>
snip-slice surround ;
: remove-nth ( n seq -- seq' )
- [ [ { } ] dip dup 1+ ] dip replace-slice ;
+ [ [ { } ] dip dup 1 + ] dip replace-slice ;
: pop ( seq -- elt )
- [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
+ [ length 1 - ] [ [ nth ] [ shorten ] 2bi ] bi ;
: exchange ( m n seq -- )
[ nip bounds-check 2drop ]
@@ -687,7 +692,7 @@ PRIVATE>
: reverse-here ( seq -- )
[ length 2/ ] [ length ] [ ] tri
- [ [ over - 1- ] dip exchange-unsafe ] 2curry each ;
+ [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
: reverse ( seq -- newseq )
[
@@ -794,7 +799,7 @@ PRIVATE>
PRIVATE>
: start* ( subseq seq n -- i )
- pick length pick length swap - 1+
+ pick length pick length swap - 1 +
[ (start) ] find-from
swap [ 3drop ] dip ;
diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor
index a122aa1240..3670b10d3c 100755
--- a/core/sets/sets-docs.factor
+++ b/core/sets/sets-docs.factor
@@ -1,4 +1,4 @@
-USING: kernel help.markup help.syntax sequences quotations ;
+USING: kernel help.markup help.syntax sequences quotations assocs ;
IN: sets
ARTICLE: "sets" "Set-theoretic operations on sequences"
@@ -42,7 +42,7 @@ HELP: adjoin
{ $side-effects "seq" } ;
HELP: conjoin
-{ $values { "elt" object } { "assoc" "an assoc" } }
+{ $values { "elt" object } { "assoc" assoc } }
{ $description "Stores a key/value pair, both equal to " { $snippet "elt" } ", into the assoc." }
{ $examples
{ $example
@@ -54,7 +54,7 @@ HELP: conjoin
{ $side-effects "assoc" } ;
HELP: unique
-{ $values { "seq" "a sequence" } { "assoc" "an assoc" } }
+{ $values { "seq" "a sequence" } { "assoc" assoc } }
{ $description "Outputs a new assoc where the keys and values are equal." }
{ $examples
{ $example "USING: sets prettyprint ;" "{ 1 1 2 2 3 3 } unique ." "H{ { 1 1 } { 2 2 } { 3 3 } }" }
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index 840fe628e0..1e5f9bf1dd 100644
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -83,7 +83,7 @@ $nl
"A word can be used to check if a class has an initial value or not:"
{ $subsection initial-value } ;
-ARTICLE: "slots" "Slots"
+ARTICLE: "slots" "Low-level slot operations"
"The " { $vocab-link "slots" } " vocabulary contains words for introspecting the slots of an object. A " { $emphasis "slot" } " is a component of an object which can store a value."
$nl
{ $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data."
@@ -104,6 +104,9 @@ $nl
{ $subsection define-changer }
{ $subsection define-slot-methods }
{ $subsection define-accessors }
+"Unsafe slot access:"
+{ $subsection slot }
+{ $subsection set-slot }
{ $see-also "accessors" "mirrors" } ;
ABOUT: "slots"
diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor
index 767cec4830..1365e81524 100644
--- a/core/slots/slots-tests.factor
+++ b/core/slots/slots-tests.factor
@@ -1,5 +1,5 @@
IN: slots.tests
-USING: math accessors slots strings generic.standard kernel
+USING: math accessors slots strings generic.single kernel
tools.test generic words parser eval math.functions ;
TUPLE: r/w-test foo ;
@@ -25,12 +25,12 @@ TUPLE: hello length ;
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
! See if declarations are cleared on redefinition
-[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test
+[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test
[ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
-[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test
+[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test
[ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test
[ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index a353f50947..6bb854daf6 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -122,7 +122,7 @@ ERROR: bad-slot-value value class ;
[
\ over ,
over reader-word 1quotation
- [ dip call ] curry [ dip swap ] curry %
+ [ dip call ] curry [ ] like [ dip swap ] curry %
swap setter-word ,
] [ ] make (( object quot -- object )) define-inline
] [ 2drop ] if ;
@@ -222,7 +222,7 @@ M: slot-spec make-slot
[ make-slot ] map ;
: finalize-slots ( specs base -- specs )
- over length [ + ] with map [ >>offset ] 2map ;
+ over length iota [ + ] with map [ >>offset ] 2map ;
: slot-named ( name specs -- spec/f )
[ name>> = ] with find nip ;
diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor
index 30ecb70ed9..f2fa6b8771 100644
--- a/core/sorting/sorting.factor
+++ b/core/sorting/sorting.factor
@@ -29,13 +29,13 @@ TUPLE: merge
[ [ [ 2drop ] dip nth-unsafe ] dip push ] [
pick 2 = [
[
- [ 2drop dup 1+ ] dip
+ [ 2drop dup 1 + ] dip
[ nth-unsafe ] curry bi@
] dip [ push ] curry bi@
] [
pick 3 = [
[
- [ 2drop dup 1+ dup 1+ ] dip
+ [ 2drop dup 1 + dup 1 + ] dip
[ nth-unsafe ] curry tri@
] dip [ push ] curry tri@
] [ [ nip subseq ] dip push-all ] if
@@ -57,10 +57,10 @@ TUPLE: merge
[ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
: l-next ( merge -- )
- [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
+ [ [ l-elt ] [ [ 1 + ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
: r-next ( merge -- )
- [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
+ [ [ r-elt ] [ [ 1 + ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
: decide ( merge -- ? )
[ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
@@ -129,8 +129,8 @@ TUPLE: merge
while 2drop ; inline
: each-pair ( seq quot -- )
- [ [ length 1+ 2/ ] keep ] dip
- [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
+ [ [ length 1 + 2/ ] keep ] dip
+ [ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline
: (sort-pairs) ( i1 i2 seq quot accum -- )
[ 2dup length = ] 2dip rot [
diff --git a/core/source-files/errors/authors.txt b/core/source-files/errors/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/core/source-files/errors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/core/source-files/errors/errors-tests.factor b/core/source-files/errors/errors-tests.factor
new file mode 100644
index 0000000000..f13790f5bb
--- /dev/null
+++ b/core/source-files/errors/errors-tests.factor
@@ -0,0 +1,10 @@
+USING: assocs compiler.errors compiler.units definitions
+namespaces source-files.errors tools.test words ;
+IN: source-files.errors.tests
+
+DEFER: forget-test
+
+[ ] [ [ \ forget-test [ 1 ] (( -- )) define-declared ] with-compilation-unit ] unit-test
+[ t ] [ \ forget-test compiler-errors get key? ] unit-test
+[ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test
+[ f ] [ \ forget-test compiler-errors get key? ] unit-test
\ No newline at end of file
diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor
new file mode 100644
index 0000000000..f6f4f4825a
--- /dev/null
+++ b/core/source-files/errors/errors.factor
@@ -0,0 +1,77 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel math.order sorting sequences definitions
+namespaces arrays splitting io math.parser math init ;
+IN: source-files.errors
+
+TUPLE: source-file-error error asset file line# ;
+
+: sort-errors ( errors -- alist )
+ [ [ [ line#>> ] compare ] sort ] { } assoc-map-as sort-keys ;
+
+: group-by-source-file ( errors -- assoc )
+ H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ;
+
+TUPLE: error-type type word plural icon quot forget-quot { fatal? initial: t } ;
+
+GENERIC: error-type ( error -- type )
+
+: <definition-error> ( error definition class -- source-file-error )
+ new
+ swap
+ [ >>asset ]
+ [ where [ first2 [ >>file ] [ >>line# ] bi* ] when* ] bi
+ swap >>error ; inline
+
+SYMBOL: error-types
+
+error-types [ V{ } clone ] initialize
+
+: define-error-type ( error-type -- )
+ dup type>> error-types get set-at ;
+
+: error-icon-path ( type -- icon )
+ error-types get at icon>> ;
+
+: error-counts ( -- alist )
+ error-types get
+ [ nip dup quot>> call( -- seq ) length ] assoc-map
+ [ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ;
+
+: error-summary ( -- )
+ error-counts [
+ over
+ [ word>> write ]
+ [ " - show " write number>string write bl ]
+ [ plural>> print ] tri*
+ ] assoc-each ;
+
+: all-errors ( -- errors )
+ error-types get values
+ [ quot>> call( -- seq ) ] map
+ concat ;
+
+GENERIC: errors-changed ( observer -- )
+
+SYMBOL: error-observers
+
+[ V{ } clone error-observers set-global ] "source-files.errors" add-init-hook
+
+: add-error-observer ( observer -- ) error-observers get push ;
+
+: remove-error-observer ( observer -- ) error-observers get delq ;
+
+: notify-error-observers ( -- ) error-observers get [ errors-changed ] each ;
+
+: delete-file-errors ( seq file type -- )
+ [
+ [ swap file>> = ] [ swap error-type = ]
+ bi-curry* bi and not
+ ] 2curry filter-here
+ notify-error-observers ;
+
+: delete-definition-errors ( definition -- )
+ error-types get [
+ second forget-quot>> dup
+ [ call( definition -- ) ] [ 2drop ] if
+ ] with each ;
\ No newline at end of file
diff --git a/core/source-files/source-files-docs.factor b/core/source-files/source-files-docs.factor
index 2c9e2172cc..91c039dbae 100644
--- a/core/source-files/source-files-docs.factor
+++ b/core/source-files/source-files-docs.factor
@@ -3,7 +3,7 @@ definitions quotations compiler.units ;
IN: source-files
ARTICLE: "source-files" "Source files"
-"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "tools.vocabs" } "."
+"Words in the " { $vocab-link "source-files" } " vocabulary are used to keep track of loaded source files. This is used to implement " { $link "vocabs.refresh" } "."
$nl
"The source file database:"
{ $subsection source-files }
@@ -11,9 +11,7 @@ $nl
{ $subsection source-file }
"Words intended for the parser:"
{ $subsection record-checksum }
-{ $subsection record-form }
-{ $subsection xref-source }
-{ $subsection unxref-source }
+{ $subsection record-definitions }
"Removing a source file from the database:"
{ $subsection forget-source }
"Updating the database:"
@@ -42,27 +40,8 @@ HELP: record-checksum
{ $description "Records the CRC32 checksm of the source file's contents." }
$low-level-note ;
-HELP: xref-source
-{ $values { "source-file" source-file } }
-{ $description "Adds the source file to the " { $link crossref } " graph enabling words to find source files which reference them in their top level forms." }
-$low-level-note ;
-
-HELP: unxref-source
-{ $values { "source-file" source-file } }
-{ $description "Removes the source file from the " { $link crossref } " graph." }
-$low-level-note ;
-
-HELP: xref-sources
-{ $description "Adds all loaded source files to the " { $link crossref } " graph. This is done during bootstrap." }
-$low-level-note ;
-
-HELP: record-form
-{ $values { "quot" quotation } { "source-file" source-file } }
-{ $description "Records usage information for a source file's top level form." }
-$low-level-note ;
-
HELP: reset-checksums
-{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "tools.vocabs" } "." } ;
+{ $description "Resets recorded modification times and CRC32 checksums for all loaded source files, creating a checkpoint for " { $link "vocabs.refresh" } "." } ;
HELP: forget-source
{ $values { "path" "a pathname string" } }
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index c8441ba3b0..558018a147 100644
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -1,39 +1,26 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays definitions generic assocs kernel math namespaces
sequences strings vectors words quotations io io.files
io.pathnames combinators sorting splitting math.parser effects
continuations checksums checksums.crc32 vocabs hashtables graphs
-compiler.units io.encodings.utf8 accessors ;
+compiler.units io.encodings.utf8 accessors source-files.errors ;
IN: source-files
SYMBOL: source-files
TUPLE: source-file
path
+top-level-form
checksum
-uses definitions ;
+definitions ;
+
+: record-top-level-form ( quot file -- )
+ (>>top-level-form) H{ } notify-definition-observers ;
: record-checksum ( lines source-file -- )
[ crc32 checksum-lines ] dip (>>checksum) ;
-: (xref-source) ( source-file -- pathname uses )
- [ path>> <pathname> ]
- [ uses>> [ crossref? ] filter ] bi ;
-
-: xref-source ( source-file -- )
- (xref-source) crossref get add-vertex ;
-
-: unxref-source ( source-file -- )
- (xref-source) crossref get remove-vertex ;
-
-: xref-sources ( -- )
- source-files get [ nip xref-source ] assoc-each ;
-
-: record-form ( quot source-file -- )
- [ quot-uses keys ] dip
- [ unxref-source ] [ (>>uses) ] [ xref-source ] tri ;
-
: record-definitions ( file -- )
new-definitions get >>definitions drop ;
@@ -58,14 +45,8 @@ ERROR: invalid-source-file-path path ;
M: pathname where string>> 1 2array ;
: forget-source ( path -- )
- [
- source-file
- [ unxref-source ]
- [ definitions>> [ keys forget-all ] each ]
- bi
- ]
- [ source-files get delete-at ]
- bi ;
+ source-files get delete-at*
+ [ definitions>> [ keys forget-all ] each ] [ drop ] if ;
M: pathname forget*
string>> forget-source ;
@@ -77,21 +58,20 @@ M: pathname forget*
SYMBOL: file
-TUPLE: source-file-error error file ;
-
-: <source-file-error> ( msg -- error )
+: wrap-source-file-error ( error -- * )
+ file get rollback-source-file
\ source-file-error new
- file get >>file
- swap >>error ;
+ f >>line#
+ file get path>> >>file
+ swap >>error rethrow ;
: with-source-file ( name quot -- )
#! Should be called from inside with-compilation-unit.
[
- swap source-file
- dup file set
- definitions>> old-definitions set
[
- file get rollback-source-file
- <source-file-error> rethrow
- ] recover
+ source-file
+ [ file set ]
+ [ definitions>> old-definitions set ] bi
+ ] dip
+ [ wrap-source-file-error ] recover
] with-scope ; inline
diff --git a/core/splitting/splitting.factor b/core/splitting/splitting.factor
index 6d833c792e..c55a75baa6 100644
--- a/core/splitting/splitting.factor
+++ b/core/splitting/splitting.factor
@@ -55,7 +55,7 @@ PRIVATE>
: (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop
- [ [ swap subseq , ] 2keep 1+ swap (split) ]
+ [ [ swap subseq , ] 2keep 1 + swap (split) ]
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ;
diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor
index 5b71b13552..22bf7bb821 100644
--- a/core/strings/strings-tests.factor
+++ b/core/strings/strings-tests.factor
@@ -58,7 +58,7 @@ unit-test
[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test
! Random tester found this
-[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with
+[ 2 -7 resize-string ] [ { "kernel-error" 3 11 -7 } = ] must-fail-with
! Make sure 24-bit strings work
"hello world" "s" set
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index df9eb568f6..fff355fb95 100644
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -1,7 +1,7 @@
USING: generic help.syntax help.markup kernel math parser words
effects classes generic.standard classes.tuple generic.math
-generic.standard arrays io.pathnames vocabs.loader io sequences
-assocs words.symbol words.alias words.constant ;
+generic.standard generic.single arrays io.pathnames vocabs.loader io
+sequences assocs words.symbol words.alias words.constant combinators ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
@@ -66,6 +66,12 @@ ARTICLE: "syntax-floats" "Float syntax"
"7.e13"
"1.0e-5"
}
+"There are three special float values:"
+{ $table
+{ "Positive infinity" { $snippet "1/0." } }
+{ "Negative infinity" { $snippet "-1/0." } }
+{ "Not-a-number" { $snippet "0/0." } }
+}
"More information on floats can be found in " { $link "floats" } "." ;
ARTICLE: "syntax-complex-numbers" "Complex number syntax"
@@ -146,6 +152,11 @@ ARTICLE: "syntax-pathnames" "Pathname syntax"
{ $subsection POSTPONE: P" }
"Pathnames are documented in " { $link "io.pathnames" } "." ;
+ARTICLE: "syntax-effects" "Stack effect syntax"
+"Note that this is " { $emphasis "not" } " syntax to declare stack effects of words. This pushes an " { $link effect } " instance on the stack for reflection, for use with words such as " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "."
+{ $subsection POSTPONE: (( }
+{ $see-also "effects" "inference" "tools.inference" } ;
+
ARTICLE: "syntax-literals" "Literals"
"Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words."
$nl
@@ -162,11 +173,14 @@ $nl
{ $subsection "syntax-sbufs" }
{ $subsection "syntax-hashtables" }
{ $subsection "syntax-tuples" }
-{ $subsection "syntax-pathnames" } ;
+{ $subsection "syntax-pathnames" }
+{ $subsection "syntax-effects" } ;
ARTICLE: "syntax" "Syntax"
"Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "."
{ $subsection "parser-algorithm" }
+{ $subsection "vocabulary-search" }
+{ $subsection "top-level-forms" }
{ $subsection "syntax-comments" }
{ $subsection "syntax-literals" }
{ $subsection "syntax-immediate" } ;
@@ -509,7 +523,7 @@ HELP: (
{ $syntax "( inputs -- outputs )" }
{ $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } }
{ $description "A stack effect declaration. This is treated as a comment unless it appears inside a word definition." }
-{ $see-also "effect-declaration" } ;
+{ $see-also "effects" } ;
HELP: ((
{ $syntax "(( inputs -- outputs ))" }
@@ -517,11 +531,19 @@ HELP: ((
{ $description "Literal stack effect syntax." }
{ $notes "Useful for meta-programming with " { $link define-declared } "." }
{ $examples
- { $code
+ { $example
+ "USING: compiler.units kernel math prettyprint random words ;"
+ "IN: scratchpad"
+ ""
"SYMBOL: my-dynamic-word"
- "USING: math random words ;"
- "3 { [ + ] [ - ] [ * ] [ / ] } random curry"
- "(( x -- y )) define-declared"
+ ""
+ "["
+ " my-dynamic-word 2 { [ + ] [ * ] } random curry"
+ " (( x -- y )) define-declared"
+ "] with-compilation-unit"
+ ""
+ "2 my-dynamic-word ."
+ "4"
}
} ;
@@ -727,7 +749,7 @@ HELP: <PRIVATE
"<PRIVATE"
""
": (fac) ( accum n -- n! )"
- " dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
+ " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
""
"PRIVATE>"
""
@@ -738,7 +760,7 @@ HELP: <PRIVATE
"IN: factorial.private"
""
": (fac) ( accum n -- n! )"
- " dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
+ " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
""
"IN: factorial"
""
@@ -762,7 +784,9 @@ HELP: >>
{ $description "Marks the end of a parse time code block." } ;
HELP: call-next-method
+{ $syntax "call-next-method" }
{ $description "Calls the next applicable method. Only valid inside a method definition. The values at the top of the stack are passed on to the next method, and they must be compatible with that method's class specializer." }
+{ $notes "This word looks like an ordinary word but it is a parsing word. It cannot be factored out of a method definition, since the code expansion references the current method object directly." }
{ $errors
"Throws a " { $link no-next-method } " error if this is the least specific method, and throws an " { $link inconsistent-next-method } " error if the values at the top of the stack are not compatible with the current method's specializer."
} ;
@@ -773,10 +797,17 @@ HELP: call-next-method
HELP: call(
{ $syntax "call( stack -- effect )" }
-{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
+{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." }
+{ $examples
+ { $code
+ "TUPLE: action name quot ;"
+ ": perform-action ( action -- )"
+ " [ name>> print ] [ quot>> call( -- ) ] bi ;"
+ }
+} ;
HELP: execute(
{ $syntax "execute( stack -- effect )" }
{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
-{ POSTPONE: call( POSTPONE: execute( } related-words
\ No newline at end of file
+{ POSTPONE: call( POSTPONE: execute( } related-words
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index cb5cdfd5ac..7d710717aa 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien arrays byte-arrays definitions generic
+USING: accessors alien arrays byte-arrays byte-vectors definitions generic
hashtables kernel math namespaces parser lexer sequences strings
strings.parser sbufs vectors words words.symbol words.constant
words.alias quotations io assocs splitting classes.tuple
-generic.standard generic.math generic.parser classes
+generic.standard generic.hook generic.math generic.parser classes
io.pathnames vocabs vocabs.parser classes.parser classes.union
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple.parser compiler.units
@@ -98,12 +98,14 @@ IN: bootstrap.syntax
"{" [ \ } [ >array ] parse-literal ] define-core-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-core-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-core-syntax
+ "BV{" [ \ } [ >byte-vector ] parse-literal ] define-core-syntax
"H{" [ \ } [ >hashtable ] parse-literal ] define-core-syntax
"T{" [ parse-tuple-literal parsed ] define-core-syntax
"W{" [ \ } [ first <wrapper> ] parse-literal ] define-core-syntax
"POSTPONE:" [ scan-word parsed ] define-core-syntax
"\\" [ scan-word <wrapper> parsed ] define-core-syntax
+ "M\\" [ scan-word scan-word method <wrapper> parsed ] define-core-syntax
"inline" [ word make-inline ] define-core-syntax
"recursive" [ word make-recursive ] define-core-syntax
"foldable" [ word make-foldable ] define-core-syntax
diff --git a/core/system/system.factor b/core/system/system.factor
index 8f587d28c2..38b4a5fd9b 100644
--- a/core/system/system.factor
+++ b/core/system/system.factor
@@ -1,29 +1,20 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-IN: system
USING: kernel kernel.private sequences math namespaces
init splitting assocs system.private layouts words ;
+IN: system
-SINGLETON: x86.32
-SINGLETON: x86.64
-SINGLETON: arm
-SINGLETON: ppc
+SINGLETONS: x86.32 x86.64 arm ppc ;
UNION: x86 x86.32 x86.64 ;
: cpu ( -- class ) \ cpu get-global ; foldable
-SINGLETON: winnt
-SINGLETON: wince
+SINGLETONS: winnt wince ;
UNION: windows winnt wince ;
-SINGLETON: freebsd
-SINGLETON: netbsd
-SINGLETON: openbsd
-SINGLETON: solaris
-SINGLETON: macosx
-SINGLETON: linux
+SINGLETONS: freebsd netbsd openbsd solaris macosx linux ;
SINGLETON: haiku
@@ -62,11 +53,6 @@ PRIVATE>
: vm ( -- path ) \ vm get-global ;
-[
- 8 getenv string>cpu \ cpu set-global
- 9 getenv string>os \ os set-global
-] "system" add-init-hook
-
: embedded? ( -- ? ) 15 getenv ;
: millis ( -- ms ) micros 1000 /i ;
diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor
index e0d6fd4493..03d234807d 100644
--- a/core/vocabs/loader/loader-docs.factor
+++ b/core/vocabs/loader/loader-docs.factor
@@ -106,7 +106,7 @@ HELP: reload
HELP: require
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Loads a vocabulary if it has not already been loaded." }
-{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "tools.vocabs" } "." } ;
+{ $notes "To unconditionally reload a vocabulary, use " { $link reload } ". To reload changed source files only, use the words in " { $link "vocabs.refresh" } "." } ;
HELP: run
{ $values { "vocab" "a vocabulary specifier" } }
diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor
index 87531caee4..09f28541e0 100644
--- a/core/vocabs/loader/loader-tests.factor
+++ b/core/vocabs/loader/loader-tests.factor
@@ -1,9 +1,9 @@
-IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
-debugger compiler.units tools.vocabs accessors eval
-combinators vocabs.parser grouping ;
+debugger compiler.units accessors eval
+combinators vocabs.parser grouping vocabs.files vocabs.refresh ;
+IN: vocabs.loader.tests
! This vocab should not exist, but just in case...
[ ] [
@@ -18,13 +18,6 @@ combinators vocabs.parser grouping ;
[ t ]
[ "kernel" >vocab-link "kernel" vocab = ] unit-test
-[ t ] [
- "kernel" vocab-files
- "kernel" vocab vocab-files
- "kernel" <vocab-link> vocab-files
- 3array all-equal?
-] unit-test
-
IN: vocabs.loader.test.2
: hello ( -- ) ;
@@ -143,7 +136,7 @@ IN: vocabs.loader.tests
forget-junk
[ { } ] [
- "IN: xabbabbja" eval "xabbabbja" vocab-files
+ "IN: xabbabbja" eval( -- ) "xabbabbja" vocab-files
] unit-test
[ "xabbabbja" forget-vocab ] with-compilation-unit
diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor
index 4f9005e110..6561c55b67 100644
--- a/core/vocabs/loader/loader.factor
+++ b/core/vocabs/loader/loader.factor
@@ -3,7 +3,7 @@
USING: namespaces make sequences io io.files io.pathnames kernel
assocs words vocabs definitions parser continuations hashtables
sorting source-files arrays combinators strings system
-math.parser compiler.errors splitting init accessors sets ;
+math.parser splitting init accessors sets ;
IN: vocabs.loader
SYMBOL: vocab-roots
@@ -80,11 +80,11 @@ SYMBOL: load-help?
PRIVATE>
: require ( vocab -- )
- [ load-vocab drop ] with-compiler-errors ;
+ load-vocab drop ;
: reload ( name -- )
dup vocab
- [ [ [ load-source ] [ load-docs ] bi ] with-compiler-errors ]
+ [ [ load-source ] [ load-docs ] bi ]
[ require ]
?if ;
@@ -125,9 +125,7 @@ PRIVATE>
[
dup vocab-name blacklist get at* [ rethrow ] [
drop dup find-vocab-root
- [ [ (load-vocab) ] with-compiler-errors ]
- [ dup vocab [ ] [ no-vocab ] ?if ]
- if
+ [ (load-vocab) ] [ dup vocab [ ] [ no-vocab ] ?if ] if
] if
] load-vocab-hook set-global
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index 2b978e8666..6c12b7b325 100644
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -65,8 +65,22 @@ M: object vocab-main vocab vocab-main ;
M: f vocab-main ;
+SYMBOL: vocab-observers
+
+GENERIC: vocabs-changed ( obj -- )
+
+: add-vocab-observer ( obj -- )
+ vocab-observers get push ;
+
+: remove-vocab-observer ( obj -- )
+ vocab-observers get delq ;
+
+: notify-vocab-observers ( -- )
+ vocab-observers get [ vocabs-changed ] each ;
+
: create-vocab ( name -- vocab )
- dictionary get [ <vocab> ] cache ;
+ dictionary get [ <vocab> ] cache
+ notify-vocab-observers ;
ERROR: no-vocab name ;
@@ -99,7 +113,8 @@ M: string >vocab-link dup vocab [ ] [ <vocab-link> ] ?if ;
: forget-vocab ( vocab -- )
dup words forget-all
- vocab-name dictionary get delete-at ;
+ vocab-name dictionary get delete-at
+ notify-vocab-observers ;
M: vocab-spec forget* forget-vocab ;
diff --git a/core/words/alias/alias-tests.factor b/core/words/alias/alias-tests.factor
index 0278a4d4b9..c4bc8519a9 100644
--- a/core/words/alias/alias-tests.factor
+++ b/core/words/alias/alias-tests.factor
@@ -2,5 +2,5 @@ USING: math eval tools.test effects ;
IN: words.alias.tests
ALIAS: foo +
-[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
-[ (( -- value )) ] [ \ foo stack-effect ] unit-test
\ No newline at end of file
+[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval( -- ) ] unit-test
+[ (( -- value )) ] [ \ foo stack-effect ] unit-test
diff --git a/core/words/alias/alias.factor b/core/words/alias/alias.factor
index 0615e8333e..73e270dffc 100644
--- a/core/words/alias/alias.factor
+++ b/core/words/alias/alias.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: quotations effects accessors sequences words kernel ;
+USING: quotations effects accessors sequences words kernel definitions ;
IN: words.alias
PREDICATE: alias < word "alias" word-prop ;
@@ -12,5 +12,6 @@ PREDICATE: alias < word "alias" word-prop ;
M: alias reset-word
[ call-next-method ] [ f "alias" set-word-prop ] bi ;
-M: alias stack-effect
- def>> first stack-effect ;
+M: alias definer drop \ ALIAS: f ;
+
+M: alias definition def>> first 1quotation ;
\ No newline at end of file
diff --git a/core/words/constant/constant-docs.factor b/core/words/constant/constant-docs.factor
new file mode 100644
index 0000000000..3175b5d4ff
--- /dev/null
+++ b/core/words/constant/constant-docs.factor
@@ -0,0 +1,12 @@
+USING: help.markup help.syntax words.constant ;
+IN: words.constant
+
+ARTICLE: "words.constant" "Constants"
+"There is a syntax for defining words which push literals on the stack."
+$nl
+"Define a new word that pushes a literal on the stack:"
+{ $subsection POSTPONE: CONSTANT: }
+"Define an constant at run-time:"
+{ $subsection define-constant } ;
+
+ABOUT: "words.constant"
diff --git a/core/words/constant/constant-tests.factor b/core/words/constant/constant-tests.factor
new file mode 100644
index 0000000000..721846b2d1
--- /dev/null
+++ b/core/words/constant/constant-tests.factor
@@ -0,0 +1,20 @@
+IN: words.constant.tests
+USING: tools.test math words.constant ;
+
+CONSTANT: a +
+
+[ + ] [ a ] unit-test
+
+[ t ] [ \ a constant? ] unit-test
+
+CONSTANT: b \ +
+
+[ \ + ] [ b ] unit-test
+
+CONSTANT: c { 1 2 3 }
+
+[ { 1 2 3 } ] [ c ] unit-test
+
+SYMBOL: foo
+
+[ f ] [ \ foo constant? ] unit-test
\ No newline at end of file
diff --git a/core/words/constant/constant.factor b/core/words/constant/constant.factor
index 43b7f37599..b518760bf9 100644
--- a/core/words/constant/constant.factor
+++ b/core/words/constant/constant.factor
@@ -1,10 +1,17 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences words ;
+USING: accessors kernel sequences words definitions quotations ;
IN: words.constant
-PREDICATE: constant < word ( obj -- ? )
- def>> dup length 1 = [ first word? not ] [ drop f ] if ;
+PREDICATE: constant < word "constant" word-prop >boolean ;
: define-constant ( word value -- )
- [ ] curry (( -- value )) define-inline ;
+ [ "constant" set-word-prop ]
+ [ [ ] curry (( -- value )) define-inline ] 2bi ;
+
+M: constant reset-word
+ [ call-next-method ] [ f "constant" set-word-prop ] bi ;
+
+M: constant definer drop \ CONSTANT: f ;
+
+M: constant definition "constant" word-prop literalize 1quotation ;
\ No newline at end of file
diff --git a/core/words/symbol/symbol.factor b/core/words/symbol/symbol.factor
index a107808eec..34ec6b9174 100644
--- a/core/words/symbol/symbol.factor
+++ b/core/words/symbol/symbol.factor
@@ -1,10 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors definitions
-words words.constant ;
+USING: kernel sequences accessors definitions words ;
IN: words.symbol
-PREDICATE: symbol < constant ( obj -- ? )
+PREDICATE: symbol < word ( obj -- ? )
[ def>> ] [ [ ] curry ] bi sequence= ;
M: symbol definer drop \ SYMBOL: f ;
@@ -12,4 +11,4 @@ M: symbol definer drop \ SYMBOL: f ;
M: symbol definition drop f ;
: define-symbol ( word -- )
- dup define-constant ;
+ dup [ ] curry (( -- value )) define-inline ;
diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor
index 1ad6928acb..3725086f70 100644
--- a/core/words/words-docs.factor
+++ b/core/words/words-docs.factor
@@ -1,5 +1,5 @@
USING: definitions help.markup help.syntax kernel parser
-kernel.private words.private vocabs classes quotations
+kernel.private vocabs classes quotations
strings effects compiler.units ;
IN: words
@@ -21,8 +21,8 @@ $nl
{ $subsection gensym }
{ $subsection define-temp } ;
-ARTICLE: "colon-definition" "Word definitions"
-"Every word has an associated quotation definition that is called when the word is executed."
+ARTICLE: "colon-definition" "Colon definitions"
+"Every word has an associated quotation definition that is called when the word is executed. A " { $emphasis "colon definition" } " is a word where this quotation is supplied directly by the user. This is the simplest and most common type of word definition."
$nl
"Defining words at parse time:"
{ $subsection POSTPONE: : }
@@ -31,7 +31,7 @@ $nl
{ $subsection define }
{ $subsection define-declared }
{ $subsection define-inline }
-"Word definitions should declare their stack effect, unless the definition is completely trivial. See " { $link "effect-declaration" } "."
+"Word definitions must declare their stack effect. See " { $link "effects" } "."
$nl
"All other types of word definitions, such as " { $link "words.symbol" } " and " { $link "generic" } ", are just special cases of the above." ;
@@ -56,29 +56,16 @@ $nl
": foo undefined ;"
} ;
-ARTICLE: "declarations" "Declarations"
-"Declarations are parsing words that set a word property in the most recently defined word. Declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently."
+ARTICLE: "declarations" "Compiler declarations"
+"Compiler declarations are parsing words that set a word property in the most recently defined word. They appear after the final " { $link POSTPONE: ; } " of a word definition:"
+{ $code ": cubed ( x -- y ) dup dup * * ; foldable" }
+"Compiler declarations assert that the word follows a certain contract, enabling certain optimizations that are not valid in general."
{ $subsection POSTPONE: inline }
{ $subsection POSTPONE: foldable }
{ $subsection POSTPONE: flushable }
{ $subsection POSTPONE: recursive }
-{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." }
-"Stack effect declarations are documented in " { $link "effect-declaration" } "." ;
-
-ARTICLE: "word-definition" "Defining words"
-"There are two approaches to creating word definitions:"
-{ $list
- "using parsing words at parse time,"
- "using defining words at run time."
-}
-"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words."
-{ $subsection "colon-definition" }
-{ $subsection "words.symbol" }
-{ $subsection "words.alias" }
-{ $subsection "primitives" }
-{ $subsection "deferred" }
-{ $subsection "declarations" }
-"Words implement the definition protocol; see " { $link "definitions" } "." ;
+"It is entirely up to the programmer to ensure that the word satisfies the contract of a declaration. Furthermore, if a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract. Unspecified behavior may result if a word does not follow the contract of one of its declarations."
+{ $see-also "effects" } ;
ARTICLE: "word-props" "Word properties"
"Each word has a hashtable of properties."
@@ -99,14 +86,10 @@ $nl
{ { { $snippet "\"reading\"" } ", " { $snippet "\"writing\"" } } { "Set on slot accessor words - " { $link "slots" } } }
- { { $snippet "\"declared-effect\"" } { $link "effect-declaration" } }
+ { { $snippet "\"declared-effect\"" } { $link "effects" } }
{ { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } }
- { { $snippet "\"infer\"" } { $link "macros" } }
-
- { { { $snippet "\"inferred-effect\"" } } { $link "inference" } }
-
{ { $snippet "\"specializer\"" } { $link "hints" } }
{ { $snippet "\"predicating\"" } " Set on class predicates, stores the corresponding class word" }
@@ -137,9 +120,7 @@ $nl
"An " { $emphasis "XT" } " (execution token) is the machine code address of a word:"
{ $subsection word-xt } ;
-ARTICLE: "words" "Words"
-"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation."
-$nl
+ARTICLE: "words.introspection" "Word introspection"
"Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary."
$nl
"Word objects contain several slots:"
@@ -152,22 +133,36 @@ $nl
"Words are instances of a class."
{ $subsection word }
{ $subsection word? }
+"Words implement the definition protocol; see " { $link "definitions" } "."
{ $subsection "interned-words" }
{ $subsection "uninterned-words" }
-{ $subsection "word-definition" }
{ $subsection "word-props" }
-{ $subsection "word.private" }
+{ $subsection "word.private" } ;
+
+ARTICLE: "words" "Words"
+"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation."
+$nl
+"There are two ways of creating word definitions:"
+{ $list
+ "using parsing words at parse time,"
+ "using defining words at run time."
+}
+"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words."
+$nl
+"Types of words:"
+{ $subsection "colon-definition" }
+{ $subsection "words.symbol" }
+{ $subsection "words.alias" }
+{ $subsection "words.constant" }
+{ $subsection "primitives" }
+"Advanced topics:"
+{ $subsection "deferred" }
+{ $subsection "declarations" }
+{ $subsection "words.introspection" }
{ $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ;
ABOUT: "words"
-HELP: execute ( word -- )
-{ $values { "word" word } }
-{ $description "Executes a word." }
-{ $examples
- { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ;\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" }
-} ;
-
HELP: deferred
{ $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ;
@@ -293,10 +288,6 @@ HELP: define-temp
"This word must be called from inside " { $link with-compilation-unit } "."
} ;
-HELP: quot-uses
-{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } }
-{ $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ;
-
HELP: delimiter?
{ $values { "obj" object } { "?" "a boolean" } }
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor
index 305541119b..0ecf7b65f0 100755
--- a/core/words/words-tests.factor
+++ b/core/words/words-tests.factor
@@ -6,7 +6,7 @@ IN: words.tests
[ 4 ] [
[
- "poo" "words.tests" create [ 2 2 + ] define
+ "poo" "words.tests" create [ 2 2 + ] (( -- n )) define-declared
] with-compilation-unit
"poo" "words.tests" lookup execute
] unit-test
@@ -51,7 +51,7 @@ SYMBOL: a-symbol
! See if redefining a generic as a colon def clears some
! word props.
GENERIC: testing ( a -- b )
-"IN: words.tests : testing ( -- ) ;" eval
+"IN: words.tests : testing ( -- ) ;" eval( -- )
[ f ] [ \ testing generic? ] unit-test
@@ -63,52 +63,6 @@ FORGET: forgotten
FORGET: another-forgotten
: another-forgotten ( -- ) ;
-! I forgot remove-crossref calls!
-: fee ( -- ) ;
-: foe ( -- ) fee ;
-: fie ( -- ) foe ;
-
-[ t ] [ \ fee usage [ word? ] filter empty? ] unit-test
-[ t ] [ \ foe usage empty? ] unit-test
-[ f ] [ \ foe crossref get key? ] unit-test
-
-FORGET: foe
-
-! xref should not retain references to gensyms
-[ ] [
- [ gensym [ * ] define ] with-compilation-unit
-] unit-test
-
-[ t ] [
- \ * usage [ word? ] filter [ crossref? ] all?
-] unit-test
-
-DEFER: calls-a-gensym
-[ ] [
- [
- \ calls-a-gensym
- gensym dup "x" set 1quotation
- define
- ] with-compilation-unit
-] unit-test
-
-[ f ] [ "x" get crossref get at ] unit-test
-
-! more xref buggery
-[ f ] [
- GENERIC: xyzzle ( x -- x )
- : a ( -- ) ; \ a
- M: integer xyzzle a ;
- FORGET: a
- M: object xyzzle ;
- crossref get at
-] unit-test
-
-! regression
-GENERIC: freakish ( x -- y )
-: bar ( x -- y ) freakish ;
-M: array freakish ;
-[ t ] [ \ bar \ freakish usage member? ] unit-test
DEFER: x
[ x ] [ undefined? ] must-fail-with
@@ -116,45 +70,25 @@ DEFER: x
[ ] [ "no-loc" "words.tests" create drop ] unit-test
[ f ] [ "no-loc" "words.tests" lookup where ] unit-test
-[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test
-[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test
[ "test-last" ] [ word name>> ] unit-test
-! regression
-SYMBOL: quot-uses-a
-SYMBOL: quot-uses-b
-
-[ ] [
- [
- quot-uses-a [ 2 3 + ] define
- ] with-compilation-unit
-] unit-test
-
-[ { + } ] [ \ quot-uses-a uses ] unit-test
-
-[ ] [
- [
- quot-uses-b 2 [ 3 + ] curry define
- ] with-compilation-unit
-] unit-test
-
-[ { + } ] [ \ quot-uses-b uses ] unit-test
-
"undef-test" "words.tests" lookup [
[ forget ] with-compilation-unit
] when*
-[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval ]
+[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval( -- ) ]
[ error>> undefined? ] must-fail-with
[ ] [
- "IN: words.tests GENERIC: symbol-generic ( -- )" eval
+ "IN: words.tests GENERIC: symbol-generic ( -- )" eval( -- )
] unit-test
[ ] [
- "IN: words.tests SYMBOL: symbol-generic" eval
+ "IN: words.tests SYMBOL: symbol-generic" eval( -- )
] unit-test
[ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test
@@ -174,14 +108,14 @@ SYMBOL: quot-uses-b
[ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test
! Regressions
-[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval( -- ) ] unit-test
[ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
-[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test
-[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval( -- ) ] unit-test
[ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
-[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test
+[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test
[ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test
[ { } ]
@@ -191,8 +125,3 @@ SYMBOL: quot-uses-b
keys [ "forgotten" word-prop ] any?
] filter
] unit-test
-
-[ { } ] [
- crossref get keys
- [ word? ] filter [ "forgotten" word-prop ] filter
-] unit-test
diff --git a/core/words/words.factor b/core/words/words.factor
index 5b230c1b00..1976c1e4cd 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions graphs assocs kernel
-kernel.private slots.private math namespaces sequences strings
-vectors sbufs quotations assocs hashtables sorting words.private
-vocabs math.order sets ;
+kernel.private kernel.private slots.private math namespaces sequences
+strings vectors sbufs quotations assocs hashtables sorting vocabs
+math.order sets ;
IN: words
: word ( -- word ) \ word get-global ;
@@ -62,37 +62,7 @@ SYMBOL: bootstrapping?
GENERIC: crossref? ( word -- ? )
M: word crossref?
- dup "forgotten" word-prop [
- drop f
- ] [
- vocabulary>> >boolean
- ] if ;
-
-GENERIC: compiled-crossref? ( word -- ? )
-
-M: word compiled-crossref? crossref? ;
-
-GENERIC# (quot-uses) 1 ( obj assoc -- )
-
-M: object (quot-uses) 2drop ;
-
-M: word (quot-uses) over crossref? [ conjoin ] [ 2drop ] if ;
-
-: seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ;
-
-M: array (quot-uses) seq-uses ;
-
-M: hashtable (quot-uses) [ >alist ] dip seq-uses ;
-
-M: callable (quot-uses) seq-uses ;
-
-M: wrapper (quot-uses) [ wrapped>> ] dip (quot-uses) ;
-
-: quot-uses ( quot -- assoc )
- global [ H{ } clone [ (quot-uses) ] keep ] bind ;
-
-M: word uses ( word -- seq )
- def>> quot-uses keys ;
+ dup "forgotten" word-prop [ drop f ] [ vocabulary>> >boolean ] if ;
SYMBOL: compiled-crossref
@@ -131,44 +101,22 @@ compiled-generic-crossref [ H{ } clone ] initialize
: inline? ( word -- ? ) "inline" word-prop ; inline
-SYMBOL: visited
+GENERIC: subwords ( word -- seq )
-CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" }
-
-: (redefined) ( word -- )
- dup visited get key? [ drop ] [
- [ reset-on-redefine reset-props ]
- [ visited get conjoin ]
- [
- crossref get at keys
- [ word? ] filter
- [
- [ reset-on-redefine [ word-prop ] with any? ]
- [ inline? ]
- bi or
- ] filter
- [ (redefined) ] each
- ] tri
- ] if ;
-
-: redefined ( word -- )
- [ H{ } clone visited [ (redefined) ] with-variable ]
- [ changed-definition ]
- bi ;
+M: word subwords drop f ;
: define ( word def -- )
- [ ] like
- over unxref
- over redefined
- >>def
- dup crossref? [ dup xref ] when drop ;
+ over changed-definition [ ] like >>def drop ;
+
+: changed-effect ( word -- )
+ [ dup changed-effects get set-in-unit ]
+ [ dup primitive? [ drop ] [ changed-definition ] if ] bi ;
: set-stack-effect ( effect word -- )
2dup "declared-effect" word-prop = [ 2drop ] [
- swap
- [ drop changed-effect ]
- [ "declared-effect" set-word-prop ]
- [ drop dup primitive? [ drop ] [ redefined ] if ]
+ [ nip changed-effect ]
+ [ nip subwords [ changed-effect ] each ]
+ [ swap "declared-effect" set-word-prop ]
2tri
] if ;
@@ -176,7 +124,11 @@ CONSTANT: reset-on-redefine { "inferred-effect" "cannot-infer" }
[ nip swap set-stack-effect ] [ drop define ] 3bi ;
: make-inline ( word -- )
- t "inline" set-word-prop ;
+ dup inline? [ drop ] [
+ [ t "inline" set-word-prop ]
+ [ changed-effect ]
+ bi
+ ] if ;
: make-recursive ( word -- )
t "recursive" set-word-prop ;
@@ -199,15 +151,19 @@ M: word reset-word
"writer" "delimiter"
} reset-props ;
-GENERIC: subwords ( word -- seq )
-
-M: word subwords drop f ;
-
: reset-generic ( word -- )
[ subwords forget-all ]
[ reset-word ]
- [ { "methods" "combination" "default-method" } reset-props ]
- tri ;
+ [
+ f >>direct-entry-def
+ {
+ "methods"
+ "combination"
+ "default-method"
+ "engines"
+ "decision-tree"
+ } reset-props
+ ] tri ;
: gensym ( -- word )
"( gensym )" f <word> ;
@@ -250,10 +206,9 @@ M: word set-where swap "loc" set-word-prop ;
M: word forget*
dup "forgotten" word-prop [ drop ] [
- [ delete-xref ]
[ [ name>> ] [ vocabulary>> vocab-words ] bi delete-at ]
[ t "forgotten" set-word-prop ]
- tri
+ bi
] if ;
M: word hashcode*
@@ -261,6 +216,4 @@ M: word hashcode*
M: word literalize <wrapper> ;
-: xref-words ( -- ) all-words [ xref ] each ;
-
INSTANCE: word definition
\ No newline at end of file
diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor
index aae0b40d38..b9679ec26b 100755
--- a/extra/4DNav/4DNav.factor
+++ b/extra/4DNav/4DNav.factor
@@ -75,8 +75,6 @@ VAR: present-space
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! namespace utilities
-
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
: closed-quot ( quot -- quot )
namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
@@ -156,9 +154,9 @@ VAR: present-space
3 model-projection <model> view4> (>>model) ;
: camera-action ( quot -- quot )
- [ drop [ ] observer3d>
+ '[ drop _ observer3d>
with-self update-observer-projections ]
- make* closed-quot ;
+ closed-quot ;
: win3D ( text gadget -- )
"navigateur 4D : " rot append open-window ;
@@ -400,7 +398,7 @@ M: handler handle-gesture ( gesture gadget -- ? )
: add-keyboard-delegate ( obj -- obj )
<handler>
-{
+H{
{ T{ key-down f f "LEFT" }
[ [ rotation-step turn-left ] camera-action ] }
{ T{ key-down f f "RIGHT" }
@@ -435,7 +433,7 @@ M: handler handle-gesture ( gesture gadget -- ? )
{ T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }
{ T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }
- } [ make* ] map >hashtable >>table
+ } >>table
;
! --------------------------------------------
diff --git a/extra/4DNav/camera/camera.factor b/extra/4DNav/camera/camera.factor
index 1f36a46275..0d46d73f55 100755
--- a/extra/4DNav/camera/camera.factor
+++ b/extra/4DNav/camera/camera.factor
@@ -1,4 +1,4 @@
-USING: kernel namespaces math.vectors opengl 4DNav.turtle ;
+USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ;
IN: 4DNav.camera
diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor
index 9bd0e9c011..51bebc3877 100755
--- a/extra/4DNav/file-chooser/file-chooser.factor
+++ b/extra/4DNav/file-chooser/file-chooser.factor
@@ -72,17 +72,17 @@ file-chooser H{
: init-filelist-model ( file-chooser -- file-chooser )
dup list-of-files <model> >>model ;
-: (fc-go) ( file-chooser quot -- )
+: (fc-go) ( file-chooser button quot -- )
[ [ file-chooser? ] find-parent dup path>> ] dip
call
normalize-path swap set-model
update-filelist-model
- drop ;
+ drop ; inline
-: fc-go-parent ( file-chooser -- )
+: fc-go-parent ( file-chooser button -- )
[ dup value>> parent-directory ] (fc-go) ;
-: fc-go-home ( file-chooser -- )
+: fc-go-home ( file-chooser button -- )
[ home ] (fc-go) ;
: fc-change-directory ( file-chooser file -- )
@@ -92,11 +92,9 @@ file-chooser H{
;
: fc-load-file ( file-chooser file -- )
- dupd [ selected-file>> ] [ name>> ] bi* swap set-model
- [ path>> value>> ]
- [ selected-file>> value>> append ]
- [ hook>> ] tri
- call
+ over [ name>> ] [ selected-file>> ] bi* set-model
+ [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi
+ call( path -- )
; inline
! : fc-ok-action ( file-chooser -- quot )
diff --git a/extra/annotations/annotations-docs.factor b/extra/annotations/annotations-docs.factor
index 1bece9d4fb..8685d954e8 100644
--- a/extra/annotations/annotations-docs.factor
+++ b/extra/annotations/annotations-docs.factor
@@ -1,6 +1,6 @@
USING: accessors arrays combinators definitions generalizations
help help.markup help.topics kernel sequences sorting vocabs
-words combinators.smart ;
+words combinators.smart tools.crossref ;
IN: annotations
<PRIVATE
diff --git a/extra/audio/audio.factor b/extra/audio/audio.factor
new file mode 100644
index 0000000000..04df36ebd6
--- /dev/null
+++ b/extra/audio/audio.factor
@@ -0,0 +1,23 @@
+USING: accessors alien arrays combinators kernel math openal ;
+IN: audio
+
+TUPLE: audio
+ { channels integer }
+ { sample-bits integer }
+ { sample-rate integer }
+ { size integer }
+ { data c-ptr } ;
+
+C: <audio> audio
+
+ERROR: format-unsupported-by-openal audio ;
+
+: openal-format ( audio -- format )
+ dup [ channels>> ] [ sample-bits>> ] bi 2array {
+ { { 1 8 } [ drop AL_FORMAT_MONO8 ] }
+ { { 1 16 } [ drop AL_FORMAT_MONO16 ] }
+ { { 2 8 } [ drop AL_FORMAT_STEREO8 ] }
+ { { 2 16 } [ drop AL_FORMAT_STEREO16 ] }
+ [ drop format-unsupported-by-openal ]
+ } case ;
+
diff --git a/extra/audio/wav/wav.factor b/extra/audio/wav/wav.factor
new file mode 100644
index 0000000000..6b76e98f3a
--- /dev/null
+++ b/extra/audio/wav/wav.factor
@@ -0,0 +1,85 @@
+USING: alien.c-types alien.syntax audio combinators
+combinators.short-circuit io io.binary io.encodings.binary
+io.files io.streams.byte-array kernel locals math
+sequences ;
+IN: audio.wav
+
+CONSTANT: RIFF-MAGIC "RIFF"
+CONSTANT: WAVE-MAGIC "WAVE"
+CONSTANT: FMT-MAGIC "fmt "
+CONSTANT: DATA-MAGIC "data"
+
+C-STRUCT: riff-chunk-header
+ { "char[4]" "id" }
+ { "uchar[4]" "size" }
+ ;
+
+C-STRUCT: riff-chunk
+ { "riff-chunk-header" "header" }
+ { "char[4]" "format" }
+ ;
+
+C-STRUCT: wav-fmt-chunk
+ { "riff-chunk-header" "header" }
+ { "uchar[2]" "audio-format" }
+ { "uchar[2]" "num-channels" }
+ { "uchar[4]" "sample-rate" }
+ { "uchar[4]" "byte-rate" }
+ { "uchar[2]" "block-align" }
+ { "uchar[2]" "bits-per-sample" }
+ ;
+
+C-STRUCT: wav-data-chunk
+ { "riff-chunk-header" "header" }
+ { "uchar[0]" "body" }
+ ;
+
+ERROR: invalid-wav-file ;
+
+: ensured-read ( count -- output/f )
+ [ read ] keep over length = [ drop f ] unless ;
+: ensured-read* ( count -- output )
+ ensured-read [ invalid-wav-file ] unless* ;
+
+: read-chunk ( -- byte-array/f )
+ 4 ensured-read [ 4 ensured-read* dup le> ensured-read* 3append ] [ f ] if* ;
+: read-riff-chunk ( -- byte-array/f )
+ "riff-chunk" heap-size ensured-read* ;
+
+: id= ( chunk id -- ? )
+ [ 4 head ] dip sequence= ;
+
+: check-chunk ( chunk id min-size -- ? )
+ [ id= ] [ [ length ] dip >= ] bi-curry* bi and ;
+
+:: read-wav-chunks ( -- fmt data )
+ f :> fmt! f :> data!
+ [ { [ fmt data and not ] [ read-chunk ] } 0&& dup ]
+ [ {
+ { [ dup FMT-MAGIC "wav-fmt-chunk" heap-size check-chunk ] [ fmt! ] }
+ { [ dup DATA-MAGIC "wav-data-chunk" heap-size check-chunk ] [ data! ] }
+ } cond ] while drop
+ fmt data 2dup and [ invalid-wav-file ] unless ;
+
+: verify-wav ( chunk -- )
+ {
+ [ RIFF-MAGIC id= ]
+ [ riff-chunk-format 4 memory>byte-array WAVE-MAGIC id= ]
+ } 1&&
+ [ invalid-wav-file ] unless ;
+
+: (read-wav) ( -- audio )
+ read-wav-chunks
+ [
+ [ wav-fmt-chunk-num-channels 2 memory>byte-array le> ]
+ [ wav-fmt-chunk-bits-per-sample 2 memory>byte-array le> ]
+ [ wav-fmt-chunk-sample-rate 4 memory>byte-array le> ] tri
+ ] [
+ [ riff-chunk-header-size 4 memory>byte-array le> dup ]
+ [ wav-data-chunk-body ] bi swap memory>byte-array
+ ] bi* <audio> ;
+
+: read-wav ( filename -- audio )
+ binary [
+ read-riff-chunk verify-wav (read-wav)
+ ] with-file-reader ;
diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor
index f06bc2fb81..31a4b75eb2 100644
--- a/extra/bank/bank.factor
+++ b/extra/bank/bank.factor
@@ -54,7 +54,7 @@ C: <transaction> transaction
: process-day ( account date -- )
2dup accumulate-interest ?pay-interest ;
-: each-day ( quot start end -- )
+: each-day ( quot: ( -- ) start end -- )
2dup before? [
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [
@@ -63,7 +63,7 @@ C: <transaction> transaction
: process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+
- [ dupd process-day ] spin each-day ; inline
+ [ dupd process-day ] spin each-day ;
: inserting-transactions ( account transactions -- account )
[ [ date>> process-to-date ] keep >>transaction ] each ;
diff --git a/extra/benchmark/base64/base64.factor b/extra/benchmark/base64/base64.factor
index f6e5f7ca39..350a29f865 100644
--- a/extra/benchmark/base64/base64.factor
+++ b/extra/benchmark/base64/base64.factor
@@ -5,7 +5,7 @@ IN: benchmark.base64
: base64-benchmark ( -- )
65535 [ 255 bitand ] "" map-as
- 100 [ >base64 base64> ] times
+ 20 [ >base64 base64> ] times
drop ;
MAIN: base64-benchmark
diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor
index 489dc5e73f..6c64e34835 100755
--- a/extra/benchmark/benchmark.factor
+++ b/extra/benchmark/benchmark.factor
@@ -1,21 +1,35 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel vocabs vocabs.loader tools.time tools.vocabs
+USING: kernel vocabs vocabs.loader tools.time vocabs.hierarchy
arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger math ;
+continuations debugger math namespaces memory ;
IN: benchmark
-: run-benchmark ( vocab -- result )
+<PRIVATE
+
+SYMBOL: timings
+SYMBOL: errors
+
+PRIVATE>
+
+: run-benchmark ( vocab -- )
[ "=== " write vocab-name print flush ] [
- [ [ require ] [ [ run ] benchmark ] bi ] curry
- [ error. f ] recover
+ [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
+ [ swap errors ]
+ recover get set-at
] bi ;
-: run-benchmarks ( -- assoc )
- "benchmark" all-child-vocabs-seq
- [ dup run-benchmark ] { } map>assoc ;
+: run-benchmarks ( -- timings errors )
+ [
+ V{ } clone timings set
+ V{ } clone errors set
+ "benchmark" all-child-vocabs-seq
+ [ run-benchmark ] each
+ timings get
+ errors get
+ ] with-scope ;
-: benchmarks. ( assoc -- )
+: timings. ( assocs -- )
standard-table-style [
[
[ "Benchmark" write ] with-cell
@@ -24,13 +38,21 @@ IN: benchmark
[
[
[ [ 1array $vocab-link ] with-cell ]
- [ [ 1000000 /f pprint-cell ] [ [ "failed" write ] with-cell ] if* ] bi*
+ [ 1000000 /f pprint-cell ]
+ bi*
] with-row
] assoc-each
] tabular-output nl ;
+: benchmark-errors. ( errors -- )
+ [
+ [ "=== " write vocab-name print ]
+ [ error. ]
+ bi*
+ ] assoc-each ;
+
: benchmarks ( -- )
- run-benchmarks benchmarks. ;
+ run-benchmarks [ timings. ] [ benchmark-errors. ] bi* ;
MAIN: benchmarks
diff --git a/extra/benchmark/beust1/beust1.factor b/extra/benchmark/beust1/beust1.factor
index 9849ac2dbe..d94c1d1335 100644
--- a/extra/benchmark/beust1/beust1.factor
+++ b/extra/benchmark/beust1/beust1.factor
@@ -8,7 +8,7 @@ IN: benchmark.beust1
1 [a,b] [ number>string all-unique? ] count ; inline
: beust ( -- )
- 10000000 count-numbers
+ 2000000 count-numbers
number>string " unique numbers." append print ;
MAIN: beust
diff --git a/extra/benchmark/beust2/beust2.factor b/extra/benchmark/beust2/beust2.factor
index f96dc77961..d269ef3503 100755
--- a/extra/benchmark/beust2/beust2.factor
+++ b/extra/benchmark/beust2/beust2.factor
@@ -34,7 +34,7 @@ IN: benchmark.beust2
:: beust ( -- )
[let | i! [ 0 ] |
- 10000000000 [ i 1+ i! ] count-numbers
+ 5000000000 [ i 1+ i! ] count-numbers
i number>string " unique numbers." append print
] ;
diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor
index 2ae5ada8a1..f457b90c30 100755
--- a/extra/benchmark/fasta/fasta.factor
+++ b/extra/benchmark/fasta/fasta.factor
@@ -46,8 +46,8 @@ CONSTANT: homo-sapiens
}
: make-cumulative ( freq -- chars floats )
- dup keys >byte-array
- swap values >double-array unclip [ + ] accumulate swap suffix ;
+ [ keys >byte-array ]
+ [ values >double-array ] bi unclip [ + ] accumulate swap suffix ;
:: select-random ( seed chars floats -- seed elt )
floats seed random -rot
@@ -55,7 +55,7 @@ CONSTANT: homo-sapiens
chars nth-unsafe ; inline
: make-random-fasta ( seed len chars floats -- seed )
- [ rot drop select-random ] 2curry B{ } map-as print ; inline
+ [ rot drop select-random ] 2curry "" map-as print ; inline
: write-description ( desc id -- )
">" write write bl print ; inline
@@ -71,7 +71,7 @@ CONSTANT: homo-sapiens
:: make-repeat-fasta ( k len alu -- k' )
[let | kn [ alu length ] |
- len [ k + kn mod alu nth-unsafe ] B{ } map-as print
+ len [ k + kn mod alu nth-unsafe ] "" map-as print
k len +
] ; inline
diff --git a/extra/benchmark/fib6/deploy.factor b/extra/benchmark/fib6/deploy.factor
new file mode 100644
index 0000000000..3a367dcd51
--- /dev/null
+++ b/extra/benchmark/fib6/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+ { deploy-name "benchmark.fib6" }
+ { deploy-threads? f }
+ { deploy-math? f }
+ { deploy-word-props? f }
+ { deploy-ui? f }
+ { deploy-io 1 }
+ { deploy-compiler? t }
+ { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
+ { deploy-unicode? f }
+ { deploy-word-defs? f }
+ { deploy-c-types? f }
+}
diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor
index 64d1b6c533..f81b6a21a2 100755
--- a/extra/benchmark/fib6/fib6.factor
+++ b/extra/benchmark/fib6/fib6.factor
@@ -9,6 +9,6 @@ USING: math kernel alien ;
] alien-callback
"int" { "int" } "cdecl" alien-indirect ;
-: fib-main ( -- ) 34 fib drop ;
+: fib-main ( -- ) 32 fib drop ;
MAIN: fib-main
diff --git a/extra/benchmark/gc0/authors.txt b/extra/benchmark/gc0/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/benchmark/gc0/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/benchmark/gc0/gc0.factor b/extra/benchmark/gc0/gc0.factor
new file mode 100644
index 0000000000..997e8df23f
--- /dev/null
+++ b/extra/benchmark/gc0/gc0.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math ;
+IN: benchmark.gc0
+
+: allocate ( -- obj ) 10 f <array> ;
+: gc0 ( -- ) f 60000000 [ allocate nip ] times drop ;
+
+MAIN: gc0
\ No newline at end of file
diff --git a/extra/benchmark/gc1/authors.txt b/extra/benchmark/gc1/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/benchmark/gc1/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/benchmark/gc1/gc1.factor b/extra/benchmark/gc1/gc1.factor
new file mode 100644
index 0000000000..d201a08ecf
--- /dev/null
+++ b/extra/benchmark/gc1/gc1.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math sequences kernel ;
+IN: benchmark.gc1
+
+: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ;
+
+MAIN: gc1
\ No newline at end of file
diff --git a/extra/benchmark/gc2/authors.txt b/extra/benchmark/gc2/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/benchmark/gc2/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/benchmark/gc2/gc2.factor b/extra/benchmark/gc2/gc2.factor
new file mode 100644
index 0000000000..58f645aa7f
--- /dev/null
+++ b/extra/benchmark/gc2/gc2.factor
@@ -0,0 +1,24 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays kernel namespaces sequences math memory ;
+IN: benchmark.gc2
+
+! Runs slowly if clean cards are not unmarked.
+SYMBOL: oldies
+
+: make-old-objects ( -- )
+ 1000000 [ 1 f <array> ] replicate oldies set gc
+ oldies get [ "HI" swap set-first ] each ;
+
+: allocate ( -- x ) 20000 (byte-array) ;
+
+: age ( -- )
+ 1000 [ allocate drop ] times ;
+
+: gc2 ( -- )
+ [
+ make-old-objects
+ 50000 [ age ] times
+ ] with-scope ;
+
+MAIN: gc2
\ No newline at end of file
diff --git a/extra/benchmark/javascript/authors.txt b/extra/benchmark/javascript/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/benchmark/javascript/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/benchmark/javascript/javascript.factor b/extra/benchmark/javascript/javascript.factor
new file mode 100644
index 0000000000..4c05439e99
--- /dev/null
+++ b/extra/benchmark/javascript/javascript.factor
@@ -0,0 +1,10 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings.utf8 io.files kernel peg.javascript ;
+IN: benchmark.javascript
+
+: javascript-parser-benchmark ( -- )
+ "vocab:benchmark/javascript/jquery-1.3.2.min.js"
+ utf8 file-contents parse-javascript drop ;
+
+MAIN: javascript-parser-benchmark
\ No newline at end of file
diff --git a/extra/benchmark/javascript/jquery-1.3.2.min.js b/extra/benchmark/javascript/jquery-1.3.2.min.js
new file mode 100644
index 0000000000..b1ae21d8b2
--- /dev/null
+++ b/extra/benchmark/javascript/jquery-1.3.2.min.js
@@ -0,0 +1,19 @@
+/*
+ * jQuery JavaScript Library v1.3.2
+ * http://jquery.com/
+ *
+ * Copyright (c) 2009 John Resig
+ * Dual licensed under the MIT and GPL licenses.
+ * http://docs.jquery.com/License
+ *
+ * Date: 2009-02-19 17:34:21 -0500 (Thu, 19 Feb 2009)
+ * Revision: 6246
+ */
+(function(){var l=this,g,y=l.jQuery,p=l.$,o=l.jQuery=l.$=function(E,F){return new o.fn.init(E,F)},D=/^[^<]*(<(.|\s)+>)[^>]*$|^#([\w-]+)$/,f=/^.[^:#\[\.,]*$/;o.fn=o.prototype={init:function(E,H){E=E||document;if(E.nodeType){this[0]=E;this.length=1;this.context=E;return this}if(typeof E==="string"){var G=D.exec(E);if(G&&(G[1]||!H)){if(G[1]){E=o.clean([G[1]],H)}else{var I=document.getElementById(G[3]);if(I&&I.id!=G[3]){return o().find(E)}var F=o(I||[]);F.context=document;F.selector=E;return F}}else{return o(H).find(E)}}else{if(o.isFunction(E)){return o(document).ready(E)}}if(E.selector&&E.context){this.selector=E.selector;this.context=E.context}return this.setArray(o.isArray(E)?E:o.makeArray(E))},selector:"",jquery:"1.3.2",size:function(){return this.length},get:function(E){return E===g?Array.prototype.slice.call(this):this[E]},pushStack:function(F,H,E){var G=o(F);G.prevObject=this;G.context=this.context;if(H==="find"){G.selector=this.selector+(this.selector?" ":"")+E}else{if(H){G.selector=this.selector+"."+H+"("+E+")"}}return G},setArray:function(E){this.length=0;Array.prototype.push.apply(this,E);return this},each:function(F,E){return o.each(this,F,E)},index:function(E){return o.inArray(E&&E.jquery?E[0]:E,this)},attr:function(F,H,G){var E=F;if(typeof F==="string"){if(H===g){return this[0]&&o[G||"attr"](this[0],F)}else{E={};E[F]=H}}return this.each(function(I){for(F in E){o.attr(G?this.style:this,F,o.prop(this,E[F],G,I,F))}})},css:function(E,F){if((E=="width"||E=="height")&&parseFloat(F)<0){F=g}return this.attr(E,F,"curCSS")},text:function(F){if(typeof F!=="object"&&F!=null){return this.empty().append((this[0]&&this[0].ownerDocument||document).createTextNode(F))}var E="";o.each(F||this,function(){o.each(this.childNodes,function(){if(this.nodeType!=8){E+=this.nodeType!=1?this.nodeValue:o.fn.text([this])}})});return E},wrapAll:function(E){if(this[0]){var F=o(E,this[0].ownerDocument).clone();if(this[0].parentNode){F.insertBefore(this[0])}F.map(function(){var G=this;while(G.firstChild){G=G.firstChild}return G}).append(this)}return this},wrapInner:function(E){return this.each(function(){o(this).contents().wrapAll(E)})},wrap:function(E){return this.each(function(){o(this).wrapAll(E)})},append:function(){return this.domManip(arguments,true,function(E){if(this.nodeType==1){this.appendChild(E)}})},prepend:function(){return this.domManip(arguments,true,function(E){if(this.nodeType==1){this.insertBefore(E,this.firstChild)}})},before:function(){return this.domManip(arguments,false,function(E){this.parentNode.insertBefore(E,this)})},after:function(){return this.domManip(arguments,false,function(E){this.parentNode.insertBefore(E,this.nextSibling)})},end:function(){return this.prevObject||o([])},push:[].push,sort:[].sort,splice:[].splice,find:function(E){if(this.length===1){var F=this.pushStack([],"find",E);F.length=0;o.find(E,this[0],F);return F}else{return this.pushStack(o.unique(o.map(this,function(G){return o.find(E,G)})),"find",E)}},clone:function(G){var E=this.map(function(){if(!o.support.noCloneEvent&&!o.isXMLDoc(this)){var I=this.outerHTML;if(!I){var J=this.ownerDocument.createElement("div");J.appendChild(this.cloneNode(true));I=J.innerHTML}return o.clean([I.replace(/ jQuery\d+="(?:\d+|null)"/g,"").replace(/^\s*/,"")])[0]}else{return this.cloneNode(true)}});if(G===true){var H=this.find("*").andSelf(),F=0;E.find("*").andSelf().each(function(){if(this.nodeName!==H[F].nodeName){return}var I=o.data(H[F],"events");for(var K in I){for(var J in I[K]){o.event.add(this,K,I[K][J],I[K][J].data)}}F++})}return E},filter:function(E){return this.pushStack(o.isFunction(E)&&o.grep(this,function(G,F){return E.call(G,F)})||o.multiFilter(E,o.grep(this,function(F){return F.nodeType===1})),"filter",E)},closest:function(E){var G=o.expr.match.POS.test(E)?o(E):null,F=0;return this.map(function(){var H=this;while(H&&H.ownerDocument){if(G?G.index(H)>-1:o(H).is(E)){o.data(H,"closest",F);return H}H=H.parentNode;F++}})},not:function(E){if(typeof E==="string"){if(f.test(E)){return this.pushStack(o.multiFilter(E,this,true),"not",E)}else{E=o.multiFilter(E,this)}}var F=E.length&&E[E.length-1]!==g&&!E.nodeType;return this.filter(function(){return F?o.inArray(this,E)<0:this!=E})},add:function(E){return this.pushStack(o.unique(o.merge(this.get(),typeof E==="string"?o(E):o.makeArray(E))))},is:function(E){return !!E&&o.multiFilter(E,this).length>0},hasClass:function(E){return !!E&&this.is("."+E)},val:function(K){if(K===g){var E=this[0];if(E){if(o.nodeName(E,"option")){return(E.attributes.value||{}).specified?E.value:E.text}if(o.nodeName(E,"select")){var I=E.selectedIndex,L=[],M=E.options,H=E.type=="select-one";if(I<0){return null}for(var F=H?I:0,J=H?I+1:M.length;F<J;F++){var G=M[F];if(G.selected){K=o(G).val();if(H){return K}L.push(K)}}return L}return(E.value||"").replace(/\r/g,"")}return g}if(typeof K==="number"){K+=""}return this.each(function(){if(this.nodeType!=1){return}if(o.isArray(K)&&/radio|checkbox/.test(this.type)){this.checked=(o.inArray(this.value,K)>=0||o.inArray(this.name,K)>=0)}else{if(o.nodeName(this,"select")){var N=o.makeArray(K);o("option",this).each(function(){this.selected=(o.inArray(this.value,N)>=0||o.inArray(this.text,N)>=0)});if(!N.length){this.selectedIndex=-1}}else{this.value=K}}})},html:function(E){return E===g?(this[0]?this[0].innerHTML.replace(/ jQuery\d+="(?:\d+|null)"/g,""):null):this.empty().append(E)},replaceWith:function(E){return this.after(E).remove()},eq:function(E){return this.slice(E,+E+1)},slice:function(){return this.pushStack(Array.prototype.slice.apply(this,arguments),"slice",Array.prototype.slice.call(arguments).join(","))},map:function(E){return this.pushStack(o.map(this,function(G,F){return E.call(G,F,G)}))},andSelf:function(){return this.add(this.prevObject)},domManip:function(J,M,L){if(this[0]){var I=(this[0].ownerDocument||this[0]).createDocumentFragment(),F=o.clean(J,(this[0].ownerDocument||this[0]),I),H=I.firstChild;if(H){for(var G=0,E=this.length;G<E;G++){L.call(K(this[G],H),this.length>1||G>0?I.cloneNode(true):I)}}if(F){o.each(F,z)}}return this;function K(N,O){return M&&o.nodeName(N,"table")&&o.nodeName(O,"tr")?(N.getElementsByTagName("tbody")[0]||N.appendChild(N.ownerDocument.createElement("tbody"))):N}}};o.fn.init.prototype=o.fn;function z(E,F){if(F.src){o.ajax({url:F.src,async:false,dataType:"script"})}else{o.globalEval(F.text||F.textContent||F.innerHTML||"")}if(F.parentNode){F.parentNode.removeChild(F)}}function e(){return +new Date}o.extend=o.fn.extend=function(){var J=arguments[0]||{},H=1,I=arguments.length,E=false,G;if(typeof J==="boolean"){E=J;J=arguments[1]||{};H=2}if(typeof J!=="object"&&!o.isFunction(J)){J={}}if(I==H){J=this;--H}for(;H<I;H++){if((G=arguments[H])!=null){for(var F in G){var K=J[F],L=G[F];if(J===L){continue}if(E&&L&&typeof L==="object"&&!L.nodeType){J[F]=o.extend(E,K||(L.length!=null?[]:{}),L)}else{if(L!==g){J[F]=L}}}}}return J};var b=/z-?index|font-?weight|opacity|zoom|line-?height/i,q=document.defaultView||{},s=Object.prototype.toString;o.extend({noConflict:function(E){l.$=p;if(E){l.jQuery=y}return o},isFunction:function(E){return s.call(E)==="[object Function]"},isArray:function(E){return s.call(E)==="[object Array]"},isXMLDoc:function(E){return E.nodeType===9&&E.documentElement.nodeName!=="HTML"||!!E.ownerDocument&&o.isXMLDoc(E.ownerDocument)},globalEval:function(G){if(G&&/\S/.test(G)){var F=document.getElementsByTagName("head")[0]||document.documentElement,E=document.createElement("script");E.type="text/javascript";if(o.support.scriptEval){E.appendChild(document.createTextNode(G))}else{E.text=G}F.insertBefore(E,F.firstChild);F.removeChild(E)}},nodeName:function(F,E){return F.nodeName&&F.nodeName.toUpperCase()==E.toUpperCase()},each:function(G,K,F){var E,H=0,I=G.length;if(F){if(I===g){for(E in G){if(K.apply(G[E],F)===false){break}}}else{for(;H<I;){if(K.apply(G[H++],F)===false){break}}}}else{if(I===g){for(E in G){if(K.call(G[E],E,G[E])===false){break}}}else{for(var J=G[0];H<I&&K.call(J,H,J)!==false;J=G[++H]){}}}return G},prop:function(H,I,G,F,E){if(o.isFunction(I)){I=I.call(H,F)}return typeof I==="number"&&G=="curCSS"&&!b.test(E)?I+"px":I},className:{add:function(E,F){o.each((F||"").split(/\s+/),function(G,H){if(E.nodeType==1&&!o.className.has(E.className,H)){E.className+=(E.className?" ":"")+H}})},remove:function(E,F){if(E.nodeType==1){E.className=F!==g?o.grep(E.className.split(/\s+/),function(G){return !o.className.has(F,G)}).join(" "):""}},has:function(F,E){return F&&o.inArray(E,(F.className||F).toString().split(/\s+/))>-1}},swap:function(H,G,I){var E={};for(var F in G){E[F]=H.style[F];H.style[F]=G[F]}I.call(H);for(var F in G){H.style[F]=E[F]}},css:function(H,F,J,E){if(F=="width"||F=="height"){var L,G={position:"absolute",visibility:"hidden",display:"block"},K=F=="width"?["Left","Right"]:["Top","Bottom"];function I(){L=F=="width"?H.offsetWidth:H.offsetHeight;if(E==="border"){return}o.each(K,function(){if(!E){L-=parseFloat(o.curCSS(H,"padding"+this,true))||0}if(E==="margin"){L+=parseFloat(o.curCSS(H,"margin"+this,true))||0}else{L-=parseFloat(o.curCSS(H,"border"+this+"Width",true))||0}})}if(H.offsetWidth!==0){I()}else{o.swap(H,G,I)}return Math.max(0,Math.round(L))}return o.curCSS(H,F,J)},curCSS:function(I,F,G){var L,E=I.style;if(F=="opacity"&&!o.support.opacity){L=o.attr(E,"opacity");return L==""?"1":L}if(F.match(/float/i)){F=w}if(!G&&E&&E[F]){L=E[F]}else{if(q.getComputedStyle){if(F.match(/float/i)){F="float"}F=F.replace(/([A-Z])/g,"-$1").toLowerCase();var M=q.getComputedStyle(I,null);if(M){L=M.getPropertyValue(F)}if(F=="opacity"&&L==""){L="1"}}else{if(I.currentStyle){var J=F.replace(/\-(\w)/g,function(N,O){return O.toUpperCase()});L=I.currentStyle[F]||I.currentStyle[J];if(!/^\d+(px)?$/i.test(L)&&/^\d/.test(L)){var H=E.left,K=I.runtimeStyle.left;I.runtimeStyle.left=I.currentStyle.left;E.left=L||0;L=E.pixelLeft+"px";E.left=H;I.runtimeStyle.left=K}}}}return L},clean:function(F,K,I){K=K||document;if(typeof K.createElement==="undefined"){K=K.ownerDocument||K[0]&&K[0].ownerDocument||document}if(!I&&F.length===1&&typeof F[0]==="string"){var H=/^<(\w+)\s*\/?>$/.exec(F[0]);if(H){return[K.createElement(H[1])]}}var G=[],E=[],L=K.createElement("div");o.each(F,function(P,S){if(typeof S==="number"){S+=""}if(!S){return}if(typeof S==="string"){S=S.replace(/(<(\w+)[^>]*?)\/>/g,function(U,V,T){return T.match(/^(abbr|br|col|img|input|link|meta|param|hr|area|embed)$/i)?U:V+"></"+T+">"});var O=S.replace(/^\s+/,"").substring(0,10).toLowerCase();var Q=!O.indexOf("<opt")&&[1,"<select multiple='multiple'>","</select>"]||!O.indexOf("<leg")&&[1,"<fieldset>","</fieldset>"]||O.match(/^<(thead|tbody|tfoot|colg|cap)/)&&[1,"<table>","</table>"]||!O.indexOf("<tr")&&[2,"<table><tbody>","</tbody></table>"]||(!O.indexOf("<td")||!O.indexOf("<th"))&&[3,"<table><tbody><tr>","</tr></tbody></table>"]||!O.indexOf("<col")&&[2,"<table><tbody></tbody><colgroup>","</colgroup></table>"]||!o.support.htmlSerialize&&[1,"div<div>","</div>"]||[0,"",""];L.innerHTML=Q[1]+S+Q[2];while(Q[0]--){L=L.lastChild}if(!o.support.tbody){var R=/<tbody/i.test(S),N=!O.indexOf("<table")&&!R?L.firstChild&&L.firstChild.childNodes:Q[1]=="<table>"&&!R?L.childNodes:[];for(var M=N.length-1;M>=0;--M){if(o.nodeName(N[M],"tbody")&&!N[M].childNodes.length){N[M].parentNode.removeChild(N[M])}}}if(!o.support.leadingWhitespace&&/^\s/.test(S)){L.insertBefore(K.createTextNode(S.match(/^\s*/)[0]),L.firstChild)}S=o.makeArray(L.childNodes)}if(S.nodeType){G.push(S)}else{G=o.merge(G,S)}});if(I){for(var J=0;G[J];J++){if(o.nodeName(G[J],"script")&&(!G[J].type||G[J].type.toLowerCase()==="text/javascript")){E.push(G[J].parentNode?G[J].parentNode.removeChild(G[J]):G[J])}else{if(G[J].nodeType===1){G.splice.apply(G,[J+1,0].concat(o.makeArray(G[J].getElementsByTagName("script"))))}I.appendChild(G[J])}}return E}return G},attr:function(J,G,K){if(!J||J.nodeType==3||J.nodeType==8){return g}var H=!o.isXMLDoc(J),L=K!==g;G=H&&o.props[G]||G;if(J.tagName){var F=/href|src|style/.test(G);if(G=="selected"&&J.parentNode){J.parentNode.selectedIndex}if(G in J&&H&&!F){if(L){if(G=="type"&&o.nodeName(J,"input")&&J.parentNode){throw"type property can't be changed"}J[G]=K}if(o.nodeName(J,"form")&&J.getAttributeNode(G)){return J.getAttributeNode(G).nodeValue}if(G=="tabIndex"){var I=J.getAttributeNode("tabIndex");return I&&I.specified?I.value:J.nodeName.match(/(button|input|object|select|textarea)/i)?0:J.nodeName.match(/^(a|area)$/i)&&J.href?0:g}return J[G]}if(!o.support.style&&H&&G=="style"){return o.attr(J.style,"cssText",K)}if(L){J.setAttribute(G,""+K)}var E=!o.support.hrefNormalized&&H&&F?J.getAttribute(G,2):J.getAttribute(G);return E===null?g:E}if(!o.support.opacity&&G=="opacity"){if(L){J.zoom=1;J.filter=(J.filter||"").replace(/alpha\([^)]*\)/,"")+(parseInt(K)+""=="NaN"?"":"alpha(opacity="+K*100+")")}return J.filter&&J.filter.indexOf("opacity=")>=0?(parseFloat(J.filter.match(/opacity=([^)]*)/)[1])/100)+"":""}G=G.replace(/-([a-z])/ig,function(M,N){return N.toUpperCase()});if(L){J[G]=K}return J[G]},trim:function(E){return(E||"").replace(/^\s+|\s+$/g,"")},makeArray:function(G){var E=[];if(G!=null){var F=G.length;if(F==null||typeof G==="string"||o.isFunction(G)||G.setInterval){E[0]=G}else{while(F){E[--F]=G[F]}}}return E},inArray:function(G,H){for(var E=0,F=H.length;E<F;E++){if(H[E]===G){return E}}return -1},merge:function(H,E){var F=0,G,I=H.length;if(!o.support.getAll){while((G=E[F++])!=null){if(G.nodeType!=8){H[I++]=G}}}else{while((G=E[F++])!=null){H[I++]=G}}return H},unique:function(K){var F=[],E={};try{for(var G=0,H=K.length;G<H;G++){var J=o.data(K[G]);if(!E[J]){E[J]=true;F.push(K[G])}}}catch(I){F=K}return F},grep:function(F,J,E){var G=[];for(var H=0,I=F.length;H<I;H++){if(!E!=!J(F[H],H)){G.push(F[H])}}return G},map:function(E,J){var F=[];for(var G=0,H=E.length;G<H;G++){var I=J(E[G],G);if(I!=null){F[F.length]=I}}return F.concat.apply([],F)}});var C=navigator.userAgent.toLowerCase();o.browser={version:(C.match(/.+(?:rv|it|ra|ie)[\/: ]([\d.]+)/)||[0,"0"])[1],safari:/webkit/.test(C),opera:/opera/.test(C),msie:/msie/.test(C)&&!/opera/.test(C),mozilla:/mozilla/.test(C)&&!/(compatible|webkit)/.test(C)};o.each({parent:function(E){return E.parentNode},parents:function(E){return o.dir(E,"parentNode")},next:function(E){return o.nth(E,2,"nextSibling")},prev:function(E){return o.nth(E,2,"previousSibling")},nextAll:function(E){return o.dir(E,"nextSibling")},prevAll:function(E){return o.dir(E,"previousSibling")},siblings:function(E){return o.sibling(E.parentNode.firstChild,E)},children:function(E){return o.sibling(E.firstChild)},contents:function(E){return o.nodeName(E,"iframe")?E.contentDocument||E.contentWindow.document:o.makeArray(E.childNodes)}},function(E,F){o.fn[E]=function(G){var H=o.map(this,F);if(G&&typeof G=="string"){H=o.multiFilter(G,H)}return this.pushStack(o.unique(H),E,G)}});o.each({appendTo:"append",prependTo:"prepend",insertBefore:"before",insertAfter:"after",replaceAll:"replaceWith"},function(E,F){o.fn[E]=function(G){var J=[],L=o(G);for(var K=0,H=L.length;K<H;K++){var I=(K>0?this.clone(true):this).get();o.fn[F].apply(o(L[K]),I);J=J.concat(I)}return this.pushStack(J,E,G)}});o.each({removeAttr:function(E){o.attr(this,E,"");if(this.nodeType==1){this.removeAttribute(E)}},addClass:function(E){o.className.add(this,E)},removeClass:function(E){o.className.remove(this,E)},toggleClass:function(F,E){if(typeof E!=="boolean"){E=!o.className.has(this,F)}o.className[E?"add":"remove"](this,F)},remove:function(E){if(!E||o.filter(E,[this]).length){o("*",this).add([this]).each(function(){o.event.remove(this);o.removeData(this)});if(this.parentNode){this.parentNode.removeChild(this)}}},empty:function(){o(this).children().remove();while(this.firstChild){this.removeChild(this.firstChild)}}},function(E,F){o.fn[E]=function(){return this.each(F,arguments)}});function j(E,F){return E[0]&&parseInt(o.curCSS(E[0],F,true),10)||0}var h="jQuery"+e(),v=0,A={};o.extend({cache:{},data:function(F,E,G){F=F==l?A:F;var H=F[h];if(!H){H=F[h]=++v}if(E&&!o.cache[H]){o.cache[H]={}}if(G!==g){o.cache[H][E]=G}return E?o.cache[H][E]:H},removeData:function(F,E){F=F==l?A:F;var H=F[h];if(E){if(o.cache[H]){delete o.cache[H][E];E="";for(E in o.cache[H]){break}if(!E){o.removeData(F)}}}else{try{delete F[h]}catch(G){if(F.removeAttribute){F.removeAttribute(h)}}delete o.cache[H]}},queue:function(F,E,H){if(F){E=(E||"fx")+"queue";var G=o.data(F,E);if(!G||o.isArray(H)){G=o.data(F,E,o.makeArray(H))}else{if(H){G.push(H)}}}return G},dequeue:function(H,G){var E=o.queue(H,G),F=E.shift();if(!G||G==="fx"){F=E[0]}if(F!==g){F.call(H)}}});o.fn.extend({data:function(E,G){var H=E.split(".");H[1]=H[1]?"."+H[1]:"";if(G===g){var F=this.triggerHandler("getData"+H[1]+"!",[H[0]]);if(F===g&&this.length){F=o.data(this[0],E)}return F===g&&H[1]?this.data(H[0]):F}else{return this.trigger("setData"+H[1]+"!",[H[0],G]).each(function(){o.data(this,E,G)})}},removeData:function(E){return this.each(function(){o.removeData(this,E)})},queue:function(E,F){if(typeof E!=="string"){F=E;E="fx"}if(F===g){return o.queue(this[0],E)}return this.each(function(){var G=o.queue(this,E,F);if(E=="fx"&&G.length==1){G[0].call(this)}})},dequeue:function(E){return this.each(function(){o.dequeue(this,E)})}});
+/*
+ * Sizzle CSS Selector Engine - v0.9.3
+ * Copyright 2009, The Dojo Foundation
+ * Released under the MIT, BSD, and GPL Licenses.
+ * More information: http://sizzlejs.com/
+ */
+(function(){var R=/((?:\((?:\([^()]+\)|[^()]+)+\)|\[(?:\[[^[\]]*\]|['"][^'"]*['"]|[^[\]'"]+)+\]|\\.|[^ >+~,(\[\\]+)+|[>+~])(\s*,\s*)?/g,L=0,H=Object.prototype.toString;var F=function(Y,U,ab,ac){ab=ab||[];U=U||document;if(U.nodeType!==1&&U.nodeType!==9){return[]}if(!Y||typeof Y!=="string"){return ab}var Z=[],W,af,ai,T,ad,V,X=true;R.lastIndex=0;while((W=R.exec(Y))!==null){Z.push(W[1]);if(W[2]){V=RegExp.rightContext;break}}if(Z.length>1&&M.exec(Y)){if(Z.length===2&&I.relative[Z[0]]){af=J(Z[0]+Z[1],U)}else{af=I.relative[Z[0]]?[U]:F(Z.shift(),U);while(Z.length){Y=Z.shift();if(I.relative[Y]){Y+=Z.shift()}af=J(Y,af)}}}else{var ae=ac?{expr:Z.pop(),set:E(ac)}:F.find(Z.pop(),Z.length===1&&U.parentNode?U.parentNode:U,Q(U));af=F.filter(ae.expr,ae.set);if(Z.length>0){ai=E(af)}else{X=false}while(Z.length){var ah=Z.pop(),ag=ah;if(!I.relative[ah]){ah=""}else{ag=Z.pop()}if(ag==null){ag=U}I.relative[ah](ai,ag,Q(U))}}if(!ai){ai=af}if(!ai){throw"Syntax error, unrecognized expression: "+(ah||Y)}if(H.call(ai)==="[object Array]"){if(!X){ab.push.apply(ab,ai)}else{if(U.nodeType===1){for(var aa=0;ai[aa]!=null;aa++){if(ai[aa]&&(ai[aa]===true||ai[aa].nodeType===1&&K(U,ai[aa]))){ab.push(af[aa])}}}else{for(var aa=0;ai[aa]!=null;aa++){if(ai[aa]&&ai[aa].nodeType===1){ab.push(af[aa])}}}}}else{E(ai,ab)}if(V){F(V,U,ab,ac);if(G){hasDuplicate=false;ab.sort(G);if(hasDuplicate){for(var aa=1;aa<ab.length;aa++){if(ab[aa]===ab[aa-1]){ab.splice(aa--,1)}}}}}return ab};F.matches=function(T,U){return F(T,null,null,U)};F.find=function(aa,T,ab){var Z,X;if(!aa){return[]}for(var W=0,V=I.order.length;W<V;W++){var Y=I.order[W],X;if((X=I.match[Y].exec(aa))){var U=RegExp.leftContext;if(U.substr(U.length-1)!=="\\"){X[1]=(X[1]||"").replace(/\\/g,"");Z=I.find[Y](X,T,ab);if(Z!=null){aa=aa.replace(I.match[Y],"");break}}}}if(!Z){Z=T.getElementsByTagName("*")}return{set:Z,expr:aa}};F.filter=function(ad,ac,ag,W){var V=ad,ai=[],aa=ac,Y,T,Z=ac&&ac[0]&&Q(ac[0]);while(ad&&ac.length){for(var ab in I.filter){if((Y=I.match[ab].exec(ad))!=null){var U=I.filter[ab],ah,af;T=false;if(aa==ai){ai=[]}if(I.preFilter[ab]){Y=I.preFilter[ab](Y,aa,ag,ai,W,Z);if(!Y){T=ah=true}else{if(Y===true){continue}}}if(Y){for(var X=0;(af=aa[X])!=null;X++){if(af){ah=U(af,Y,X,aa);var ae=W^!!ah;if(ag&&ah!=null){if(ae){T=true}else{aa[X]=false}}else{if(ae){ai.push(af);T=true}}}}}if(ah!==g){if(!ag){aa=ai}ad=ad.replace(I.match[ab],"");if(!T){return[]}break}}}if(ad==V){if(T==null){throw"Syntax error, unrecognized expression: "+ad}else{break}}V=ad}return aa};var I=F.selectors={order:["ID","NAME","TAG"],match:{ID:/#((?:[\w\u00c0-\uFFFF_-]|\\.)+)/,CLASS:/\.((?:[\w\u00c0-\uFFFF_-]|\\.)+)/,NAME:/\[name=['"]*((?:[\w\u00c0-\uFFFF_-]|\\.)+)['"]*\]/,ATTR:/\[\s*((?:[\w\u00c0-\uFFFF_-]|\\.)+)\s*(?:(\S?=)\s*(['"]*)(.*?)\3|)\s*\]/,TAG:/^((?:[\w\u00c0-\uFFFF\*_-]|\\.)+)/,CHILD:/:(only|nth|last|first)-child(?:\((even|odd|[\dn+-]*)\))?/,POS:/:(nth|eq|gt|lt|first|last|even|odd)(?:\((\d*)\))?(?=[^-]|$)/,PSEUDO:/:((?:[\w\u00c0-\uFFFF_-]|\\.)+)(?:\((['"]*)((?:\([^\)]+\)|[^\2\(\)]*)+)\2\))?/},attrMap:{"class":"className","for":"htmlFor"},attrHandle:{href:function(T){return T.getAttribute("href")}},relative:{"+":function(aa,T,Z){var X=typeof T==="string",ab=X&&!/\W/.test(T),Y=X&&!ab;if(ab&&!Z){T=T.toUpperCase()}for(var W=0,V=aa.length,U;W<V;W++){if((U=aa[W])){while((U=U.previousSibling)&&U.nodeType!==1){}aa[W]=Y||U&&U.nodeName===T?U||false:U===T}}if(Y){F.filter(T,aa,true)}},">":function(Z,U,aa){var X=typeof U==="string";if(X&&!/\W/.test(U)){U=aa?U:U.toUpperCase();for(var V=0,T=Z.length;V<T;V++){var Y=Z[V];if(Y){var W=Y.parentNode;Z[V]=W.nodeName===U?W:false}}}else{for(var V=0,T=Z.length;V<T;V++){var Y=Z[V];if(Y){Z[V]=X?Y.parentNode:Y.parentNode===U}}if(X){F.filter(U,Z,true)}}},"":function(W,U,Y){var V=L++,T=S;if(!U.match(/\W/)){var X=U=Y?U:U.toUpperCase();T=P}T("parentNode",U,V,W,X,Y)},"~":function(W,U,Y){var V=L++,T=S;if(typeof U==="string"&&!U.match(/\W/)){var X=U=Y?U:U.toUpperCase();T=P}T("previousSibling",U,V,W,X,Y)}},find:{ID:function(U,V,W){if(typeof V.getElementById!=="undefined"&&!W){var T=V.getElementById(U[1]);return T?[T]:[]}},NAME:function(V,Y,Z){if(typeof Y.getElementsByName!=="undefined"){var U=[],X=Y.getElementsByName(V[1]);for(var W=0,T=X.length;W<T;W++){if(X[W].getAttribute("name")===V[1]){U.push(X[W])}}return U.length===0?null:U}},TAG:function(T,U){return U.getElementsByTagName(T[1])}},preFilter:{CLASS:function(W,U,V,T,Z,aa){W=" "+W[1].replace(/\\/g,"")+" ";if(aa){return W}for(var X=0,Y;(Y=U[X])!=null;X++){if(Y){if(Z^(Y.className&&(" "+Y.className+" ").indexOf(W)>=0)){if(!V){T.push(Y)}}else{if(V){U[X]=false}}}}return false},ID:function(T){return T[1].replace(/\\/g,"")},TAG:function(U,T){for(var V=0;T[V]===false;V++){}return T[V]&&Q(T[V])?U[1]:U[1].toUpperCase()},CHILD:function(T){if(T[1]=="nth"){var U=/(-?)(\d*)n((?:\+|-)?\d*)/.exec(T[2]=="even"&&"2n"||T[2]=="odd"&&"2n+1"||!/\D/.test(T[2])&&"0n+"+T[2]||T[2]);T[2]=(U[1]+(U[2]||1))-0;T[3]=U[3]-0}T[0]=L++;return T},ATTR:function(X,U,V,T,Y,Z){var W=X[1].replace(/\\/g,"");if(!Z&&I.attrMap[W]){X[1]=I.attrMap[W]}if(X[2]==="~="){X[4]=" "+X[4]+" "}return X},PSEUDO:function(X,U,V,T,Y){if(X[1]==="not"){if(X[3].match(R).length>1||/^\w/.test(X[3])){X[3]=F(X[3],null,null,U)}else{var W=F.filter(X[3],U,V,true^Y);if(!V){T.push.apply(T,W)}return false}}else{if(I.match.POS.test(X[0])||I.match.CHILD.test(X[0])){return true}}return X},POS:function(T){T.unshift(true);return T}},filters:{enabled:function(T){return T.disabled===false&&T.type!=="hidden"},disabled:function(T){return T.disabled===true},checked:function(T){return T.checked===true},selected:function(T){T.parentNode.selectedIndex;return T.selected===true},parent:function(T){return !!T.firstChild},empty:function(T){return !T.firstChild},has:function(V,U,T){return !!F(T[3],V).length},header:function(T){return/h\d/i.test(T.nodeName)},text:function(T){return"text"===T.type},radio:function(T){return"radio"===T.type},checkbox:function(T){return"checkbox"===T.type},file:function(T){return"file"===T.type},password:function(T){return"password"===T.type},submit:function(T){return"submit"===T.type},image:function(T){return"image"===T.type},reset:function(T){return"reset"===T.type},button:function(T){return"button"===T.type||T.nodeName.toUpperCase()==="BUTTON"},input:function(T){return/input|select|textarea|button/i.test(T.nodeName)}},setFilters:{first:function(U,T){return T===0},last:function(V,U,T,W){return U===W.length-1},even:function(U,T){return T%2===0},odd:function(U,T){return T%2===1},lt:function(V,U,T){return U<T[3]-0},gt:function(V,U,T){return U>T[3]-0},nth:function(V,U,T){return T[3]-0==U},eq:function(V,U,T){return T[3]-0==U}},filter:{PSEUDO:function(Z,V,W,aa){var U=V[1],X=I.filters[U];if(X){return X(Z,W,V,aa)}else{if(U==="contains"){return(Z.textContent||Z.innerText||"").indexOf(V[3])>=0}else{if(U==="not"){var Y=V[3];for(var W=0,T=Y.length;W<T;W++){if(Y[W]===Z){return false}}return true}}}},CHILD:function(T,W){var Z=W[1],U=T;switch(Z){case"only":case"first":while(U=U.previousSibling){if(U.nodeType===1){return false}}if(Z=="first"){return true}U=T;case"last":while(U=U.nextSibling){if(U.nodeType===1){return false}}return true;case"nth":var V=W[2],ac=W[3];if(V==1&&ac==0){return true}var Y=W[0],ab=T.parentNode;if(ab&&(ab.sizcache!==Y||!T.nodeIndex)){var X=0;for(U=ab.firstChild;U;U=U.nextSibling){if(U.nodeType===1){U.nodeIndex=++X}}ab.sizcache=Y}var aa=T.nodeIndex-ac;if(V==0){return aa==0}else{return(aa%V==0&&aa/V>=0)}}},ID:function(U,T){return U.nodeType===1&&U.getAttribute("id")===T},TAG:function(U,T){return(T==="*"&&U.nodeType===1)||U.nodeName===T},CLASS:function(U,T){return(" "+(U.className||U.getAttribute("class"))+" ").indexOf(T)>-1},ATTR:function(Y,W){var V=W[1],T=I.attrHandle[V]?I.attrHandle[V](Y):Y[V]!=null?Y[V]:Y.getAttribute(V),Z=T+"",X=W[2],U=W[4];return T==null?X==="!=":X==="="?Z===U:X==="*="?Z.indexOf(U)>=0:X==="~="?(" "+Z+" ").indexOf(U)>=0:!U?Z&&T!==false:X==="!="?Z!=U:X==="^="?Z.indexOf(U)===0:X==="$="?Z.substr(Z.length-U.length)===U:X==="|="?Z===U||Z.substr(0,U.length+1)===U+"-":false},POS:function(X,U,V,Y){var T=U[2],W=I.setFilters[T];if(W){return W(X,V,U,Y)}}}};var M=I.match.POS;for(var O in I.match){I.match[O]=RegExp(I.match[O].source+/(?![^\[]*\])(?![^\(]*\))/.source)}var E=function(U,T){U=Array.prototype.slice.call(U);if(T){T.push.apply(T,U);return T}return U};try{Array.prototype.slice.call(document.documentElement.childNodes)}catch(N){E=function(X,W){var U=W||[];if(H.call(X)==="[object Array]"){Array.prototype.push.apply(U,X)}else{if(typeof X.length==="number"){for(var V=0,T=X.length;V<T;V++){U.push(X[V])}}else{for(var V=0;X[V];V++){U.push(X[V])}}}return U}}var G;if(document.documentElement.compareDocumentPosition){G=function(U,T){var V=U.compareDocumentPosition(T)&4?-1:U===T?0:1;if(V===0){hasDuplicate=true}return V}}else{if("sourceIndex" in document.documentElement){G=function(U,T){var V=U.sourceIndex-T.sourceIndex;if(V===0){hasDuplicate=true}return V}}else{if(document.createRange){G=function(W,U){var V=W.ownerDocument.createRange(),T=U.ownerDocument.createRange();V.selectNode(W);V.collapse(true);T.selectNode(U);T.collapse(true);var X=V.compareBoundaryPoints(Range.START_TO_END,T);if(X===0){hasDuplicate=true}return X}}}}(function(){var U=document.createElement("form"),V="script"+(new Date).getTime();U.innerHTML="<input name='"+V+"'/>";var T=document.documentElement;T.insertBefore(U,T.firstChild);if(!!document.getElementById(V)){I.find.ID=function(X,Y,Z){if(typeof Y.getElementById!=="undefined"&&!Z){var W=Y.getElementById(X[1]);return W?W.id===X[1]||typeof W.getAttributeNode!=="undefined"&&W.getAttributeNode("id").nodeValue===X[1]?[W]:g:[]}};I.filter.ID=function(Y,W){var X=typeof Y.getAttributeNode!=="undefined"&&Y.getAttributeNode("id");return Y.nodeType===1&&X&&X.nodeValue===W}}T.removeChild(U)})();(function(){var T=document.createElement("div");T.appendChild(document.createComment(""));if(T.getElementsByTagName("*").length>0){I.find.TAG=function(U,Y){var X=Y.getElementsByTagName(U[1]);if(U[1]==="*"){var W=[];for(var V=0;X[V];V++){if(X[V].nodeType===1){W.push(X[V])}}X=W}return X}}T.innerHTML="<a href='#'></a>";if(T.firstChild&&typeof T.firstChild.getAttribute!=="undefined"&&T.firstChild.getAttribute("href")!=="#"){I.attrHandle.href=function(U){return U.getAttribute("href",2)}}})();if(document.querySelectorAll){(function(){var T=F,U=document.createElement("div");U.innerHTML="<p class='TEST'></p>";if(U.querySelectorAll&&U.querySelectorAll(".TEST").length===0){return}F=function(Y,X,V,W){X=X||document;if(!W&&X.nodeType===9&&!Q(X)){try{return E(X.querySelectorAll(Y),V)}catch(Z){}}return T(Y,X,V,W)};F.find=T.find;F.filter=T.filter;F.selectors=T.selectors;F.matches=T.matches})()}if(document.getElementsByClassName&&document.documentElement.getElementsByClassName){(function(){var T=document.createElement("div");T.innerHTML="<div class='test e'></div><div class='test'></div>";if(T.getElementsByClassName("e").length===0){return}T.lastChild.className="e";if(T.getElementsByClassName("e").length===1){return}I.order.splice(1,0,"CLASS");I.find.CLASS=function(U,V,W){if(typeof V.getElementsByClassName!=="undefined"&&!W){return V.getElementsByClassName(U[1])}}})()}function P(U,Z,Y,ad,aa,ac){var ab=U=="previousSibling"&&!ac;for(var W=0,V=ad.length;W<V;W++){var T=ad[W];if(T){if(ab&&T.nodeType===1){T.sizcache=Y;T.sizset=W}T=T[U];var X=false;while(T){if(T.sizcache===Y){X=ad[T.sizset];break}if(T.nodeType===1&&!ac){T.sizcache=Y;T.sizset=W}if(T.nodeName===Z){X=T;break}T=T[U]}ad[W]=X}}}function S(U,Z,Y,ad,aa,ac){var ab=U=="previousSibling"&&!ac;for(var W=0,V=ad.length;W<V;W++){var T=ad[W];if(T){if(ab&&T.nodeType===1){T.sizcache=Y;T.sizset=W}T=T[U];var X=false;while(T){if(T.sizcache===Y){X=ad[T.sizset];break}if(T.nodeType===1){if(!ac){T.sizcache=Y;T.sizset=W}if(typeof Z!=="string"){if(T===Z){X=true;break}}else{if(F.filter(Z,[T]).length>0){X=T;break}}}T=T[U]}ad[W]=X}}}var K=document.compareDocumentPosition?function(U,T){return U.compareDocumentPosition(T)&16}:function(U,T){return U!==T&&(U.contains?U.contains(T):true)};var Q=function(T){return T.nodeType===9&&T.documentElement.nodeName!=="HTML"||!!T.ownerDocument&&Q(T.ownerDocument)};var J=function(T,aa){var W=[],X="",Y,V=aa.nodeType?[aa]:aa;while((Y=I.match.PSEUDO.exec(T))){X+=Y[0];T=T.replace(I.match.PSEUDO,"")}T=I.relative[T]?T+"*":T;for(var Z=0,U=V.length;Z<U;Z++){F(T,V[Z],W)}return F.filter(X,W)};o.find=F;o.filter=F.filter;o.expr=F.selectors;o.expr[":"]=o.expr.filters;F.selectors.filters.hidden=function(T){return T.offsetWidth===0||T.offsetHeight===0};F.selectors.filters.visible=function(T){return T.offsetWidth>0||T.offsetHeight>0};F.selectors.filters.animated=function(T){return o.grep(o.timers,function(U){return T===U.elem}).length};o.multiFilter=function(V,T,U){if(U){V=":not("+V+")"}return F.matches(V,T)};o.dir=function(V,U){var T=[],W=V[U];while(W&&W!=document){if(W.nodeType==1){T.push(W)}W=W[U]}return T};o.nth=function(X,T,V,W){T=T||1;var U=0;for(;X;X=X[V]){if(X.nodeType==1&&++U==T){break}}return X};o.sibling=function(V,U){var T=[];for(;V;V=V.nextSibling){if(V.nodeType==1&&V!=U){T.push(V)}}return T};return;l.Sizzle=F})();o.event={add:function(I,F,H,K){if(I.nodeType==3||I.nodeType==8){return}if(I.setInterval&&I!=l){I=l}if(!H.guid){H.guid=this.guid++}if(K!==g){var G=H;H=this.proxy(G);H.data=K}var E=o.data(I,"events")||o.data(I,"events",{}),J=o.data(I,"handle")||o.data(I,"handle",function(){return typeof o!=="undefined"&&!o.event.triggered?o.event.handle.apply(arguments.callee.elem,arguments):g});J.elem=I;o.each(F.split(/\s+/),function(M,N){var O=N.split(".");N=O.shift();H.type=O.slice().sort().join(".");var L=E[N];if(o.event.specialAll[N]){o.event.specialAll[N].setup.call(I,K,O)}if(!L){L=E[N]={};if(!o.event.special[N]||o.event.special[N].setup.call(I,K,O)===false){if(I.addEventListener){I.addEventListener(N,J,false)}else{if(I.attachEvent){I.attachEvent("on"+N,J)}}}}L[H.guid]=H;o.event.global[N]=true});I=null},guid:1,global:{},remove:function(K,H,J){if(K.nodeType==3||K.nodeType==8){return}var G=o.data(K,"events"),F,E;if(G){if(H===g||(typeof H==="string"&&H.charAt(0)==".")){for(var I in G){this.remove(K,I+(H||""))}}else{if(H.type){J=H.handler;H=H.type}o.each(H.split(/\s+/),function(M,O){var Q=O.split(".");O=Q.shift();var N=RegExp("(^|\\.)"+Q.slice().sort().join(".*\\.")+"(\\.|$)");if(G[O]){if(J){delete G[O][J.guid]}else{for(var P in G[O]){if(N.test(G[O][P].type)){delete G[O][P]}}}if(o.event.specialAll[O]){o.event.specialAll[O].teardown.call(K,Q)}for(F in G[O]){break}if(!F){if(!o.event.special[O]||o.event.special[O].teardown.call(K,Q)===false){if(K.removeEventListener){K.removeEventListener(O,o.data(K,"handle"),false)}else{if(K.detachEvent){K.detachEvent("on"+O,o.data(K,"handle"))}}}F=null;delete G[O]}}})}for(F in G){break}if(!F){var L=o.data(K,"handle");if(L){L.elem=null}o.removeData(K,"events");o.removeData(K,"handle")}}},trigger:function(I,K,H,E){var G=I.type||I;if(!E){I=typeof I==="object"?I[h]?I:o.extend(o.Event(G),I):o.Event(G);if(G.indexOf("!")>=0){I.type=G=G.slice(0,-1);I.exclusive=true}if(!H){I.stopPropagation();if(this.global[G]){o.each(o.cache,function(){if(this.events&&this.events[G]){o.event.trigger(I,K,this.handle.elem)}})}}if(!H||H.nodeType==3||H.nodeType==8){return g}I.result=g;I.target=H;K=o.makeArray(K);K.unshift(I)}I.currentTarget=H;var J=o.data(H,"handle");if(J){J.apply(H,K)}if((!H[G]||(o.nodeName(H,"a")&&G=="click"))&&H["on"+G]&&H["on"+G].apply(H,K)===false){I.result=false}if(!E&&H[G]&&!I.isDefaultPrevented()&&!(o.nodeName(H,"a")&&G=="click")){this.triggered=true;try{H[G]()}catch(L){}}this.triggered=false;if(!I.isPropagationStopped()){var F=H.parentNode||H.ownerDocument;if(F){o.event.trigger(I,K,F,true)}}},handle:function(K){var J,E;K=arguments[0]=o.event.fix(K||l.event);K.currentTarget=this;var L=K.type.split(".");K.type=L.shift();J=!L.length&&!K.exclusive;var I=RegExp("(^|\\.)"+L.slice().sort().join(".*\\.")+"(\\.|$)");E=(o.data(this,"events")||{})[K.type];for(var G in E){var H=E[G];if(J||I.test(H.type)){K.handler=H;K.data=H.data;var F=H.apply(this,arguments);if(F!==g){K.result=F;if(F===false){K.preventDefault();K.stopPropagation()}}if(K.isImmediatePropagationStopped()){break}}}},props:"altKey attrChange attrName bubbles button cancelable charCode clientX clientY ctrlKey currentTarget data detail eventPhase fromElement handler keyCode metaKey newValue originalTarget pageX pageY prevValue relatedNode relatedTarget screenX screenY shiftKey srcElement target toElement view wheelDelta which".split(" "),fix:function(H){if(H[h]){return H}var F=H;H=o.Event(F);for(var G=this.props.length,J;G;){J=this.props[--G];H[J]=F[J]}if(!H.target){H.target=H.srcElement||document}if(H.target.nodeType==3){H.target=H.target.parentNode}if(!H.relatedTarget&&H.fromElement){H.relatedTarget=H.fromElement==H.target?H.toElement:H.fromElement}if(H.pageX==null&&H.clientX!=null){var I=document.documentElement,E=document.body;H.pageX=H.clientX+(I&&I.scrollLeft||E&&E.scrollLeft||0)-(I.clientLeft||0);H.pageY=H.clientY+(I&&I.scrollTop||E&&E.scrollTop||0)-(I.clientTop||0)}if(!H.which&&((H.charCode||H.charCode===0)?H.charCode:H.keyCode)){H.which=H.charCode||H.keyCode}if(!H.metaKey&&H.ctrlKey){H.metaKey=H.ctrlKey}if(!H.which&&H.button){H.which=(H.button&1?1:(H.button&2?3:(H.button&4?2:0)))}return H},proxy:function(F,E){E=E||function(){return F.apply(this,arguments)};E.guid=F.guid=F.guid||E.guid||this.guid++;return E},special:{ready:{setup:B,teardown:function(){}}},specialAll:{live:{setup:function(E,F){o.event.add(this,F[0],c)},teardown:function(G){if(G.length){var E=0,F=RegExp("(^|\\.)"+G[0]+"(\\.|$)");o.each((o.data(this,"events").live||{}),function(){if(F.test(this.type)){E++}});if(E<1){o.event.remove(this,G[0],c)}}}}}};o.Event=function(E){if(!this.preventDefault){return new o.Event(E)}if(E&&E.type){this.originalEvent=E;this.type=E.type}else{this.type=E}this.timeStamp=e();this[h]=true};function k(){return false}function u(){return true}o.Event.prototype={preventDefault:function(){this.isDefaultPrevented=u;var E=this.originalEvent;if(!E){return}if(E.preventDefault){E.preventDefault()}E.returnValue=false},stopPropagation:function(){this.isPropagationStopped=u;var E=this.originalEvent;if(!E){return}if(E.stopPropagation){E.stopPropagation()}E.cancelBubble=true},stopImmediatePropagation:function(){this.isImmediatePropagationStopped=u;this.stopPropagation()},isDefaultPrevented:k,isPropagationStopped:k,isImmediatePropagationStopped:k};var a=function(F){var E=F.relatedTarget;while(E&&E!=this){try{E=E.parentNode}catch(G){E=this}}if(E!=this){F.type=F.data;o.event.handle.apply(this,arguments)}};o.each({mouseover:"mouseenter",mouseout:"mouseleave"},function(F,E){o.event.special[E]={setup:function(){o.event.add(this,F,a,E)},teardown:function(){o.event.remove(this,F,a)}}});o.fn.extend({bind:function(F,G,E){return F=="unload"?this.one(F,G,E):this.each(function(){o.event.add(this,F,E||G,E&&G)})},one:function(G,H,F){var E=o.event.proxy(F||H,function(I){o(this).unbind(I,E);return(F||H).apply(this,arguments)});return this.each(function(){o.event.add(this,G,E,F&&H)})},unbind:function(F,E){return this.each(function(){o.event.remove(this,F,E)})},trigger:function(E,F){return this.each(function(){o.event.trigger(E,F,this)})},triggerHandler:function(E,G){if(this[0]){var F=o.Event(E);F.preventDefault();F.stopPropagation();o.event.trigger(F,G,this[0]);return F.result}},toggle:function(G){var E=arguments,F=1;while(F<E.length){o.event.proxy(G,E[F++])}return this.click(o.event.proxy(G,function(H){this.lastToggle=(this.lastToggle||0)%F;H.preventDefault();return E[this.lastToggle++].apply(this,arguments)||false}))},hover:function(E,F){return this.mouseenter(E).mouseleave(F)},ready:function(E){B();if(o.isReady){E.call(document,o)}else{o.readyList.push(E)}return this},live:function(G,F){var E=o.event.proxy(F);E.guid+=this.selector+G;o(document).bind(i(G,this.selector),this.selector,E);return this},die:function(F,E){o(document).unbind(i(F,this.selector),E?{guid:E.guid+this.selector+F}:null);return this}});function c(H){var E=RegExp("(^|\\.)"+H.type+"(\\.|$)"),G=true,F=[];o.each(o.data(this,"events").live||[],function(I,J){if(E.test(J.type)){var K=o(H.target).closest(J.data)[0];if(K){F.push({elem:K,fn:J})}}});F.sort(function(J,I){return o.data(J.elem,"closest")-o.data(I.elem,"closest")});o.each(F,function(){if(this.fn.call(this.elem,H,this.fn.data)===false){return(G=false)}});return G}function i(F,E){return["live",F,E.replace(/\./g,"`").replace(/ /g,"|")].join(".")}o.extend({isReady:false,readyList:[],ready:function(){if(!o.isReady){o.isReady=true;if(o.readyList){o.each(o.readyList,function(){this.call(document,o)});o.readyList=null}o(document).triggerHandler("ready")}}});var x=false;function B(){if(x){return}x=true;if(document.addEventListener){document.addEventListener("DOMContentLoaded",function(){document.removeEventListener("DOMContentLoaded",arguments.callee,false);o.ready()},false)}else{if(document.attachEvent){document.attachEvent("onreadystatechange",function(){if(document.readyState==="complete"){document.detachEvent("onreadystatechange",arguments.callee);o.ready()}});if(document.documentElement.doScroll&&l==l.top){(function(){if(o.isReady){return}try{document.documentElement.doScroll("left")}catch(E){setTimeout(arguments.callee,0);return}o.ready()})()}}}o.event.add(l,"load",o.ready)}o.each(("blur,focus,load,resize,scroll,unload,click,dblclick,mousedown,mouseup,mousemove,mouseover,mouseout,mouseenter,mouseleave,change,select,submit,keydown,keypress,keyup,error").split(","),function(F,E){o.fn[E]=function(G){return G?this.bind(E,G):this.trigger(E)}});o(l).bind("unload",function(){for(var E in o.cache){if(E!=1&&o.cache[E].handle){o.event.remove(o.cache[E].handle.elem)}}});(function(){o.support={};var F=document.documentElement,G=document.createElement("script"),K=document.createElement("div"),J="script"+(new Date).getTime();K.style.display="none";K.innerHTML=' <link/><table></table><a href="/a" style="color:red;float:left;opacity:.5;">a</a><select><option>text</option></select><object><param/></object>';var H=K.getElementsByTagName("*"),E=K.getElementsByTagName("a")[0];if(!H||!H.length||!E){return}o.support={leadingWhitespace:K.firstChild.nodeType==3,tbody:!K.getElementsByTagName("tbody").length,objectAll:!!K.getElementsByTagName("object")[0].getElementsByTagName("*").length,htmlSerialize:!!K.getElementsByTagName("link").length,style:/red/.test(E.getAttribute("style")),hrefNormalized:E.getAttribute("href")==="/a",opacity:E.style.opacity==="0.5",cssFloat:!!E.style.cssFloat,scriptEval:false,noCloneEvent:true,boxModel:null};G.type="text/javascript";try{G.appendChild(document.createTextNode("window."+J+"=1;"))}catch(I){}F.insertBefore(G,F.firstChild);if(l[J]){o.support.scriptEval=true;delete l[J]}F.removeChild(G);if(K.attachEvent&&K.fireEvent){K.attachEvent("onclick",function(){o.support.noCloneEvent=false;K.detachEvent("onclick",arguments.callee)});K.cloneNode(true).fireEvent("onclick")}o(function(){var L=document.createElement("div");L.style.width=L.style.paddingLeft="1px";document.body.appendChild(L);o.boxModel=o.support.boxModel=L.offsetWidth===2;document.body.removeChild(L).style.display="none"})})();var w=o.support.cssFloat?"cssFloat":"styleFloat";o.props={"for":"htmlFor","class":"className","float":w,cssFloat:w,styleFloat:w,readonly:"readOnly",maxlength:"maxLength",cellspacing:"cellSpacing",rowspan:"rowSpan",tabindex:"tabIndex"};o.fn.extend({_load:o.fn.load,load:function(G,J,K){if(typeof G!=="string"){return this._load(G)}var I=G.indexOf(" ");if(I>=0){var E=G.slice(I,G.length);G=G.slice(0,I)}var H="GET";if(J){if(o.isFunction(J)){K=J;J=null}else{if(typeof J==="object"){J=o.param(J);H="POST"}}}var F=this;o.ajax({url:G,type:H,dataType:"html",data:J,complete:function(M,L){if(L=="success"||L=="notmodified"){F.html(E?o("<div/>").append(M.responseText.replace(/<script(.|\s)*?\/script>/g,"")).find(E):M.responseText)}if(K){F.each(K,[M.responseText,L,M])}}});return this},serialize:function(){return o.param(this.serializeArray())},serializeArray:function(){return this.map(function(){return this.elements?o.makeArray(this.elements):this}).filter(function(){return this.name&&!this.disabled&&(this.checked||/select|textarea/i.test(this.nodeName)||/text|hidden|password|search/i.test(this.type))}).map(function(E,F){var G=o(this).val();return G==null?null:o.isArray(G)?o.map(G,function(I,H){return{name:F.name,value:I}}):{name:F.name,value:G}}).get()}});o.each("ajaxStart,ajaxStop,ajaxComplete,ajaxError,ajaxSuccess,ajaxSend".split(","),function(E,F){o.fn[F]=function(G){return this.bind(F,G)}});var r=e();o.extend({get:function(E,G,H,F){if(o.isFunction(G)){H=G;G=null}return o.ajax({type:"GET",url:E,data:G,success:H,dataType:F})},getScript:function(E,F){return o.get(E,null,F,"script")},getJSON:function(E,F,G){return o.get(E,F,G,"json")},post:function(E,G,H,F){if(o.isFunction(G)){H=G;G={}}return o.ajax({type:"POST",url:E,data:G,success:H,dataType:F})},ajaxSetup:function(E){o.extend(o.ajaxSettings,E)},ajaxSettings:{url:location.href,global:true,type:"GET",contentType:"application/x-www-form-urlencoded",processData:true,async:true,xhr:function(){return l.ActiveXObject?new ActiveXObject("Microsoft.XMLHTTP"):new XMLHttpRequest()},accepts:{xml:"application/xml, text/xml",html:"text/html",script:"text/javascript, application/javascript",json:"application/json, text/javascript",text:"text/plain",_default:"*/*"}},lastModified:{},ajax:function(M){M=o.extend(true,M,o.extend(true,{},o.ajaxSettings,M));var W,F=/=\?(&|$)/g,R,V,G=M.type.toUpperCase();if(M.data&&M.processData&&typeof M.data!=="string"){M.data=o.param(M.data)}if(M.dataType=="jsonp"){if(G=="GET"){if(!M.url.match(F)){M.url+=(M.url.match(/\?/)?"&":"?")+(M.jsonp||"callback")+"=?"}}else{if(!M.data||!M.data.match(F)){M.data=(M.data?M.data+"&":"")+(M.jsonp||"callback")+"=?"}}M.dataType="json"}if(M.dataType=="json"&&(M.data&&M.data.match(F)||M.url.match(F))){W="jsonp"+r++;if(M.data){M.data=(M.data+"").replace(F,"="+W+"$1")}M.url=M.url.replace(F,"="+W+"$1");M.dataType="script";l[W]=function(X){V=X;I();L();l[W]=g;try{delete l[W]}catch(Y){}if(H){H.removeChild(T)}}}if(M.dataType=="script"&&M.cache==null){M.cache=false}if(M.cache===false&&G=="GET"){var E=e();var U=M.url.replace(/(\?|&)_=.*?(&|$)/,"$1_="+E+"$2");M.url=U+((U==M.url)?(M.url.match(/\?/)?"&":"?")+"_="+E:"")}if(M.data&&G=="GET"){M.url+=(M.url.match(/\?/)?"&":"?")+M.data;M.data=null}if(M.global&&!o.active++){o.event.trigger("ajaxStart")}var Q=/^(\w+:)?\/\/([^\/?#]+)/.exec(M.url);if(M.dataType=="script"&&G=="GET"&&Q&&(Q[1]&&Q[1]!=location.protocol||Q[2]!=location.host)){var H=document.getElementsByTagName("head")[0];var T=document.createElement("script");T.src=M.url;if(M.scriptCharset){T.charset=M.scriptCharset}if(!W){var O=false;T.onload=T.onreadystatechange=function(){if(!O&&(!this.readyState||this.readyState=="loaded"||this.readyState=="complete")){O=true;I();L();T.onload=T.onreadystatechange=null;H.removeChild(T)}}}H.appendChild(T);return g}var K=false;var J=M.xhr();if(M.username){J.open(G,M.url,M.async,M.username,M.password)}else{J.open(G,M.url,M.async)}try{if(M.data){J.setRequestHeader("Content-Type",M.contentType)}if(M.ifModified){J.setRequestHeader("If-Modified-Since",o.lastModified[M.url]||"Thu, 01 Jan 1970 00:00:00 GMT")}J.setRequestHeader("X-Requested-With","XMLHttpRequest");J.setRequestHeader("Accept",M.dataType&&M.accepts[M.dataType]?M.accepts[M.dataType]+", */*":M.accepts._default)}catch(S){}if(M.beforeSend&&M.beforeSend(J,M)===false){if(M.global&&!--o.active){o.event.trigger("ajaxStop")}J.abort();return false}if(M.global){o.event.trigger("ajaxSend",[J,M])}var N=function(X){if(J.readyState==0){if(P){clearInterval(P);P=null;if(M.global&&!--o.active){o.event.trigger("ajaxStop")}}}else{if(!K&&J&&(J.readyState==4||X=="timeout")){K=true;if(P){clearInterval(P);P=null}R=X=="timeout"?"timeout":!o.httpSuccess(J)?"error":M.ifModified&&o.httpNotModified(J,M.url)?"notmodified":"success";if(R=="success"){try{V=o.httpData(J,M.dataType,M)}catch(Z){R="parsererror"}}if(R=="success"){var Y;try{Y=J.getResponseHeader("Last-Modified")}catch(Z){}if(M.ifModified&&Y){o.lastModified[M.url]=Y}if(!W){I()}}else{o.handleError(M,J,R)}L();if(X){J.abort()}if(M.async){J=null}}}};if(M.async){var P=setInterval(N,13);if(M.timeout>0){setTimeout(function(){if(J&&!K){N("timeout")}},M.timeout)}}try{J.send(M.data)}catch(S){o.handleError(M,J,null,S)}if(!M.async){N()}function I(){if(M.success){M.success(V,R)}if(M.global){o.event.trigger("ajaxSuccess",[J,M])}}function L(){if(M.complete){M.complete(J,R)}if(M.global){o.event.trigger("ajaxComplete",[J,M])}if(M.global&&!--o.active){o.event.trigger("ajaxStop")}}return J},handleError:function(F,H,E,G){if(F.error){F.error(H,E,G)}if(F.global){o.event.trigger("ajaxError",[H,F,G])}},active:0,httpSuccess:function(F){try{return !F.status&&location.protocol=="file:"||(F.status>=200&&F.status<300)||F.status==304||F.status==1223}catch(E){}return false},httpNotModified:function(G,E){try{var H=G.getResponseHeader("Last-Modified");return G.status==304||H==o.lastModified[E]}catch(F){}return false},httpData:function(J,H,G){var F=J.getResponseHeader("content-type"),E=H=="xml"||!H&&F&&F.indexOf("xml")>=0,I=E?J.responseXML:J.responseText;if(E&&I.documentElement.tagName=="parsererror"){throw"parsererror"}if(G&&G.dataFilter){I=G.dataFilter(I,H)}if(typeof I==="string"){if(H=="script"){o.globalEval(I)}if(H=="json"){I=l["eval"]("("+I+")")}}return I},param:function(E){var G=[];function H(I,J){G[G.length]=encodeURIComponent(I)+"="+encodeURIComponent(J)}if(o.isArray(E)||E.jquery){o.each(E,function(){H(this.name,this.value)})}else{for(var F in E){if(o.isArray(E[F])){o.each(E[F],function(){H(F,this)})}else{H(F,o.isFunction(E[F])?E[F]():E[F])}}}return G.join("&").replace(/%20/g,"+")}});var m={},n,d=[["height","marginTop","marginBottom","paddingTop","paddingBottom"],["width","marginLeft","marginRight","paddingLeft","paddingRight"],["opacity"]];function t(F,E){var G={};o.each(d.concat.apply([],d.slice(0,E)),function(){G[this]=F});return G}o.fn.extend({show:function(J,L){if(J){return this.animate(t("show",3),J,L)}else{for(var H=0,F=this.length;H<F;H++){var E=o.data(this[H],"olddisplay");this[H].style.display=E||"";if(o.css(this[H],"display")==="none"){var G=this[H].tagName,K;if(m[G]){K=m[G]}else{var I=o("<"+G+" />").appendTo("body");K=I.css("display");if(K==="none"){K="block"}I.remove();m[G]=K}o.data(this[H],"olddisplay",K)}}for(var H=0,F=this.length;H<F;H++){this[H].style.display=o.data(this[H],"olddisplay")||""}return this}},hide:function(H,I){if(H){return this.animate(t("hide",3),H,I)}else{for(var G=0,F=this.length;G<F;G++){var E=o.data(this[G],"olddisplay");if(!E&&E!=="none"){o.data(this[G],"olddisplay",o.css(this[G],"display"))}}for(var G=0,F=this.length;G<F;G++){this[G].style.display="none"}return this}},_toggle:o.fn.toggle,toggle:function(G,F){var E=typeof G==="boolean";return o.isFunction(G)&&o.isFunction(F)?this._toggle.apply(this,arguments):G==null||E?this.each(function(){var H=E?G:o(this).is(":hidden");o(this)[H?"show":"hide"]()}):this.animate(t("toggle",3),G,F)},fadeTo:function(E,G,F){return this.animate({opacity:G},E,F)},animate:function(I,F,H,G){var E=o.speed(F,H,G);return this[E.queue===false?"each":"queue"](function(){var K=o.extend({},E),M,L=this.nodeType==1&&o(this).is(":hidden"),J=this;for(M in I){if(I[M]=="hide"&&L||I[M]=="show"&&!L){return K.complete.call(this)}if((M=="height"||M=="width")&&this.style){K.display=o.css(this,"display");K.overflow=this.style.overflow}}if(K.overflow!=null){this.style.overflow="hidden"}K.curAnim=o.extend({},I);o.each(I,function(O,S){var R=new o.fx(J,K,O);if(/toggle|show|hide/.test(S)){R[S=="toggle"?L?"show":"hide":S](I)}else{var Q=S.toString().match(/^([+-]=)?([\d+-.]+)(.*)$/),T=R.cur(true)||0;if(Q){var N=parseFloat(Q[2]),P=Q[3]||"px";if(P!="px"){J.style[O]=(N||1)+P;T=((N||1)/R.cur(true))*T;J.style[O]=T+P}if(Q[1]){N=((Q[1]=="-="?-1:1)*N)+T}R.custom(T,N,P)}else{R.custom(T,S,"")}}});return true})},stop:function(F,E){var G=o.timers;if(F){this.queue([])}this.each(function(){for(var H=G.length-1;H>=0;H--){if(G[H].elem==this){if(E){G[H](true)}G.splice(H,1)}}});if(!E){this.dequeue()}return this}});o.each({slideDown:t("show",1),slideUp:t("hide",1),slideToggle:t("toggle",1),fadeIn:{opacity:"show"},fadeOut:{opacity:"hide"}},function(E,F){o.fn[E]=function(G,H){return this.animate(F,G,H)}});o.extend({speed:function(G,H,F){var E=typeof G==="object"?G:{complete:F||!F&&H||o.isFunction(G)&&G,duration:G,easing:F&&H||H&&!o.isFunction(H)&&H};E.duration=o.fx.off?0:typeof E.duration==="number"?E.duration:o.fx.speeds[E.duration]||o.fx.speeds._default;E.old=E.complete;E.complete=function(){if(E.queue!==false){o(this).dequeue()}if(o.isFunction(E.old)){E.old.call(this)}};return E},easing:{linear:function(G,H,E,F){return E+F*G},swing:function(G,H,E,F){return((-Math.cos(G*Math.PI)/2)+0.5)*F+E}},timers:[],fx:function(F,E,G){this.options=E;this.elem=F;this.prop=G;if(!E.orig){E.orig={}}}});o.fx.prototype={update:function(){if(this.options.step){this.options.step.call(this.elem,this.now,this)}(o.fx.step[this.prop]||o.fx.step._default)(this);if((this.prop=="height"||this.prop=="width")&&this.elem.style){this.elem.style.display="block"}},cur:function(F){if(this.elem[this.prop]!=null&&(!this.elem.style||this.elem.style[this.prop]==null)){return this.elem[this.prop]}var E=parseFloat(o.css(this.elem,this.prop,F));return E&&E>-10000?E:parseFloat(o.curCSS(this.elem,this.prop))||0},custom:function(I,H,G){this.startTime=e();this.start=I;this.end=H;this.unit=G||this.unit||"px";this.now=this.start;this.pos=this.state=0;var E=this;function F(J){return E.step(J)}F.elem=this.elem;if(F()&&o.timers.push(F)&&!n){n=setInterval(function(){var K=o.timers;for(var J=0;J<K.length;J++){if(!K[J]()){K.splice(J--,1)}}if(!K.length){clearInterval(n);n=g}},13)}},show:function(){this.options.orig[this.prop]=o.attr(this.elem.style,this.prop);this.options.show=true;this.custom(this.prop=="width"||this.prop=="height"?1:0,this.cur());o(this.elem).show()},hide:function(){this.options.orig[this.prop]=o.attr(this.elem.style,this.prop);this.options.hide=true;this.custom(this.cur(),0)},step:function(H){var G=e();if(H||G>=this.options.duration+this.startTime){this.now=this.end;this.pos=this.state=1;this.update();this.options.curAnim[this.prop]=true;var E=true;for(var F in this.options.curAnim){if(this.options.curAnim[F]!==true){E=false}}if(E){if(this.options.display!=null){this.elem.style.overflow=this.options.overflow;this.elem.style.display=this.options.display;if(o.css(this.elem,"display")=="none"){this.elem.style.display="block"}}if(this.options.hide){o(this.elem).hide()}if(this.options.hide||this.options.show){for(var I in this.options.curAnim){o.attr(this.elem.style,I,this.options.orig[I])}}this.options.complete.call(this.elem)}return false}else{var J=G-this.startTime;this.state=J/this.options.duration;this.pos=o.easing[this.options.easing||(o.easing.swing?"swing":"linear")](this.state,J,0,1,this.options.duration);this.now=this.start+((this.end-this.start)*this.pos);this.update()}return true}};o.extend(o.fx,{speeds:{slow:600,fast:200,_default:400},step:{opacity:function(E){o.attr(E.elem.style,"opacity",E.now)},_default:function(E){if(E.elem.style&&E.elem.style[E.prop]!=null){E.elem.style[E.prop]=E.now+E.unit}else{E.elem[E.prop]=E.now}}}});if(document.documentElement.getBoundingClientRect){o.fn.offset=function(){if(!this[0]){return{top:0,left:0}}if(this[0]===this[0].ownerDocument.body){return o.offset.bodyOffset(this[0])}var G=this[0].getBoundingClientRect(),J=this[0].ownerDocument,F=J.body,E=J.documentElement,L=E.clientTop||F.clientTop||0,K=E.clientLeft||F.clientLeft||0,I=G.top+(self.pageYOffset||o.boxModel&&E.scrollTop||F.scrollTop)-L,H=G.left+(self.pageXOffset||o.boxModel&&E.scrollLeft||F.scrollLeft)-K;return{top:I,left:H}}}else{o.fn.offset=function(){if(!this[0]){return{top:0,left:0}}if(this[0]===this[0].ownerDocument.body){return o.offset.bodyOffset(this[0])}o.offset.initialized||o.offset.initialize();var J=this[0],G=J.offsetParent,F=J,O=J.ownerDocument,M,H=O.documentElement,K=O.body,L=O.defaultView,E=L.getComputedStyle(J,null),N=J.offsetTop,I=J.offsetLeft;while((J=J.parentNode)&&J!==K&&J!==H){M=L.getComputedStyle(J,null);N-=J.scrollTop,I-=J.scrollLeft;if(J===G){N+=J.offsetTop,I+=J.offsetLeft;if(o.offset.doesNotAddBorder&&!(o.offset.doesAddBorderForTableAndCells&&/^t(able|d|h)$/i.test(J.tagName))){N+=parseInt(M.borderTopWidth,10)||0,I+=parseInt(M.borderLeftWidth,10)||0}F=G,G=J.offsetParent}if(o.offset.subtractsBorderForOverflowNotVisible&&M.overflow!=="visible"){N+=parseInt(M.borderTopWidth,10)||0,I+=parseInt(M.borderLeftWidth,10)||0}E=M}if(E.position==="relative"||E.position==="static"){N+=K.offsetTop,I+=K.offsetLeft}if(E.position==="fixed"){N+=Math.max(H.scrollTop,K.scrollTop),I+=Math.max(H.scrollLeft,K.scrollLeft)}return{top:N,left:I}}}o.offset={initialize:function(){if(this.initialized){return}var L=document.body,F=document.createElement("div"),H,G,N,I,M,E,J=L.style.marginTop,K='<div style="position:absolute;top:0;left:0;margin:0;border:5px solid #000;padding:0;width:1px;height:1px;"><div></div></div><table style="position:absolute;top:0;left:0;margin:0;border:5px solid #000;padding:0;width:1px;height:1px;" cellpadding="0" cellspacing="0"><tr><td></td></tr></table>';M={position:"absolute",top:0,left:0,margin:0,border:0,width:"1px",height:"1px",visibility:"hidden"};for(E in M){F.style[E]=M[E]}F.innerHTML=K;L.insertBefore(F,L.firstChild);H=F.firstChild,G=H.firstChild,I=H.nextSibling.firstChild.firstChild;this.doesNotAddBorder=(G.offsetTop!==5);this.doesAddBorderForTableAndCells=(I.offsetTop===5);H.style.overflow="hidden",H.style.position="relative";this.subtractsBorderForOverflowNotVisible=(G.offsetTop===-5);L.style.marginTop="1px";this.doesNotIncludeMarginInBodyOffset=(L.offsetTop===0);L.style.marginTop=J;L.removeChild(F);this.initialized=true},bodyOffset:function(E){o.offset.initialized||o.offset.initialize();var G=E.offsetTop,F=E.offsetLeft;if(o.offset.doesNotIncludeMarginInBodyOffset){G+=parseInt(o.curCSS(E,"marginTop",true),10)||0,F+=parseInt(o.curCSS(E,"marginLeft",true),10)||0}return{top:G,left:F}}};o.fn.extend({position:function(){var I=0,H=0,F;if(this[0]){var G=this.offsetParent(),J=this.offset(),E=/^body|html$/i.test(G[0].tagName)?{top:0,left:0}:G.offset();J.top-=j(this,"marginTop");J.left-=j(this,"marginLeft");E.top+=j(G,"borderTopWidth");E.left+=j(G,"borderLeftWidth");F={top:J.top-E.top,left:J.left-E.left}}return F},offsetParent:function(){var E=this[0].offsetParent||document.body;while(E&&(!/^body|html$/i.test(E.tagName)&&o.css(E,"position")=="static")){E=E.offsetParent}return o(E)}});o.each(["Left","Top"],function(F,E){var G="scroll"+E;o.fn[G]=function(H){if(!this[0]){return null}return H!==g?this.each(function(){this==l||this==document?l.scrollTo(!F?H:o(l).scrollLeft(),F?H:o(l).scrollTop()):this[G]=H}):this[0]==l||this[0]==document?self[F?"pageYOffset":"pageXOffset"]||o.boxModel&&document.documentElement[G]||document.body[G]:this[0][G]}});o.each(["Height","Width"],function(I,G){var E=I?"Left":"Top",H=I?"Right":"Bottom",F=G.toLowerCase();o.fn["inner"+G]=function(){return this[0]?o.css(this[0],F,false,"padding"):null};o.fn["outer"+G]=function(K){return this[0]?o.css(this[0],F,false,K?"margin":"border"):null};var J=G.toLowerCase();o.fn[J]=function(K){return this[0]==l?document.compatMode=="CSS1Compat"&&document.documentElement["client"+G]||document.body["client"+G]:this[0]==document?Math.max(document.documentElement["client"+G],document.body["scroll"+G],document.documentElement["scroll"+G],document.body["offset"+G],document.documentElement["offset"+G]):K===g?(this.length?o.css(this[0],J):null):this.css(J,typeof K==="string"?K:K+"px")}})})();
\ No newline at end of file
diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor
index 5030cb6904..de60049c84 100644
--- a/extra/benchmark/md5/md5.factor
+++ b/extra/benchmark/md5/md5.factor
@@ -1,7 +1,7 @@
-USING: checksums checksums.md5 io.files kernel ;
+USING: checksums checksums.md5 sequences byte-arrays kernel ;
IN: benchmark.md5
: md5-file ( -- )
- "vocab:mime/multipart/multipart-tests.factor" md5 checksum-file drop ;
+ 2000000 iota >byte-array md5 checksum-bytes drop ;
MAIN: md5-file
diff --git a/extra/benchmark/pidigits/authors.txt b/extra/benchmark/pidigits/authors.txt
new file mode 100644
index 0000000000..4eec9c9a08
--- /dev/null
+++ b/extra/benchmark/pidigits/authors.txt
@@ -0,0 +1 @@
+Aaron Schaefer
diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor
new file mode 100644
index 0000000000..5de5cc5e99
--- /dev/null
+++ b/extra/benchmark/pidigits/pidigits.factor
@@ -0,0 +1,59 @@
+! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
+! The contents of this file are licensed under the Simplified BSD License
+! A copy of the license is available at http://factorcode.org/license.txt
+USING: arrays formatting fry grouping io kernel locals math math.functions
+ math.matrices math.parser math.primes.factors math.vectors prettyprint
+ sequences sequences.deep sets ;
+IN: benchmark.pidigits
+
+: extract ( z x -- n )
+ 1 2array '[ _ v* sum ] map first2 /i ;
+
+: next ( z -- n )
+ 3 extract ;
+
+: safe? ( z n -- ? )
+ [ 4 extract ] dip = ;
+
+: >matrix ( q s r t -- z )
+ 4array 2 group ;
+
+: produce ( z n -- z' )
+ [ 10 ] dip -10 * 0 1 >matrix swap m. ;
+
+: gen-x ( x -- matrix )
+ dup 2 * 1 + [ 2 * 0 ] keep >matrix ;
+
+: consume ( z k -- z' )
+ gen-x m. ;
+
+:: (padded-total) ( row col -- str n format )
+ "" row col + "%" "s\t:%d\n"
+ 10 col - number>string glue ;
+
+: padded-total ( row col -- )
+ (padded-total) '[ _ printf ] call( str n -- ) ;
+
+:: (pidigits) ( k z n row col -- )
+ n 0 > [
+ z next :> y
+ z y safe? [
+ col 10 = [
+ row 10 + y "\t:%d\n%d" printf
+ k z y produce n 1 - row 10 + 1 (pidigits)
+ ] [
+ y number>string write
+ k z y produce n 1 - row col 1 + (pidigits)
+ ] if
+ ] [
+ k 1 + z k consume n row col (pidigits)
+ ] if
+ ] [ row col padded-total ] if ;
+
+: pidigits ( n -- )
+ [ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
+
+: pidigits-main ( -- )
+ 10000 pidigits ;
+
+MAIN: pidigits-main
diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor
index d2eb4cdab5..4eab7c1669 100755
--- a/extra/benchmark/random/random.factor
+++ b/extra/benchmark/random/random.factor
@@ -11,6 +11,6 @@ IN: benchmark.random
] with-file-writer ;
: random-main ( -- )
- 1000000 write-random-numbers ;
+ 300000 write-random-numbers ;
MAIN: random-main
diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor
index a4df1fe04d..642b3dbb93 100755
--- a/extra/benchmark/raytracer/raytracer.factor
+++ b/extra/benchmark/raytracer/raytracer.factor
@@ -53,7 +53,7 @@ C: <sphere> sphere
: sphere-t ( b d -- t )
-+ dup 0.0 <
- [ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
+ [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
: sphere-b&v ( sphere ray -- b v )
[ sphere-v ] [ nip ] 2bi
diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor
index 8e19ba9a8f..c1a7af2966 100644
--- a/extra/benchmark/sha1/sha1.factor
+++ b/extra/benchmark/sha1/sha1.factor
@@ -1,7 +1,7 @@
-USING: checksums checksums.sha1 io.files kernel ;
+USING: checksums checksums.sha1 sequences byte-arrays kernel ;
IN: benchmark.sha1
: sha1-file ( -- )
- "vocab:mime/multipart/multipart-tests.factor" sha1 checksum-file drop ;
+ 2000000 iota >byte-array sha1 checksum-bytes drop ;
MAIN: sha1-file
diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor
index bb7aebba62..b1f27830ee 100644
--- a/extra/benchmark/sum-file/sum-file.factor
+++ b/extra/benchmark/sum-file/sum-file.factor
@@ -9,6 +9,6 @@ IN: benchmark.sum-file
ascii [ 0 sum-file-loop ] with-file-reader . ;
: sum-file-main ( -- )
- random-numbers-path sum-file ;
+ 5 [ random-numbers-path sum-file ] times ;
MAIN: sum-file-main
diff --git a/extra/benchmark/tuple-arrays/authors.txt b/extra/benchmark/tuple-arrays/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/benchmark/tuple-arrays/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor
new file mode 100644
index 0000000000..483311d4f4
--- /dev/null
+++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions tuple-arrays accessors fry sequences
+prettyprint ;
+IN: benchmark.tuple-arrays
+
+TUPLE: point { x float } { y float } { z float } ;
+
+TUPLE-ARRAY: point
+
+: tuple-array-benchmark ( -- )
+ 100 [
+ drop 5000 <point-array> [
+ [ 1+ ] change-x
+ [ 1- ] change-y
+ [ 1+ 2 / ] change-z
+ ] map [ z>> ] sigma
+ ] sigma . ;
+
+MAIN: tuple-array-benchmark
\ No newline at end of file
diff --git a/extra/benchmark/typecheck3/typecheck3.factor b/extra/benchmark/typecheck3/typecheck3.factor
index c4887c03c4..fccd80a607 100644
--- a/extra/benchmark/typecheck3/typecheck3.factor
+++ b/extra/benchmark/typecheck3/typecheck3.factor
@@ -3,7 +3,7 @@ IN: benchmark.typecheck3
TUPLE: hello n ;
-: hello-n* ( obj -- val ) dup tag 2 eq? [ 2 slot ] [ 3 throw ] if ;
+: hello-n* ( obj -- val ) 2 slot ;
: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
diff --git a/extra/benchmark/typecheck4/typecheck4.factor b/extra/benchmark/typecheck4/typecheck4.factor
deleted file mode 100644
index c881864304..0000000000
--- a/extra/benchmark/typecheck4/typecheck4.factor
+++ /dev/null
@@ -1,12 +0,0 @@
-USING: math kernel kernel.private slots.private ;
-IN: benchmark.typecheck4
-
-TUPLE: hello n ;
-
-: hello-n* ( obj -- val ) 2 slot ;
-
-: foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
-
-: typecheck-main ( -- ) 0 hello boa foo 2drop ;
-
-MAIN: typecheck-main
diff --git a/extra/bson/authors.txt b/extra/bson/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/bson/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/bson/bson.factor b/extra/bson/bson.factor
new file mode 100644
index 0000000000..a97b5029b0
--- /dev/null
+++ b/extra/bson/bson.factor
@@ -0,0 +1,6 @@
+USING: vocabs.loader ;
+
+IN: bson
+
+"bson.reader" require
+"bson.writer" require
diff --git a/extra/bson/constants/authors.txt b/extra/bson/constants/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/bson/constants/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/bson/constants/constants.factor b/extra/bson/constants/constants.factor
new file mode 100644
index 0000000000..5148413b61
--- /dev/null
+++ b/extra/bson/constants/constants.factor
@@ -0,0 +1,49 @@
+USING: accessors constructors kernel strings uuid ;
+
+IN: bson.constants
+
+: <objid> ( -- objid )
+ uuid1 ; inline
+
+TUPLE: oid { a initial: 0 } { b initial: 0 } ;
+
+TUPLE: objref ns objid ;
+
+CONSTRUCTOR: objref ( ns objid -- objref ) ;
+
+TUPLE: mdbregexp { regexp string } { options string } ;
+
+: <mdbregexp> ( string -- mdbregexp )
+ [ mdbregexp new ] dip >>regexp ;
+
+
+CONSTANT: MDB_OID_FIELD "_id"
+CONSTANT: MDB_META_FIELD "_mfd"
+
+CONSTANT: T_EOO 0
+CONSTANT: T_Double 1
+CONSTANT: T_Integer 16
+CONSTANT: T_Boolean 8
+CONSTANT: T_String 2
+CONSTANT: T_Object 3
+CONSTANT: T_Array 4
+CONSTANT: T_Binary 5
+CONSTANT: T_Undefined 6
+CONSTANT: T_OID 7
+CONSTANT: T_Date 9
+CONSTANT: T_NULL 10
+CONSTANT: T_Regexp 11
+CONSTANT: T_DBRef 12
+CONSTANT: T_Code 13
+CONSTANT: T_ScopedCode 17
+CONSTANT: T_Symbol 14
+CONSTANT: T_JSTypeMax 16
+CONSTANT: T_MaxKey 127
+
+CONSTANT: T_Binary_Function 1
+CONSTANT: T_Binary_Bytes 2
+CONSTANT: T_Binary_UUID 3
+CONSTANT: T_Binary_MD5 5
+CONSTANT: T_Binary_Custom 128
+
+
diff --git a/extra/bson/constants/summary.txt b/extra/bson/constants/summary.txt
new file mode 100644
index 0000000000..11b05920ef
--- /dev/null
+++ b/extra/bson/constants/summary.txt
@@ -0,0 +1 @@
+Shared constants and classes
diff --git a/extra/bson/reader/authors.txt b/extra/bson/reader/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/bson/reader/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor
new file mode 100644
index 0000000000..96cde41c2b
--- /dev/null
+++ b/extra/bson/reader/reader.factor
@@ -0,0 +1,200 @@
+USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
+io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
+sequences serialize arrays calendar io.encodings ;
+
+IN: bson.reader
+
+<PRIVATE
+
+TUPLE: element { type integer } name ;
+TUPLE: state
+ { size initial: -1 } { read initial: 0 } exemplar
+ result scope element ;
+
+: <state> ( exemplar -- state )
+ [ state new ] dip
+ [ clone >>exemplar ] keep
+ clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
+ V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
+
+PREDICATE: bson-eoo < integer T_EOO = ;
+PREDICATE: bson-not-eoo < integer T_EOO > ;
+
+PREDICATE: bson-double < integer T_Double = ;
+PREDICATE: bson-integer < integer T_Integer = ;
+PREDICATE: bson-string < integer T_String = ;
+PREDICATE: bson-object < integer T_Object = ;
+PREDICATE: bson-array < integer T_Array = ;
+PREDICATE: bson-binary < integer T_Binary = ;
+PREDICATE: bson-regexp < integer T_Regexp = ;
+PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
+PREDICATE: bson-binary-function < integer T_Binary_Function = ;
+PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
+PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
+PREDICATE: bson-oid < integer T_OID = ;
+PREDICATE: bson-boolean < integer T_Boolean = ;
+PREDICATE: bson-date < integer T_Date = ;
+PREDICATE: bson-null < integer T_NULL = ;
+PREDICATE: bson-ref < integer T_DBRef = ;
+
+GENERIC: element-read ( type -- cont? )
+GENERIC: element-data-read ( type -- object )
+GENERIC: element-binary-read ( length type -- object )
+
+: byte-array>number ( seq -- number )
+ byte-array>bignum >integer ; inline
+
+: get-state ( -- state )
+ state get ; inline
+
+: count-bytes ( count -- )
+ [ get-state ] dip '[ _ + ] change-read drop ; inline
+
+: read-int32 ( -- int32 )
+ 4 [ read byte-array>number ] [ count-bytes ] bi ; inline
+
+: read-longlong ( -- longlong )
+ 8 [ read byte-array>number ] [ count-bytes ] bi ; inline
+
+: read-double ( -- double )
+ 8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline
+
+: read-byte-raw ( -- byte-raw )
+ 1 [ read ] [ count-bytes ] bi ; inline
+
+: read-byte ( -- byte )
+ read-byte-raw first ; inline
+
+: read-cstring ( -- string )
+ input-stream get utf8 <decoder>
+ "\0" swap stream-read-until drop ; inline
+
+: read-sized-string ( length -- string )
+ drop read-cstring ; inline
+
+: read-element-type ( -- type )
+ read-byte ; inline
+
+: push-element ( type name -- element )
+ element boa
+ [ get-state element>> push ] keep ; inline
+
+: pop-element ( -- element )
+ get-state element>> pop ; inline
+
+: peek-scope ( -- ht )
+ get-state scope>> peek ; inline
+
+: read-elements ( -- )
+ read-element-type
+ element-read
+ [ read-elements ] when ; inline recursive
+
+GENERIC: fix-result ( assoc type -- result )
+
+M: bson-object fix-result ( assoc type -- result )
+ drop ;
+
+M: bson-array fix-result ( assoc type -- result )
+ drop
+ values ;
+
+GENERIC: end-element ( type -- )
+
+M: bson-object end-element ( type -- )
+ drop ;
+
+M: bson-array end-element ( type -- )
+ drop ;
+
+M: object end-element ( type -- )
+ drop
+ pop-element drop ;
+
+M: bson-eoo element-read ( type -- cont? )
+ drop
+ get-state scope>> [ pop ] keep swap ! vec assoc
+ pop-element [ type>> ] keep ! vec assoc element
+ [ fix-result ] dip
+ rot length 0 > ! assoc element
+ [ name>> peek-scope set-at t ]
+ [ drop [ get-state ] dip >>result drop f ] if ;
+
+M: bson-not-eoo element-read ( type -- cont? )
+ [ peek-scope ] dip ! scope type
+ '[ _ read-cstring push-element [ name>> ] [ type>> ] bi
+ [ element-data-read ] keep
+ end-element
+ swap
+ ] dip set-at t ;
+
+: [scope-changer] ( state -- state quot )
+ dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
+
+: (object-data-read) ( type -- object )
+ drop
+ read-int32 drop
+ get-state
+ [scope-changer] change-scope
+ scope>> peek ; inline
+
+M: bson-object element-data-read ( type -- object )
+ (object-data-read) ;
+
+M: bson-array element-data-read ( type -- object )
+ (object-data-read) ;
+
+M: bson-string element-data-read ( type -- object )
+ drop
+ read-int32 read-sized-string ;
+
+M: bson-integer element-data-read ( type -- object )
+ drop
+ read-int32 ;
+
+M: bson-double element-data-read ( type -- double )
+ drop
+ read-double ;
+
+M: bson-boolean element-data-read ( type -- boolean )
+ drop
+ read-byte 1 = ;
+
+M: bson-date element-data-read ( type -- timestamp )
+ drop
+ read-longlong millis>timestamp ;
+
+M: bson-binary element-data-read ( type -- binary )
+ drop
+ read-int32 read-byte element-binary-read ;
+
+M: bson-regexp element-data-read ( type -- mdbregexp )
+ drop mdbregexp new
+ read-cstring >>regexp read-cstring >>options ;
+
+M: bson-null element-data-read ( type -- bf )
+ drop
+ f ;
+
+M: bson-oid element-data-read ( type -- oid )
+ drop
+ read-longlong
+ read-int32 oid boa ;
+
+M: bson-binary-custom element-binary-read ( size type -- dbref )
+ 2drop
+ read-cstring
+ read-cstring objref boa ;
+
+M: bson-binary-bytes element-binary-read ( size type -- bytes )
+ drop read ;
+
+M: bson-binary-function element-binary-read ( size type -- quot )
+ drop read bytes>object ;
+
+PRIVATE>
+
+: stream>assoc ( exemplar -- assoc bytes-read )
+ <state> dup state
+ [ read-int32 >>size read-elements ] with-variable
+ [ result>> ] [ read>> ] bi ;
diff --git a/extra/bson/reader/summary.txt b/extra/bson/reader/summary.txt
new file mode 100644
index 0000000000..384fe07a42
--- /dev/null
+++ b/extra/bson/reader/summary.txt
@@ -0,0 +1 @@
+BSON to Factor deserializer
diff --git a/extra/bson/summary.txt b/extra/bson/summary.txt
new file mode 100644
index 0000000000..58604e6990
--- /dev/null
+++ b/extra/bson/summary.txt
@@ -0,0 +1 @@
+BSON reader and writer
diff --git a/extra/bson/writer/authors.txt b/extra/bson/writer/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/bson/writer/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/bson/writer/summary.txt b/extra/bson/writer/summary.txt
new file mode 100644
index 0000000000..5dc8501bcb
--- /dev/null
+++ b/extra/bson/writer/summary.txt
@@ -0,0 +1 @@
+Factor to BSON serializer
diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor
new file mode 100644
index 0000000000..1b9d45b124
--- /dev/null
+++ b/extra/bson/writer/writer.factor
@@ -0,0 +1,164 @@
+! Copyright (C) 2008 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs bson.constants byte-arrays byte-vectors
+calendar fry io io.binary io.encodings io.encodings.binary
+io.encodings.utf8 io.streams.byte-array kernel math math.parser
+namespaces quotations sequences sequences.private serialize strings
+words combinators.short-circuit literals ;
+
+IN: bson.writer
+
+<PRIVATE
+
+SYMBOL: shared-buffer
+
+CONSTANT: INT32-SIZE 4
+CONSTANT: CHAR-SIZE 1
+CONSTANT: INT64-SIZE 8
+
+: (buffer) ( -- buffer )
+ shared-buffer get
+ [ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
+
+: >le-stream ( x n -- )
+ swap
+ '[ _ swap nth-byte 0 B{ 0 }
+ [ set-nth-unsafe ] keep write ] each ; inline
+
+PRIVATE>
+
+: reset-buffer ( buffer -- )
+ 0 >>length drop ; inline
+
+: ensure-buffer ( -- )
+ (buffer) drop ; inline
+
+: with-buffer ( quot -- byte-vector )
+ [ (buffer) [ reset-buffer ] keep dup ] dip
+ with-output-stream* dup encoder? [ stream>> ] when ; inline
+
+: with-length ( quot: ( -- ) -- bytes-written start-index )
+ [ (buffer) [ length ] keep ] dip call
+ length swap [ - ] keep ; inline
+
+: with-length-prefix ( quot: ( -- ) -- )
+ [ B{ 0 0 0 0 } write ] prepose with-length
+ [ INT32-SIZE >le ] dip (buffer)
+ '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
+ [ INT32-SIZE ] dip each-integer ; inline
+
+: with-length-prefix-excl ( quot: ( -- ) -- )
+ [ B{ 0 0 0 0 } write ] prepose with-length
+ [ INT32-SIZE - INT32-SIZE >le ] dip (buffer)
+ '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
+ [ INT32-SIZE ] dip each-integer ; inline
+
+<PRIVATE
+
+GENERIC: bson-type? ( obj -- type ) foldable flushable
+GENERIC: bson-write ( obj -- )
+
+M: t bson-type? ( boolean -- type ) drop T_Boolean ;
+M: f bson-type? ( boolean -- type ) drop T_Boolean ;
+
+M: real bson-type? ( real -- type ) drop T_Double ;
+M: word bson-type? ( word -- type ) drop T_String ;
+M: tuple bson-type? ( tuple -- type ) drop T_Object ;
+M: sequence bson-type? ( seq -- type ) drop T_Array ;
+M: string bson-type? ( string -- type ) drop T_String ;
+M: integer bson-type? ( integer -- type ) drop T_Integer ;
+M: assoc bson-type? ( assoc -- type ) drop T_Object ;
+M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
+M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
+
+M: oid bson-type? ( word -- type ) drop T_OID ;
+M: objref bson-type? ( objref -- type ) drop T_Binary ;
+M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
+M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
+
+: write-utf8-string ( string -- )
+ output-stream get utf8 <encoder> stream-write ; inline
+
+: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline
+: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline
+: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline
+: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
+: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline
+
+: write-eoo ( -- ) T_EOO write-byte ; inline
+: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
+: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
+
+M: f bson-write ( f -- )
+ drop 0 write-byte ;
+
+M: t bson-write ( t -- )
+ drop 1 write-byte ;
+
+M: string bson-write ( obj -- )
+ '[ _ write-cstring ] with-length-prefix-excl ;
+
+M: integer bson-write ( num -- )
+ write-int32 ;
+
+M: real bson-write ( num -- )
+ >float write-double ;
+
+M: timestamp bson-write ( timestamp -- )
+ timestamp>millis write-longlong ;
+
+M: byte-array bson-write ( binary -- )
+ [ length write-int32 ] keep
+ T_Binary_Bytes write-byte
+ write ;
+
+M: quotation bson-write ( quotation -- )
+ object>bytes [ length write-int32 ] keep
+ T_Binary_Function write-byte
+ write ;
+
+M: oid bson-write ( oid -- )
+ [ a>> write-longlong ] [ b>> write-int32 ] bi ;
+
+M: objref bson-write ( objref -- )
+ [ binary ] dip
+ '[ _
+ [ ns>> write-cstring ]
+ [ objid>> write-cstring ] bi ] with-byte-writer
+ [ length write-int32 ] keep
+ T_Binary_Custom write-byte write ;
+
+M: mdbregexp bson-write ( regexp -- )
+ [ regexp>> write-cstring ]
+ [ options>> write-cstring ] bi ;
+
+M: sequence bson-write ( array -- )
+ '[ _ [ [ write-type ] dip number>string
+ write-cstring bson-write ] each-index
+ write-eoo ] with-length-prefix ;
+
+: write-oid ( assoc -- )
+ [ MDB_OID_FIELD ] dip at
+ [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
+
+: skip-field? ( name -- boolean )
+ { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
+
+M: assoc bson-write ( assoc -- )
+ '[ _ [ write-oid ] keep
+ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
+ write-eoo ] with-length-prefix ;
+
+M: word bson-write name>> bson-write ;
+
+PRIVATE>
+
+: assoc>bv ( assoc -- byte-vector )
+ [ '[ _ bson-write ] with-buffer ] with-scope ; inline
+
+: assoc>stream ( assoc -- )
+ bson-write ; inline
+
+: mdb-special-value? ( value -- ? )
+ { [ timestamp? ] [ quotation? ] [ mdbregexp? ]
+ [ oid? ] [ byte-array? ] } 1|| ;
\ No newline at end of file
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index d0625e464f..620f737fe3 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -1,58 +1,67 @@
USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
bunny.model bunny.outlined destructors kernel math opengl.demo-support
opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
-ui.render words ;
+ui.render words ui.pixel-formats ;
IN: bunny
-TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
+TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ;
-: <bunny-gadget> ( -- bunny-gadget )
- 0.0 0.0 0.375 bunny-gadget new-demo-gadget
- maybe-download read-model >>model-triangles ;
-
-: bunny-gadget-draw ( gadget -- draw )
+: get-draw ( gadget -- draw )
[ draw-n>> ] [ draw-seq>> ] bi nth ;
-: bunny-gadget-next-draw ( gadget -- )
+: next-draw ( gadget -- )
dup [ draw-seq>> ] [ draw-n>> ] bi
1+ swap length mod
>>draw-n relayout-1 ;
-M: bunny-gadget graft* ( gadget -- )
- dup find-gl-context
- GL_DEPTH_TEST glEnable
- dup model-triangles>> <bunny-geom> >>geom
- dup
+: make-draws ( gadget -- draw-seq )
[ <bunny-fixed-pipeline> ]
[ <bunny-cel-shaded> ]
[ <bunny-outlined> ] tri 3array
- sift >>draw-seq
+ sift ;
+
+M: bunny-world begin-world
+ GL_DEPTH_TEST glEnable
+ 0.0 0.0 0.375 set-demo-orientation
+ maybe-download read-model
+ [ >>model-triangles ] [ <bunny-geom> >>geom ] bi
+ dup make-draws >>draw-seq
0 >>draw-n
drop ;
-M: bunny-gadget ungraft* ( gadget -- )
+M: bunny-world end-world
dup find-gl-context
[ geom>> [ dispose ] when* ]
[ draw-seq>> [ [ dispose ] when* ] each ] bi ;
-M: bunny-gadget draw-gadget* ( gadget -- )
+M: bunny-world draw-world*
dup draw-seq>> empty? [ drop ] [
0.15 0.15 0.15 1.0 glClearColor
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
- dup demo-gadget-set-matrices
+ dup demo-world-set-matrix
GL_MODELVIEW glMatrixMode
0.02 -0.105 0.0 glTranslatef
- [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny
+ [ geom>> ] [ get-draw ] bi draw-bunny
] if ;
-M: bunny-gadget pref-dim* ( gadget -- dim )
+M: bunny-world pref-dim* ( gadget -- dim )
drop { 640 480 } ;
-bunny-gadget H{
- { T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] }
+bunny-world H{
+ { T{ key-down f f "TAB" } [ next-draw ] }
} set-gestures
: bunny-window ( -- )
- [ <bunny-gadget> "Bunny" open-window ] with-ui ;
+ [
+ f T{ world-attributes
+ { world-class bunny-world }
+ { title "Bunny" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 16 } }
+ } }
+ } open-window
+ ] with-ui ;
MAIN: bunny-window
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index 7491ed8bcb..0ad2a72100 100755
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -216,7 +216,11 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- )
] with-framebuffer ;
: (pass2) ( draw -- )
- init-matrices {
+ GL_PROJECTION glMatrixMode
+ glPushMatrix glLoadIdentity
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ {
[ color-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
[ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
[ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
@@ -230,7 +234,9 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- )
} cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
] with-gl-program
]
- } cleave ;
+ } cleave
+ GL_PROJECTION glMatrixMode
+ glPopMatrix ;
M: bunny-outlined draw-bunny
[ remake-framebuffer-if-needed ]
diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor
index f7cd10a0e9..f787befc31 100644
--- a/extra/c/preprocessor/preprocessor.factor
+++ b/extra/c/preprocessor/preprocessor.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: html.parser.state io io.encodings.utf8 io.files
+USING: sequence-parser io io.encodings.utf8 io.files
io.streams.string kernel combinators accessors io.pathnames
fry sequences arrays locals namespaces io.directories
assocs math splitting make unicode.categories
@@ -41,7 +41,7 @@ ifs elifs elses ;
DEFER: preprocess-file
-ERROR: unknown-c-preprocessor state-parser name ;
+ERROR: unknown-c-preprocessor sequence-parser name ;
ERROR: bad-include-line line ;
@@ -69,8 +69,16 @@ ERROR: header-file-missing path ;
drop
] if ;
-: handle-include ( preprocessor-state state-parser -- )
- skip-whitespace advance dup previous {
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: handle-include ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments advance dup previous {
{ CHAR: < [ CHAR: > take-until-object read-standard-include ] }
{ CHAR: " [ CHAR: " take-until-object read-local-include ] }
[ bad-include-line ]
@@ -81,58 +89,58 @@ ERROR: header-file-missing path ;
: readlns ( -- string ) [ (readlns) ] { } make concat ;
-: take-define-identifier ( state-parser -- string )
- skip-whitespace
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
-: handle-define ( preprocessor-state state-parser -- )
+: handle-define ( preprocessor-state sequence-parser -- )
[ take-define-identifier ]
- [ skip-whitespace take-rest ] bi
+ [ skip-whitespace/comments take-rest ] bi
"\\" ?tail [ readlns append ] when
spin symbol-table>> set-at ;
-: handle-undef ( preprocessor-state state-parser -- )
+: handle-undef ( preprocessor-state sequence-parser -- )
take-token swap symbol-table>> delete-at ;
-: handle-ifdef ( preprocessor-state state-parser -- )
+: handle-ifdef ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ drop ] [ t >>processing-disabled? drop ] if ;
-: handle-ifndef ( preprocessor-state state-parser -- )
+: handle-ifndef ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
take-token over symbol-table>> key?
[ t >>processing-disabled? drop ]
[ drop ] if ;
-: handle-endif ( preprocessor-state state-parser -- )
+: handle-endif ( preprocessor-state sequence-parser -- )
drop [ 1 - ] change-ifdef-nesting drop ;
-: handle-if ( preprocessor-state state-parser -- )
+: handle-if ( preprocessor-state sequence-parser -- )
[ [ 1 + ] change-ifdef-nesting ] dip
- skip-whitespace take-rest swap ifs>> push ;
+ skip-whitespace/comments take-rest swap ifs>> push ;
-: handle-elif ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap elifs>> push ;
+: handle-elif ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap elifs>> push ;
-: handle-else ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap elses>> push ;
+: handle-else ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap elses>> push ;
-: handle-pragma ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap pragmas>> push ;
+: handle-pragma ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap pragmas>> push ;
-: handle-include-next ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap include-nexts>> push ;
+: handle-include-next ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap include-nexts>> push ;
-: handle-error ( preprocessor-state state-parser -- )
- skip-whitespace take-rest swap errors>> push ;
+: handle-error ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments take-rest swap errors>> push ;
! nip take-rest throw ;
-: handle-warning ( preprocessor-state state-parser -- )
- skip-whitespace
+: handle-warning ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments
take-rest swap warnings>> push ;
-: parse-directive ( preprocessor-state state-parser string -- )
+: parse-directive ( preprocessor-state sequence-parser string -- )
{
{ "warning" [ handle-warning ] }
{ "error" [ handle-error ] }
@@ -150,7 +158,7 @@ ERROR: header-file-missing path ;
[ unknown-c-preprocessor ]
} case ;
-: parse-directive-line ( preprocessor-state state-parser -- )
+: parse-directive-line ( preprocessor-state sequence-parser -- )
advance dup take-token
pick processing-disabled?>> [
"endif" = [
@@ -162,14 +170,14 @@ ERROR: header-file-missing path ;
parse-directive
] if ;
-: preprocess-line ( preprocessor-state state-parser -- )
- skip-whitespace dup current CHAR: # =
+: preprocess-line ( preprocessor-state sequence-parser -- )
+ skip-whitespace/comments dup current CHAR: # =
[ parse-directive-line ]
[ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
: preprocess-lines ( preprocessor-state -- )
readln
- [ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
+ [ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
[ drop ] if* ;
ERROR: include-nested-too-deeply ;
diff --git a/extra/contributors/contributors-tests.factor b/extra/contributors/contributors-tests.factor
index 1476715588..3d9ce0403d 100644
--- a/extra/contributors/contributors-tests.factor
+++ b/extra/contributors/contributors-tests.factor
@@ -1,5 +1,4 @@
IN: contributors.tests
USING: contributors tools.test ;
-\ contributors must-infer
[ ] [ contributors ] unit-test
diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor
index 1879c52826..73bee76c0a 100755
--- a/extra/contributors/contributors.factor
+++ b/extra/contributors/contributors.factor
@@ -7,7 +7,7 @@ IN: contributors
: changelog ( -- authors )
image parent-directory [
- "git log --pretty=format:%an" ascii <process-reader> lines
+ "git log --pretty=format:%an" ascii <process-reader> stream-lines
] with-directory ;
: patch-counts ( authors -- assoc )
diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor
index 51276336e3..6b334822c0 100644
--- a/extra/coroutines/coroutines.factor
+++ b/extra/coroutines/coroutines.factor
@@ -19,9 +19,10 @@ TUPLE: coroutine resumecc exitcc originalcc ;
: coresume ( v co -- result )
[
>>exitcc
- resumecc>> call
+ resumecc>> call( -- )
#! At this point, the coroutine quotation must have terminated
- #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen.
+ #! normally (without calling coyield, coreset, or coterminate).
+ #! This shouldn't happen.
f over
] callcc1 2nip ;
@@ -47,4 +48,4 @@ TUPLE: coroutine resumecc exitcc originalcc ;
: coreset ( v -- )
current-coro get dup
originalcc>> >>resumecc
- exitcc>> continue-with ;
\ No newline at end of file
+ exitcc>> continue-with ;
diff --git a/unmaintained/morse/authors.txt b/extra/couchdb/authors.txt
similarity index 100%
rename from unmaintained/morse/authors.txt
rename to extra/couchdb/authors.txt
diff --git a/extra/couchdb/couchdb-tests.factor b/extra/couchdb/couchdb-tests.factor
new file mode 100644
index 0000000000..d7161a14cd
--- /dev/null
+++ b/extra/couchdb/couchdb-tests.factor
@@ -0,0 +1,46 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs couchdb kernel namespaces sequences strings tools.test ;
+IN: couchdb.tests
+
+! You must have a CouchDB server (currently only the version from svn will
+! work) running on localhost and listening on the default port for these tests
+! to work.
+
+<default-server> "factor-test" <db> [
+ [ ] [ couch get create-db ] unit-test
+ [ couch get create-db ] must-fail
+ [ ] [ couch get delete-db ] unit-test
+ [ couch get delete-db ] must-fail
+ [ ] [ couch get ensure-db ] unit-test
+ [ ] [ couch get ensure-db ] unit-test
+ [ 0 ] [ couch get db-info "doc_count" swap at ] unit-test
+ [ ] [ couch get compact-db ] unit-test
+ [ t ] [ couch get server>> next-uuid string? ] unit-test
+ [ ] [ H{
+ { "Subject" "I like Planktion" }
+ { "Tags" { "plankton" "baseball" "decisions" } }
+ { "Body"
+ "I decided today that I don't like baseball. I like plankton." }
+ { "Author" "Rusty" }
+ { "PostedDate" "2006-08-15T17:30:12Z-04:00" }
+ } save-doc ] unit-test
+ [ t ] [ couch get all-docs "rows" swap at first "id" swap at dup "id" set string? ] unit-test
+ [ t ] [ "id" get dup load-doc id> = ] unit-test
+ [ ] [ "id" get load-doc save-doc ] unit-test
+ [ "Rusty" ] [ "id" get load-doc "Author" swap at ] unit-test
+ [ ] [ "id" get load-doc "Alex" "Author" pick set-at save-doc ] unit-test
+ [ "Alex" ] [ "id" get load-doc "Author" swap at ] unit-test
+ [ 1 ] [ "function(doc) { emit(null, doc) }" temp-view-map "total_rows" swap at ] unit-test
+ [ ] [ H{
+ { "_id" "_design/posts" }
+ { "language" "javascript" }
+ { "views" H{
+ { "all" H{ { "map" "function(doc) { emit(null, doc) }" } } }
+ }
+ }
+ } save-doc ] unit-test
+ [ t ] [ "id" get load-doc delete-doc string? ] unit-test
+ [ "id" get load-doc ] must-fail
+ [ ] [ couch get delete-db ] unit-test
+] with-couch
diff --git a/extra/couchdb/couchdb.factor b/extra/couchdb/couchdb.factor
new file mode 100644
index 0000000000..da71acb074
--- /dev/null
+++ b/extra/couchdb/couchdb.factor
@@ -0,0 +1,200 @@
+! Copyright (C) 2008, 2009 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs continuations debugger hashtables http
+http.client io io.encodings.string io.encodings.utf8 json.reader
+json.writer kernel make math math.parser namespaces sequences strings
+urls urls.encoding vectors ;
+IN: couchdb
+
+! NOTE: This code only works with the latest couchdb (0.9.*), because old
+! versions didn't provide the /_uuids feature which this code relies on when
+! creating new documents.
+
+SYMBOL: couch
+: with-couch ( db quot -- )
+ couch swap with-variable ; inline
+
+! errors
+TUPLE: couchdb-error { data assoc } ;
+C: <couchdb-error> couchdb-error
+
+M: couchdb-error error. ( error -- )
+ "CouchDB Error: " write data>>
+ "error" over at [ print ] when*
+ "reason" swap at [ print ] when* ;
+
+PREDICATE: file-exists-error < couchdb-error
+ data>> "error" swap at "file_exists" = ;
+
+! http tools
+: couch-http-request ( request -- data )
+ [ http-request ] [
+ dup download-failed? [
+ response>> body>> json> <couchdb-error> throw
+ ] [
+ rethrow
+ ] if
+ ] recover nip ;
+
+: couch-request ( request -- assoc )
+ couch-http-request json> ;
+
+: couch-get ( url -- assoc )
+ <get-request> couch-request ;
+
+: couch-put ( post-data url -- assoc )
+ <put-request> couch-request ;
+
+: couch-post ( post-data url -- assoc )
+ <post-request> couch-request ;
+
+: couch-delete ( url -- assoc )
+ <delete-request> couch-request ;
+
+: response-ok ( assoc -- assoc )
+ "ok" over delete-at* and t assert= ;
+
+: response-ok* ( assoc -- )
+ response-ok drop ;
+
+! server
+TUPLE: server { host string } { port integer } { uuids vector } { uuids-to-cache integer } ;
+
+: default-couch-host ( -- host ) "localhost" ; inline
+: default-couch-port ( -- port ) 5984 ; inline
+: default-uuids-to-cache ( -- n ) 100 ; inline
+
+: <server> ( host port -- server )
+ V{ } clone default-uuids-to-cache server boa ;
+
+: <default-server> ( -- server )
+ default-couch-host default-couch-port <server> ;
+
+: (server-url) ( server -- )
+ "http://" % [ host>> % ] [ CHAR: : , port>> number>string % ] bi CHAR: / , ; inline
+
+: server-url ( server -- url )
+ [ (server-url) ] "" make ;
+
+: all-dbs ( server -- dbs )
+ server-url "_all_dbs" append couch-get ;
+
+: uuids-url ( server -- url )
+ [ dup server-url % "_uuids?count=" % uuids-to-cache>> number>string % ] "" make ;
+
+: uuids-get ( server -- uuids )
+ uuids-url couch-get "uuids" swap at >vector ;
+
+: get-uuids ( server -- server )
+ dup uuids-get [ nip ] curry change-uuids ;
+
+: ensure-uuids ( server -- server )
+ dup uuids>> empty? [ get-uuids ] when ;
+
+: next-uuid ( server -- uuid )
+ ensure-uuids uuids>> pop ;
+
+! db
+TUPLE: db { server server } { name string } ;
+C: <db> db
+
+: (db-url) ( db -- )
+ [ server>> server-url % ] [ name>> % ] bi CHAR: / , ; inline
+
+: db-url ( db -- url )
+ [ (db-url) ] "" make ;
+
+: create-db ( db -- )
+ f swap db-url couch-put response-ok* ;
+
+: ensure-db ( db -- )
+ [ create-db ] [
+ dup file-exists-error? [ 2drop ] [ rethrow ] if
+ ] recover ;
+
+: delete-db ( db -- )
+ db-url couch-delete drop ;
+
+: db-info ( db -- info )
+ db-url couch-get ;
+
+: compact-db ( db -- )
+ f swap db-url "_compact" append couch-post response-ok* ;
+
+: all-docs ( db -- docs )
+ ! TODO: queries. Maybe pass in a hashtable with options
+ db-url "_all_docs" append couch-get ;
+
+: <json-post-data> ( assoc -- post-data )
+ >json utf8 encode "application/json" <post-data> swap >>data ;
+
+! documents
+: id> ( assoc -- id ) "_id" swap at ;
+: >id ( assoc id -- assoc ) "_id" pick set-at ;
+: rev> ( assoc -- rev ) "_rev" swap at ;
+: >rev ( assoc rev -- assoc ) "_rev" pick set-at ;
+: attachments> ( assoc -- attachments ) "_attachments" swap at ;
+: >attachments ( assoc attachments -- assoc ) "_attachments" pick set-at ;
+
+: copy-key ( to from to-key from-key -- )
+ rot at spin set-at ;
+
+: copy-id ( to from -- )
+ "_id" "id" copy-key ;
+
+: copy-rev ( to from -- )
+ "_rev" "rev" copy-key ;
+
+: id-url ( id -- url )
+ couch get db-url swap url-encode-full append ;
+
+: doc-url ( assoc -- url )
+ id> id-url ;
+
+: temp-view ( view -- results )
+ <json-post-data> couch get db-url "_temp_view" append couch-post ;
+
+: temp-view-map ( map -- results )
+ "map" H{ } clone [ set-at ] keep temp-view ;
+
+: save-doc-as ( assoc id -- )
+ [ dup <json-post-data> ] dip id-url couch-put response-ok
+ [ copy-id ] [ copy-rev ] 2bi ;
+
+: save-new-doc ( assoc -- )
+ couch get server>> next-uuid save-doc-as ;
+
+: save-doc ( assoc -- )
+ dup id> [ save-doc-as ] [ save-new-doc ] if* ;
+
+: load-doc ( id -- assoc )
+ id-url couch-get ;
+
+: delete-doc ( assoc -- deletion-revision )
+ [
+ [ doc-url % ]
+ [ "?rev=" % "_rev" swap at % ] bi
+ ] "" make couch-delete response-ok "rev" swap at ;
+
+: remove-keys ( assoc keys -- )
+ swap [ delete-at ] curry each ;
+
+: remove-couch-info ( assoc -- )
+ { "_id" "_rev" "_attachments" } remove-keys ;
+
+! : construct-attachment ( content-type data -- assoc )
+! H{ } clone "name" pick set-at "content-type" pick set-at ;
+!
+! : add-attachment ( assoc name attachment -- )
+! pick attachments> [ H{ } clone ] unless*
+!
+! : attach ( assoc name content-type data -- )
+! construct-attachment H{ } clone
+
+! TODO:
+! - startkey, limit, descending, etc.
+! - loading specific revisions
+! - views
+! - attachments
+! - bulk insert/update
+! - ...?
diff --git a/extra/couchdb/tags.txt b/extra/couchdb/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/couchdb/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor
index eff95bbcd6..274e99d2f6 100755
--- a/extra/crypto/hmac/hmac-tests.factor
+++ b/extra/crypto/hmac/hmac-tests.factor
@@ -2,10 +2,37 @@ USING: kernel io strings byte-arrays sequences namespaces math
parser crypto.hmac tools.test ;
IN: crypto.hmac.tests
-[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 <string> "Hi There" byte-array>md5-hmac >string ] unit-test
-[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" byte-array>md5-hmac >string ] unit-test
-[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>md5-hmac >string ] unit-test
+[
+ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
+] [
+ 16 11 <string> "Hi There" sequence>md5-hmac >string ] unit-test
-[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 <string> "Hi There" >byte-array byte-array>sha1-hmac >string ] unit-test
-[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" >byte-array byte-array>sha1-hmac >string ] unit-test
-[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa <string> 50 HEX: dd <repetition> >byte-array byte-array>sha1-hmac >string ] unit-test
+[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
+[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test
+
+[
+ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
+]
+[
+ 16 HEX: aa <string>
+ 50 HEX: dd <repetition> sequence>md5-hmac >string
+] unit-test
+
+[
+ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
+] [
+ 16 11 <string> "Hi There" sequence>sha1-hmac >string
+] unit-test
+
+[
+ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
+] [
+ "Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string
+] unit-test
+
+[
+ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
+] [
+ 16 HEX: aa <string>
+ 50 HEX: dd <repetition> sequence>sha1-hmac >string
+] unit-test
diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor
index 73b15b9473..6e6229f182 100755
--- a/extra/crypto/hmac/hmac.factor
+++ b/extra/crypto/hmac/hmac.factor
@@ -6,6 +6,8 @@ io.streams.byte-array kernel math math.vectors memoize sequences
io.encodings.binary ;
IN: crypto.hmac
+<PRIVATE
+
: sha1-hmac ( Ko Ki -- hmac )
initialize-sha1 process-sha1-block
stream>sha1 get-sha1
@@ -24,6 +26,7 @@ IN: crypto.hmac
[ bitxor ] 2map ;
MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
+
MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: init-hmac ( K -- o i )
@@ -31,13 +34,15 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
[ opad seq-bitxor ] keep
ipad seq-bitxor ;
+PRIVATE>
+
: stream>sha1-hmac ( K stream -- hmac )
[ init-hmac sha1-hmac ] with-input-stream ;
: file>sha1-hmac ( K path -- hmac )
binary <file-reader> stream>sha1-hmac ;
-: byte-array>sha1-hmac ( K string -- hmac )
+: sequence>sha1-hmac ( K sequence -- hmac )
binary <byte-reader> stream>sha1-hmac ;
: stream>md5-hmac ( K stream -- hmac )
@@ -46,5 +51,5 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: file>md5-hmac ( K path -- hmac )
binary <file-reader> stream>md5-hmac ;
-: byte-array>md5-hmac ( K string -- hmac )
+: sequence>md5-hmac ( K sequence -- hmac )
binary <byte-reader> stream>md5-hmac ;
diff --git a/extra/descriptive/descriptive-docs.factor b/extra/descriptive/descriptive-docs.factor
index dc02f8bd9d..6ced201c13 100755
--- a/extra/descriptive/descriptive-docs.factor
+++ b/extra/descriptive/descriptive-docs.factor
@@ -1,20 +1,28 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup words ;
IN: descriptive
HELP: DESCRIPTIVE:
{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }
-{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
+{ $description "Defines a word such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
HELP: DESCRIPTIVE::
{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }
-{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a descriptive tag including the arguments to that word." } ;
+{ $description "Defines a word which uses locals such that, if an error is thrown from within it, that error is wrapped in a " { $link descriptive-error } " with the arguments to that word." } ;
-HELP: descriptive
-{ $class-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
+HELP: descriptive-error
+{ $error-description "The class of errors wrapping another error (in the underlying slot) which were thrown in a word (in the word slot) with a given set of arguments (in the args slot)." } ;
+
+HELP: make-descriptive
+{ $values { "word" word } }
+{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ;
ARTICLE: "descriptive" "Descriptive errors"
-"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in a special descriptor declaring that an error was thrown from inside that word, and including the arguments given to that word. The error is of the following class:"
-{ $subsection descriptive }
+"This vocabulary defines automatic descriptive errors. Using it, you can define a word which acts as normal, except when it throws an error, the error is wrapped in an instance of a class:"
+{ $subsection descriptive-error }
+"The wrapper contains the word itself, the input parameters, as well as the original error."
+$nl
+"To annotate an existing word with descriptive error checking:"
+{ $subsection make-descriptive }
"To define words which throw descriptive errors, use the following words:"
{ $subsection POSTPONE: DESCRIPTIVE: }
{ $subsection POSTPONE: DESCRIPTIVE:: } ;
diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor
index ceadc9fe6e..9af94aa4ed 100755
--- a/extra/descriptive/descriptive.factor
+++ b/extra/descriptive/descriptive.factor
@@ -1,6 +1,9 @@
-USING: words kernel sequences locals locals.parser
+! Copyright (c) 2008 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel sequences locals locals.parser fry
locals.definitions accessors parser namespaces continuations
-summary definitions generalizations arrays prettyprint debugger io ;
+summary definitions generalizations arrays prettyprint debugger io
+effects tools.annotations ;
IN: descriptive
ERROR: descriptive-error args underlying word ;
@@ -23,6 +26,10 @@ M: descriptive-error error.
PRIVATE>
+: make-descriptive ( word -- )
+ dup [ ] [ def>> ] [ stack-effect ] tri [descriptive]
+ '[ drop _ ] annotate-methods ;
+
: define-descriptive ( word def effect -- )
[ drop "descriptive-definition" set-word-prop ]
[ [ [ dup ] 2dip [descriptive] ] keep define-declared ]
diff --git a/extra/descriptive/tags.txt b/extra/descriptive/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/extra/descriptive/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/extra/dns/dns.factor b/extra/dns/dns.factor
index cf98154e7a..6d81f2a14b 100644
--- a/extra/dns/dns.factor
+++ b/extra/dns/dns.factor
@@ -6,7 +6,7 @@ USING: kernel byte-arrays combinators strings arrays sequences splitting
io io.binary io.sockets io.encodings.binary
accessors
combinators.smart
- newfx
+ assocs
;
IN: dns
@@ -148,8 +148,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[
{
[ name>> dn->ba ]
- [ type>> type-table of uint16->ba ]
- [ class>> class-table of uint16->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
} cleave
] output>array concat ;
@@ -203,8 +203,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[
{
[ name>> dn->ba ]
- [ type>> type-table of uint16->ba ]
- [ class>> class-table of uint16->ba ]
+ [ type>> type-table at uint16->ba ]
+ [ class>> class-table at uint16->ba ]
[ ttl>> uint32->ba ]
[
[ type>> ] [ rdata>> ] bi rdata->ba
@@ -219,13 +219,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[
{
[ qr>> 15 shift ]
- [ opcode>> opcode-table of 11 shift ]
+ [ opcode>> opcode-table at 11 shift ]
[ aa>> 10 shift ]
[ tc>> 9 shift ]
[ rd>> 8 shift ]
[ ra>> 7 shift ]
[ z>> 4 shift ]
- [ rcode>> rcode-table of 0 shift ]
+ [ rcode>> rcode-table at 0 shift ]
} cleave
] sum-outputs uint16->ba ;
@@ -301,8 +301,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[ get-name ]
[
skip-name
- [ 0 + get-double type-table key-of ]
- [ 2 + get-double class-table key-of ]
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
2bi
]
2bi query boa ;
@@ -364,10 +364,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
[
skip-name
{
- [ 0 + get-double type-table key-of ]
- [ 2 + get-double class-table key-of ]
+ [ 0 + get-double type-table value-at ]
+ [ 2 + get-double class-table value-at ]
[ 4 + get-quad ]
- [ [ 10 + ] [ get-double type-table key-of ] 2bi get-rdata ]
+ [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ]
}
2cleave
]
@@ -393,13 +393,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
get-double
{
[ 15 >> BIN: 1 bitand ]
- [ 11 >> BIN: 111 bitand opcode-table key-of ]
+ [ 11 >> BIN: 111 bitand opcode-table value-at ]
[ 10 >> BIN: 1 bitand ]
[ 9 >> BIN: 1 bitand ]
[ 8 >> BIN: 1 bitand ]
[ 7 >> BIN: 1 bitand ]
[ 4 >> BIN: 111 bitand ]
- [ BIN: 1111 bitand rcode-table key-of ]
+ [ BIN: 1111 bitand rcode-table value-at ]
}
cleave ;
@@ -484,7 +484,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: message-query ( message -- query ) question-section>> 1st ;
+: message-query ( message -- query ) question-section>> first ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/dns/misc/misc.factor b/extra/dns/misc/misc.factor
index 6e62513a80..af080f61eb 100644
--- a/extra/dns/misc/misc.factor
+++ b/extra/dns/misc/misc.factor
@@ -1,6 +1,6 @@
USING: kernel combinators sequences splitting math
- io.files io.encodings.utf8 random newfx dns.util ;
+ io.files io.encodings.utf8 random dns.util ;
IN: dns.misc
@@ -9,8 +9,8 @@ IN: dns.misc
: resolv-conf-servers ( -- seq )
"/etc/resolv.conf" utf8 file-lines
[ " " split ] map
- [ 1st "nameserver" = ] filter
- [ 2nd ] map ;
+ [ first "nameserver" = ] filter
+ [ second ] map ;
: resolv-conf-server ( -- ip ) resolv-conf-servers random ;
diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor
index b14d765e8d..644533d3a2 100644
--- a/extra/dns/server/server.factor
+++ b/extra/dns/server/server.factor
@@ -2,7 +2,7 @@
USING: kernel combinators sequences sets math threads namespaces continuations
debugger io io.sockets unicode.case accessors destructors
combinators.short-circuit combinators.smart
- newfx fry arrays
+ fry arrays
dns dns.util dns.misc ;
IN: dns.server
@@ -64,7 +64,7 @@ SYMBOL: records-var
[ rr->rdata-names ] map concat ;
: extract-names ( message -- names )
- [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ;
+ [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fill-authority
@@ -99,7 +99,7 @@ DEFER: query->rrs
: matching-cname? ( query -- rrs/f )
[ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs
[ empty? not ]
- [ 1st swap clone over rdata>> >>name query->rrs prefix-on ]
+ [ first swap clone over rdata>> >>name query->rrs swap prefix ]
[ 2drop f ]
1if ;
diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor
index 5b2e63838a..f47eb7010c 100644
--- a/extra/dns/util/util.factor
+++ b/extra/dns/util/util.factor
@@ -28,4 +28,4 @@ TUPLE: packet data addr socket ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
+: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive
\ No newline at end of file
diff --git a/extra/drills/deployed/deploy.factor b/extra/drills/deployed/deploy.factor
new file mode 100644
index 0000000000..2f62912360
--- /dev/null
+++ b/extra/drills/deployed/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+ { deploy-unicode? f }
+ { deploy-threads? t }
+ { deploy-math? t }
+ { deploy-name "drills" }
+ { deploy-ui? t }
+ { deploy-compiler? t }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { deploy-io 2 }
+ { deploy-word-defs? f }
+ { deploy-reflection 1 }
+}
diff --git a/extra/drills/deployed/deployed.factor b/extra/drills/deployed/deployed.factor
new file mode 100644
index 0000000000..43873c99bb
--- /dev/null
+++ b/extra/drills/deployed/deployed.factor
@@ -0,0 +1,36 @@
+USING: accessors arrays cocoa.dialogs combinators continuations
+fry grouping io.encodings.utf8 io.files io.styles kernel math
+math.parser models models.arrow models.history namespaces random
+sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings system ;
+
+IN: drills.deployed
+SYMBOLS: it startLength ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
+: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
+
+: show ( model -- gadget ) dup it set-global [ random ] <arrow>
+ { [ [ first ] card ]
+ [ [ second ] card ]
+ [ '[ |<< it get _ model-changed ] "No" op ]
+ [ '[ |<< [ it get [
+ _ value>> swap remove
+ [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+ ] change-model ] with-return ] "Yes" op ]
+ } cleave
+2array { 1 0 } <track> swap [ 0.5 track-add ] each
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
+
+: drill ( -- ) [
+ open-panel [
+ [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+ [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+ "Got it?" open-window
+ ] [ 0 exit ] if*
+] with-ui ;
+
+MAIN: drill
\ No newline at end of file
diff --git a/extra/drills/deployed/tags.txt b/extra/drills/deployed/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/drills/deployed/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/drills/drills.factor b/extra/drills/drills.factor
index 98da12959b..9ee4e9b6eb 100644
--- a/extra/drills/drills.factor
+++ b/extra/drills/drills.factor
@@ -3,40 +3,34 @@ fry grouping io.encodings.utf8 io.files io.styles kernel math
math.parser models models.arrow models.history namespaces random
sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
-ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks ui.gestures
-ui.gadgets.corners ;
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings ;
IN: drills
SYMBOLS: it startLength ;
-: big ( gadget -- gadget ) { "sans-serif" plain 30 } >>font ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
: show ( model -- gadget ) dup it set-global [ random ] <arrow>
{ [ [ first ] card ]
- [ [ [ second ] [ drop [ "malformed input" throw ] "Malformed Input" alert ] recover ] card ]
- [ '[ |<< [ it get [
- _ value>> swap remove
- [ [ it get go-back ] "Drill Complete" alert return ] when-empty
- ] change-model ] with-return ] "Yes" op ]
- [ '[ |<< it get _ model-changed ] "No" op ] } cleave
+ [ [ second ] card ]
+ [ '[ |<< it get _ model-changed ] "No" op ]
+ [ '[ |<< [ it get [
+ _ value>> swap remove
+ [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+ ] change-model ] with-return ] "Yes" op ]
+ } cleave
2array { 1 0 } <track> swap [ 0.5 track-add ] each
-3array <book*> 3 3 <frame> { 450 175 } >>pref-dim swap @center grid-add
-it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> @bottom grid-add ;
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
-: drill ( -- ) [
+: drill ( -- ) [
open-panel [
- [ utf8 file-lines [ "\t" split
- [ " " split 4 group [ " " join ] map ] map ] map ] map concat dup [ [ first ] [ second ] bi swap 2array ] map append
- [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
- "Got it?" open-window
+ [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+ [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+ "Got it?" open-window
] when*
] with-ui ;
-
-MAIN: drill
-
-
-! FIXME: command-line opening
-! TODO: Menu bar
-! TODO: Pious hot-buttons
\ No newline at end of file
+MAIN: drill
\ No newline at end of file
diff --git a/extra/env/authors.txt b/extra/env/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/env/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/env/env-docs.factor b/extra/env/env-docs.factor
new file mode 100644
index 0000000000..918b30af4b
--- /dev/null
+++ b/extra/env/env-docs.factor
@@ -0,0 +1,13 @@
+! (c)2009 Joe Groff, see bsd license
+USING: help.markup help.syntax ;
+IN: env
+
+HELP: env
+{ $class-description "A singleton that implements the " { $link "assocs-protocol" } " over " { $link "environment" } "." } ;
+
+ARTICLE: "env" "Accessing the environment via the assoc protocol"
+"The " { $vocab-link "env" } " vocabulary defines a " { $link env } " word which implements the " { $link "assocs-protocol" } " over " { $link "environment" } "."
+{ $subsection env }
+;
+
+ABOUT: "env"
diff --git a/extra/env/env.factor b/extra/env/env.factor
new file mode 100644
index 0000000000..f7f4c5d231
--- /dev/null
+++ b/extra/env/env.factor
@@ -0,0 +1,26 @@
+! (c)2009 Joe Groff, see bsd license
+USING: assocs environment kernel sequences ;
+IN: env
+
+SINGLETON: env
+
+INSTANCE: env assoc
+
+M: env at*
+ drop os-env dup >boolean ;
+
+M: env assoc-size
+ drop (os-envs) length ;
+
+M: env >alist
+ drop os-envs >alist ;
+
+M: env set-at
+ drop set-os-env ;
+
+M: env delete-at
+ drop unset-os-env ;
+
+M: env clear-assoc
+ drop os-envs keys [ unset-os-env ] each ;
+
diff --git a/extra/env/summary.txt b/extra/env/summary.txt
new file mode 100644
index 0000000000..bd15472427
--- /dev/null
+++ b/extra/env/summary.txt
@@ -0,0 +1 @@
+Access environment variables via the assoc protocol
diff --git a/extra/file-trees/file-trees-tests.factor b/extra/file-trees/file-trees-tests.factor
new file mode 100644
index 0000000000..dbb8f9f5d8
--- /dev/null
+++ b/extra/file-trees/file-trees-tests.factor
@@ -0,0 +1,4 @@
+USING: kernel file-trees ;
+IN: file-trees.tests
+{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3"
+"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop
\ No newline at end of file
diff --git a/extra/file-trees/file-trees.factor b/extra/file-trees/file-trees.factor
new file mode 100644
index 0000000000..eadfccdc4c
--- /dev/null
+++ b/extra/file-trees/file-trees.factor
@@ -0,0 +1,28 @@
+USING: accessors arrays delegate delegate.protocols
+io.pathnames kernel locals namespaces prettyprint sequences
+ui.frp vectors ;
+IN: file-trees
+
+TUPLE: tree node children ;
+CONSULT: sequence-protocol tree children>> ;
+
+: <tree> ( start -- tree ) V{ } clone
+ [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
+
+DEFER: (tree-insert)
+
+: tree-insert ( path tree -- ) [ unclip <tree> ] [ children>> ] bi* (tree-insert) ;
+:: (tree-insert) ( path-rest path-head tree-children -- )
+ tree-children [ node>> path-head node>> = ] find nip
+ [ path-rest swap tree-insert ]
+ [
+ path-head tree-children push
+ path-rest [ path-head tree-insert ] unless-empty
+ ] if* ;
+: create-tree ( file-list -- tree ) [ path-components ] map
+ t <tree> [ [ tree-insert ] curry each ] keep ;
+
+: <dir-table> ( tree-model -- table )
+ <frp-list*> [ node>> 1array ] >>quot
+ [ selected-value>> <switch> ]
+ [ swap >>model ] bi ;
\ No newline at end of file
diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor
index c3b1a8a3f2..3f7ce863c7 100644
--- a/extra/fuel/eval/eval.factor
+++ b/extra/fuel/eval/eval.factor
@@ -21,7 +21,7 @@ SYMBOL: fuel-eval-res-flag
t fuel-eval-res-flag set-global
: fuel-eval-restartable? ( -- ? )
- fuel-eval-res-flag get-global ; inline
+ fuel-eval-res-flag get-global ;
: fuel-push-status ( -- )
in get use get clone restarts get-global clone
@@ -29,7 +29,7 @@ t fuel-eval-res-flag set-global
fuel-status-stack get push ;
: fuel-pop-restarts ( restarts -- )
- fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline
+ fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ;
: fuel-pop-status ( -- )
fuel-status-stack get empty? [
@@ -39,35 +39,32 @@ t fuel-eval-res-flag set-global
[ restarts>> fuel-pop-restarts ] tri
] unless ;
-: fuel-forget-error ( -- ) f error set-global ; inline
-: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline
-: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline
+: fuel-forget-error ( -- ) f error set-global ;
+: fuel-forget-result ( -- ) f fuel-eval-result set-global ;
+: fuel-forget-output ( -- ) f fuel-eval-output set-global ;
: fuel-forget-status ( -- )
- fuel-forget-error fuel-forget-result fuel-forget-output ; inline
+ fuel-forget-error fuel-forget-result fuel-forget-output ;
: fuel-send-retort ( -- )
error get fuel-eval-result get-global fuel-eval-output get-global
3array fuel-pprint flush nl "<~FUEL~>" write nl flush ;
: (fuel-begin-eval) ( -- )
- fuel-push-status fuel-forget-status ; inline
+ fuel-push-status fuel-forget-status ;
: (fuel-end-eval) ( output -- )
- fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline
+ fuel-eval-output set-global fuel-send-retort fuel-pop-status ;
: (fuel-eval) ( lines -- )
- [ [ parse-lines ] with-compilation-unit call ] curry
- [ print-error ] recover ; inline
-
-: (fuel-eval-each) ( lines -- )
- [ 1vector (fuel-eval) ] each ; inline
+ [ [ parse-lines ] with-compilation-unit call( -- ) ] curry
+ [ print-error ] recover ;
: (fuel-eval-usings) ( usings -- )
- [ "USING: " prepend " ;" append ] map
- (fuel-eval-each) fuel-forget-error fuel-forget-output ;
+ [ [ use+ ] curry [ drop ] recover ] each
+ fuel-forget-error fuel-forget-output ;
: (fuel-eval-in) ( in -- )
- [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
+ [ in set ] when* ;
: (fuel-eval-in-context) ( lines in usings -- )
(fuel-begin-eval)
diff --git a/extra/fuel/fuel-tests.factor b/extra/fuel/fuel-tests.factor
new file mode 100644
index 0000000000..a0cab888e8
--- /dev/null
+++ b/extra/fuel/fuel-tests.factor
@@ -0,0 +1,33 @@
+! Copyright (C) 2009 Nicholas Seckar.
+! See http://factorcode.org/license.txt for BSD license.
+USING: continuations eval fuel fuel.private namespaces tools.test words ;
+IN: fuel.tests
+
+: fake-continuation ( -- continuation )
+ f f f "fake" f <continuation> ;
+
+: make-uses-restart ( -- restart )
+ "Use the words vocabulary" \ word?
+ fake-continuation <restart> ;
+
+: make-defer-restart ( -- restart )
+ "Defer word in current vocabulary" f
+ fake-continuation <restart> ;
+
+{ f } [ make-defer-restart is-use-restart ] unit-test
+{ t } [ make-uses-restart is-use-restart ] unit-test
+
+{ "words" } [ make-uses-restart get-restart-vocab ] unit-test
+
+{ f } [ make-defer-restart is-suggested-restart ] unit-test
+{ f } [ make-uses-restart is-suggested-restart ] unit-test
+{ f } [ { "io" } :uses-suggestions
+ [ make-uses-restart is-suggested-restart ] with-variable
+] unit-test
+{ t } [ { "words" } :uses-suggestions
+ [ make-uses-restart is-suggested-restart ] with-variable
+] unit-test
+
+{ } [
+ { "kernel" } [ "\\ dup drop" eval( -- ) ] fuel-use-suggested-vocabs
+] unit-test
diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor
index 403708e880..a9ed17877e 100644
--- a/extra/fuel/fuel.factor
+++ b/extra/fuel/fuel.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs compiler.units fuel.eval fuel.help fuel.remote fuel.xref
-help.topics io.pathnames kernel namespaces parser sequences
-tools.scaffold vocabs.loader ;
+USING: accessors assocs compiler.units continuations fuel.eval fuel.help
+fuel.remote fuel.xref help.topics io.pathnames kernel namespaces parser
+sequences tools.scaffold vocabs.loader words ;
IN: fuel
@@ -28,6 +28,22 @@ IN: fuel
<PRIVATE
SYMBOL: :uses
+SYMBOL: :uses-suggestions
+
+: is-use-restart ( restart -- ? )
+ name>> [ "Use the " head? ] [ " vocabulary" tail? ] bi and ;
+
+: get-restart-vocab ( restart -- vocab/f )
+ obj>> dup word? [ vocabulary>> ] [ drop f ] if ;
+
+: is-suggested-restart ( restart -- ? )
+ dup is-use-restart [
+ get-restart-vocab :uses-suggestions get member?
+ ] [ drop f ] if ;
+
+: try-suggested-restarts ( -- )
+ restarts get [ is-suggested-restart ] filter
+ dup length 1 = [ first restart ] [ drop ] if ;
: fuel-set-use-hook ( -- )
[ amended-use get clone :uses prefix fuel-eval-set-result ]
@@ -38,6 +54,10 @@ SYMBOL: :uses
PRIVATE>
+: fuel-use-suggested-vocabs ( suggestions quot -- ... )
+ [ :uses-suggestions set ] dip
+ [ try-suggested-restarts rethrow ] recover ; inline
+
: fuel-run-file ( path -- )
[ fuel-set-use-hook run-file ] curry with-scope ; inline
@@ -104,7 +124,7 @@ PRIVATE>
: fuel-vocab-summary ( name -- )
(fuel-vocab-summary) fuel-eval-set-result ;
-: fuel-index ( quot -- ) call format-index fuel-eval-set-result ;
+: fuel-index ( quot -- ) call( -- seq ) format-index fuel-eval-set-result ;
: fuel-get-vocabs/tag ( tag -- )
(fuel-get-vocabs/tag) fuel-eval-set-result ;
diff --git a/extra/fuel/help/help.factor b/extra/fuel/help/help.factor
index 30d6845a9b..6c43e646df 100644
--- a/extra/fuel/help/help.factor
+++ b/extra/fuel/help/help.factor
@@ -3,8 +3,8 @@
USING: accessors arrays assocs combinators help help.crossref
help.markup help.topics io io.streams.string kernel make namespaces
-parser prettyprint sequences summary tools.vocabs help.vocabs
-vocabs vocabs.loader words see ;
+parser prettyprint sequences summary help.vocabs
+vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see ;
IN: fuel.help
@@ -21,9 +21,9 @@ IN: fuel.help
[ see ] with-string-writer ; inline
: fuel-methods-str ( word -- str )
- methods dup empty? not [
+ methods [ f ] [
[ [ see nl ] each ] with-string-writer
- ] [ drop f ] if ; inline
+ ] if-empty ; inline
: fuel-related-words ( word -- seq )
dup "related" word-prop remove ; inline
diff --git a/extra/fuel/pprint/pprint.factor b/extra/fuel/pprint/pprint.factor
index 9dcbd76368..41f1102768 100644
--- a/extra/fuel/pprint/pprint.factor
+++ b/extra/fuel/pprint/pprint.factor
@@ -3,7 +3,7 @@
USING: accessors arrays classes.tuple combinators continuations io
kernel lexer math prettyprint quotations sequences source-files
-strings words ;
+source-files.errors strings words ;
IN: fuel.pprint
diff --git a/extra/fuel/xref/xref.factor b/extra/fuel/xref/xref.factor
index ec06b9892e..160b7212c4 100644
--- a/extra/fuel/xref/xref.factor
+++ b/extra/fuel/xref/xref.factor
@@ -3,7 +3,7 @@
USING: accessors arrays assocs definitions help.topics io.pathnames
kernel math math.order memoize namespaces sequences sets sorting
-tools.completion tools.crossref tools.vocabs vocabs vocabs.parser
+tools.completion tools.crossref vocabs vocabs.parser vocabs.hierarchy
words ;
IN: fuel.xref
diff --git a/extra/galois-talk/galois-talk.factor b/extra/galois-talk/galois-talk.factor
index be713542ed..ba929867e9 100644
--- a/extra/galois-talk/galois-talk.factor
+++ b/extra/galois-talk/galois-talk.factor
@@ -3,7 +3,7 @@
USING: slides help.markup math arrays hashtables namespaces
sequences kernel sequences parser memoize io.encodings.binary
locals kernel.private help.vocabs assocs quotations
-urls peg.ebnf tools.vocabs tools.annotations tools.crossref
+urls peg.ebnf tools.annotations tools.crossref
help.topics math.functions compiler.tree.optimizer
compiler.cfg.optimizer fry ;
IN: galois-talk
diff --git a/extra/game-input/dinput/dinput.factor b/extra/game-input/dinput/dinput.factor
index a2beaf6d9b..20815859ab 100755
--- a/extra/game-input/dinput/dinput.factor
+++ b/extra/game-input/dinput/dinput.factor
@@ -2,10 +2,10 @@ USING: windows.dinput windows.dinput.constants parser
alien.c-types windows.ole32 namespaces assocs kernel arrays
vectors windows.kernel32 windows.com windows.dinput shuffle
windows.user32 windows.messages sequences combinators locals
-math.rectangles accessors math windows alien
-alien.strings io.encodings.utf16 io.encodings.utf16n
-continuations byte-arrays game-input.dinput.keys-array
-game-input ui.backend.windows ;
+math.rectangles accessors math alien alien.strings
+io.encodings.utf16 io.encodings.utf16n continuations
+byte-arrays game-input.dinput.keys-array game-input
+ui.backend.windows windows.errors ;
IN: game-input.dinput
SINGLETON: dinput-game-input-backend
@@ -22,7 +22,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
+dinput+ set-global ;
: delete-dinput ( -- )
- +dinput+ global [ com-release f ] change-at ;
+ +dinput+ [ com-release f ] change-global ;
: device-for-guid ( guid -- device )
+dinput+ get swap f <void*>
@@ -172,10 +172,8 @@ TUPLE: window-rect < rect window-loc ;
[ +device-change-window+ set-global ] bi ;
: close-device-change-window ( -- )
- +device-change-handle+ global
- [ UnregisterDeviceNotification drop f ] change-at
- +device-change-window+ global
- [ DestroyWindow win32-error=0/f f ] change-at ;
+ +device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
+ +device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;
: add-wm-devicechange ( -- )
[ 4dup handle-wm-devicechange DefWindowProc ]
@@ -185,14 +183,11 @@ TUPLE: window-rect < rect window-loc ;
WM_DEVICECHANGE wm-handlers get-global delete-at ;
: release-controllers ( -- )
- +controller-devices+ global [
- [ drop com-release ] assoc-each f
- ] change-at
+ +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
f +controller-guids+ set-global ;
: release-keyboard ( -- )
- +keyboard-device+ global
- [ com-release f ] change-at
+ +keyboard-device+ [ com-release f ] change-global
f +keyboard-state+ set-global ;
M: dinput-game-input-backend (open-game-input)
diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor
index 254ed61ab0..2ded263899 100755
--- a/extra/game-input/iokit/iokit.factor
+++ b/extra/game-input/iokit/iokit.factor
@@ -239,7 +239,7 @@ M: iokit-game-input-backend (reset-game-input)
M: iokit-game-input-backend (close-game-input)
+hid-manager+ get-global [
- +hid-manager+ global [
+ +hid-manager+ [
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerUnscheduleFromRunLoop
@@ -247,7 +247,7 @@ M: iokit-game-input-backend (close-game-input)
[ 0 IOHIDManagerClose drop ]
[ CFRelease ] tri
f
- ] change-at
+ ] change-global
f +keyboard-state+ set-global
f +controller-states+ set-global
] when ;
diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor
new file mode 100644
index 0000000000..8e7c7017d4
--- /dev/null
+++ b/extra/game-loop/game-loop.factor
@@ -0,0 +1,93 @@
+USING: accessors destructors kernel math math.order namespaces
+system threads ;
+IN: game-loop
+
+TUPLE: game-loop
+ { tick-length integer read-only }
+ delegate
+ { last-tick integer }
+ thread
+ { running? boolean }
+ { tick-number integer }
+ { frame-number integer }
+ { benchmark-time integer }
+ { benchmark-tick-number integer }
+ { benchmark-frame-number integer } ;
+
+GENERIC: tick* ( delegate -- )
+GENERIC: draw* ( tick-slice delegate -- )
+
+SYMBOL: game-loop
+
+: since-last-tick ( loop -- milliseconds )
+ last-tick>> millis swap - ;
+
+: tick-slice ( loop -- slice )
+ [ since-last-tick ] [ tick-length>> ] bi /f 1.0 min ;
+
+CONSTANT: MAX-FRAMES-TO-SKIP 5
+
+<PRIVATE
+
+: redraw ( loop -- )
+ [ 1+ ] change-frame-number
+ [ tick-slice ] [ delegate>> ] bi draw* ;
+
+: tick ( loop -- )
+ delegate>> tick* ;
+
+: increment-tick ( loop -- )
+ [ 1+ ] change-tick-number
+ dup tick-length>> [ + ] curry change-last-tick
+ drop ;
+
+: ?tick ( loop count -- )
+ dup zero? [ drop millis >>last-tick drop ] [
+ over [ since-last-tick ] [ tick-length>> ] bi >=
+ [ [ drop increment-tick ] [ drop tick ] [ 1- ?tick ] 2tri ]
+ [ 2drop ] if
+ ] if ;
+
+: (run-loop) ( loop -- )
+ dup running?>>
+ [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ]
+ [ drop ] if ;
+
+: run-loop ( loop -- )
+ dup game-loop [ (run-loop) ] with-variable ;
+
+: benchmark-millis ( loop -- millis )
+ millis swap benchmark-time>> - ;
+
+PRIVATE>
+
+: reset-loop-benchmark ( loop -- )
+ millis >>benchmark-time
+ dup tick-number>> >>benchmark-tick-number
+ dup frame-number>> >>benchmark-frame-number
+ drop ;
+
+: benchmark-ticks-per-second ( loop -- n )
+ [ tick-number>> ] [ benchmark-tick-number>> - ] [ benchmark-millis ] tri /f ;
+: benchmark-frames-per-second ( loop -- n )
+ [ frame-number>> ] [ benchmark-frame-number>> - ] [ benchmark-millis ] tri /f ;
+
+: start-loop ( loop -- )
+ millis >>last-tick
+ t >>running?
+ [ reset-loop-benchmark ]
+ [ [ run-loop ] curry "game loop" spawn ]
+ [ (>>thread) ] tri ;
+
+: stop-loop ( loop -- )
+ f >>running?
+ f >>thread
+ drop ;
+
+: <game-loop> ( tick-length delegate -- loop )
+ millis f f 0 0 millis 0 0
+ game-loop boa ;
+
+M: game-loop dispose
+ stop-loop ;
+
diff --git a/extra/google-tech-talk/google-tech-talk.factor b/extra/google-tech-talk/google-tech-talk.factor
index ab8e72fc76..8e2eeeb1a7 100644
--- a/extra/google-tech-talk/google-tech-talk.factor
+++ b/extra/google-tech-talk/google-tech-talk.factor
@@ -3,7 +3,7 @@
USING: slides help.markup math arrays hashtables namespaces
sequences kernel sequences parser memoize io.encodings.binary
locals kernel.private help.vocabs assocs quotations
-urls peg.ebnf tools.vocabs tools.annotations tools.crossref
+urls peg.ebnf tools.annotations tools.crossref
help.topics math.functions compiler.tree.optimizer
compiler.cfg.optimizer fry ;
IN: google-tech-talk
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 61315a4925..d95c79dd88 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays hashtables html.parser.state
+USING: accessors arrays hashtables sequence-parser
html.parser.utils kernel namespaces sequences
unicode.case unicode.categories combinators.short-circuit
quoting fry ;
@@ -37,89 +37,89 @@ SYMBOL: tagstack
swap >>name
swap >>text ; inline
-: (read-quote) ( state-parser ch -- string )
+: (read-quote) ( sequence-parser ch -- string )
'[ [ current _ = ] take-until ] [ advance drop ] bi ;
-: read-single-quote ( state-parser -- string )
+: read-single-quote ( sequence-parser -- string )
CHAR: ' (read-quote) ;
-: read-double-quote ( state-parser -- string )
+: read-double-quote ( sequence-parser -- string )
CHAR: " (read-quote) ;
-: read-quote ( state-parser -- string )
+: read-quote ( sequence-parser -- string )
dup get+increment CHAR: ' =
[ read-single-quote ] [ read-double-quote ] if ;
-: read-key ( state-parser -- string )
+: read-key ( sequence-parser -- string )
skip-whitespace
[ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
-: read-token ( state-parser -- string )
+: read-token ( sequence-parser -- string )
[ current blank? ] take-until ;
-: read-value ( state-parser -- string )
+: read-value ( sequence-parser -- string )
skip-whitespace
dup current quote? [ read-quote ] [ read-token ] if
[ blank? ] trim ;
-: read-comment ( state-parser -- )
+: read-comment ( sequence-parser -- )
"-->" take-until-sequence comment new-tag push-tag ;
-: read-dtd ( state-parser -- )
+: read-dtd ( sequence-parser -- )
">" take-until-sequence dtd new-tag push-tag ;
-: read-bang ( state-parser -- )
+: read-bang ( sequence-parser -- )
advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
[ advance advance read-comment ] [ read-dtd ] if ;
-: read-tag ( state-parser -- string )
+: read-tag ( sequence-parser -- string )
[ [ current "><" member? ] take-until ]
[ dup current CHAR: < = [ advance ] unless drop ] bi ;
-: read-until-< ( state-parser -- string )
+: read-until-< ( sequence-parser -- string )
[ current CHAR: < = ] take-until ;
-: parse-text ( state-parser -- )
+: parse-text ( sequence-parser -- )
read-until-< [ text new-tag push-tag ] unless-empty ;
-: parse-key/value ( state-parser -- key value )
+: parse-key/value ( sequence-parser -- key value )
[ read-key >lower ]
[ skip-whitespace "=" take-sequence ]
[ swap [ read-value ] [ drop dup ] if ] tri ;
-: (parse-attributes) ( state-parser -- )
+: (parse-attributes) ( sequence-parser -- )
skip-whitespace
- dup state-parse-end? [
+ dup sequence-parse-end? [
drop
] [
[ parse-key/value swap set ] [ (parse-attributes) ] bi
] if ;
-: parse-attributes ( state-parser -- hashtable )
+: parse-attributes ( sequence-parser -- hashtable )
[ (parse-attributes) ] H{ } make-assoc ;
: (parse-tag) ( string -- string' hashtable )
[
[ read-token >lower ] [ parse-attributes ] bi
- ] state-parse ;
+ ] parse-sequence ;
-: read-< ( state-parser -- string/f )
+: read-< ( sequence-parser -- string/f )
advance dup current [
CHAR: ! = [ read-bang f ] [ read-tag ] if
] [
drop f
] if* ;
-: parse-tag ( state-parser -- )
+: parse-tag ( sequence-parser -- )
read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
-: (parse-html) ( state-parser -- )
+: (parse-html) ( sequence-parser -- )
dup peek-next [
[ parse-text ] [ parse-tag ] [ (parse-html) ] tri
] [ drop ] if ;
: tag-parse ( quot -- vector )
- V{ } clone tagstack [ state-parse ] with-variable ; inline
+ V{ } clone tagstack [ parse-sequence ] with-variable ; inline
PRIVATE>
diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
deleted file mode 100644
index c8a8a95892..0000000000
--- a/extra/html/parser/state/state-tests.factor
+++ /dev/null
@@ -1,104 +0,0 @@
-USING: tools.test html.parser.state ascii kernel accessors ;
-IN: html.parser.state.tests
-
-[ "hello" ]
-[ "hello" [ take-rest ] state-parse ] unit-test
-
-[ "hi" " how are you?" ]
-[
- "hi how are you?"
- [ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse
-] unit-test
-
-[ "foo" ";bar" ]
-[
- "foo;bar" [
- [ CHAR: ; take-until-object ] [ take-rest ] bi
- ] state-parse
-] unit-test
-
-[ "foo " " bar" ]
-[
- "foo and bar" [
- [ "and" take-until-sequence ] [ take-rest ] bi
- ] state-parse
-] unit-test
-
-[ 6 ]
-[
- " foo " [ skip-whitespace n>> ] state-parse
-] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 } <state-parser> [ current 3 = ] take-until ] unit-test
-
-[ { 1 2 } ]
-[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
-
-[ "ab" ]
-[ "abcd" <state-parser> "ab" take-sequence ] unit-test
-
-[ f ]
-[ "abcd" <state-parser> "lol" take-sequence ] unit-test
-
-[ "ab" ]
-[
- "abcd" <state-parser>
- [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
-] unit-test
-
-[ "" ]
-[ "abcd" <state-parser> "" take-sequence ] unit-test
-
-[ "cd" ]
-[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
-
-[ f ]
-[
- "\"abc\" asdf" <state-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
-] unit-test
-
-[ "abc\\\"def" ]
-[
- "\"abc\\\"def\" asdf" <state-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "asdf" ]
-[
- "\"abc\" asdf" <state-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ skip-whitespace "asdf" take-sequence ] bi
-] unit-test
-
-[ f ]
-[
- "\"abc asdf" <state-parser>
- CHAR: \ CHAR: " take-quoted-string
-] unit-test
-
-[ "\"abc" ]
-[
- "\"abc asdf" <state-parser>
- [ CHAR: \ CHAR: " take-quoted-string drop ]
- [ "\"abc" take-sequence ] bi
-] unit-test
-
-[ "c" ]
-[ "c" <state-parser> take-token ] unit-test
-
-[ f ]
-[ "" <state-parser> take-token ] unit-test
-
-[ "abcd e \\\"f g" ]
-[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
-
-[ "" ]
-[ "" <state-parser> take-rest ] unit-test
-
-[ "" ]
-[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
-
-[ f ]
-[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
deleted file mode 100644
index 2bcd08be5f..0000000000
--- a/extra/html/parser/state/state.factor
+++ /dev/null
@@ -1,127 +0,0 @@
-! Copyright (C) 2005, 2009 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals combinators.short-circuit
-make combinators io splitting ;
-
-IN: html.parser.state
-
-TUPLE: state-parser sequence n ;
-
-: <state-parser> ( sequence -- state-parser )
- state-parser new
- swap >>sequence
- 0 >>n ;
-
-: offset ( state-parser offset -- char/f )
- swap
- [ n>> + ] [ sequence>> ?nth ] bi ; inline
-
-: current ( state-parser -- char/f ) 0 offset ; inline
-
-: previous ( state-parser -- char/f ) -1 offset ; inline
-
-: peek-next ( state-parser -- char/f ) 1 offset ; inline
-
-: advance ( state-parser -- state-parser )
- [ 1 + ] change-n ; inline
-
-: advance* ( state-parser -- )
- advance drop ; inline
-
-: get+increment ( state-parser -- char/f )
- [ current ] [ advance drop ] bi ; inline
-
-:: skip-until ( state-parser quot: ( obj -- ? ) -- )
- state-parser current [
- state-parser quot call [ state-parser advance quot skip-until ] unless
- ] when ; inline recursive
-
-: state-parse-end? ( state-parser -- ? ) current not ;
-
-: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
- over state-parse-end? [
- 2drop f
- ] [
- [ drop n>> ]
- [ skip-until ]
- [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
- ] if ; inline
-
-: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
- [ not ] compose take-until ; inline
-
-: <safe-slice> ( from to seq -- slice/f )
- 3dup {
- [ 2drop 0 < ]
- [ [ drop ] 2dip length > ]
- [ drop > ]
- } 3|| [ 3drop f ] [ slice boa ] if ; inline
-
-:: take-sequence ( state-parser sequence -- obj/f )
- state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
- <safe-slice> sequence sequence= [
- sequence
- state-parser [ sequence length + ] change-n drop
- ] [
- f
- ] if ;
-
-:: take-until-sequence ( state-parser sequence -- sequence' )
- sequence length <growing-circular> :> growing
- state-parser
- [
- current growing push-growing-circular
- sequence growing sequence=
- ] take-until :> found
- found dup length
- growing length 1- - head
- state-parser advance drop ;
-
-: skip-whitespace ( state-parser -- state-parser )
- [ [ current blank? not ] take-until drop ] keep ;
-
-: take-rest-slice ( state-parser -- sequence/f )
- [ sequence>> ] [ n>> ] bi
- 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
-
-: take-rest ( state-parser -- sequence )
- [ take-rest-slice ] [ sequence>> like ] bi ;
-
-: take-until-object ( state-parser obj -- sequence )
- '[ current _ = ] take-until ;
-
-: state-parse ( sequence quot -- )
- [ <state-parser> ] dip call ; inline
-
-:: take-quoted-string ( state-parser escape-char quote-char -- string )
- state-parser n>> :> start-n
- state-parser advance
- [
- {
- [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
- [ current quote-char = not ]
- } 1||
- ] take-while :> string
- state-parser current quote-char = [
- state-parser advance* string
- ] [
- start-n state-parser (>>n) f
- ] if ;
-
-: (take-token) ( state-parser -- string )
- skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
-
-:: take-token* ( state-parser escape-char quote-char -- string/f )
- state-parser skip-whitespace
- dup current {
- { quote-char [ escape-char quote-char take-quoted-string ] }
- { f [ drop f ] }
- [ drop (take-token) ]
- } case ;
-
-: take-token ( state-parser -- string/f )
- CHAR: \ CHAR: " take-token* ;
-
-: write-full ( state-parser -- ) sequence>> write ;
-: write-rest ( state-parser -- ) take-rest write ;
diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor
index 7abd2fcdf7..afd63daf6b 100644
--- a/extra/html/parser/utils/utils.factor
+++ b/extra/html/parser/utils/utils.factor
@@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math namespaces prettyprint
-quotations sequences splitting html.parser.state strings
-combinators.short-circuit quoting ;
+quotations sequences splitting strings quoting
+combinators.short-circuit ;
IN: html.parser.utils
: trim1 ( seq ch -- newseq )
diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor
index feb110fab8..c43559a630 100644
--- a/extra/id3/id3-docs.factor
+++ b/extra/id3/id3-docs.factor
@@ -7,7 +7,7 @@ IN: id3
HELP: mp3>id3
{ $values
{ "path" "a path string" }
- { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
+ { "id3/f" "a tuple storing ID3v2 metadata or f" } }
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
{ $list
{ $link title }
@@ -22,49 +22,49 @@ HELP: mp3>id3
HELP: album
{ $values
- { "id3" id3v2-info }
- { "album/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: artist
{ $values
- { "id3" id3v2-info }
- { "artist/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: comment
{ $values
- { "id3" id3v2-info }
- { "comment/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: genre
{ $values
- { "id3" id3v2-info }
- { "genre/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: title
{ $values
- { "id3" id3v2-info }
- { "title/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: year
{ $values
- { "id3" id3v2-info }
- { "year/f" "string or f" }
+ { "id3" id3 }
+ { "string/f" "string or f" }
}
{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
HELP: find-id3-frame
{ $values
- { "id3" id3v2-info } { "name" string }
+ { "id3" id3 } { "name" string }
{ "obj/f" "object or f" }
}
{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;
diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor
index a8f35e582c..9bb7558077 100644
--- a/extra/id3/id3-tests.factor
+++ b/extra/id3/id3-tests.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2009 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test id3 combinators ;
+USING: tools.test id3 combinators grouping id3.private
+sequences math ;
IN: id3.tests
: id3-params ( id3 -- title artist album year comment genre )
@@ -40,3 +41,6 @@ IN: id3.tests
"Big Band"
] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
+
+[ t ]
+[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor
index 8e824d689f..79df00ff5e 100644
--- a/extra/id3/id3.factor
+++ b/extra/id3/id3.factor
@@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays
io.encodings.string io.encodings.utf16 assocs math.parser
combinators.short-circuit fry namespaces combinators.smart
splitting io.encodings.ascii arrays io.files.info unicode.case
-io.directories.search ;
+io.directories.search literals math.functions continuations ;
IN: id3
<PRIVATE
@@ -37,103 +37,132 @@ CONSTANT: genres
"Primus" "Porn Groove" "Satire" "Slow Jam" "Club" "Tango"
"Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
"Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella"
- "Euro-House" "Dance Hall"
+ "Euro-House" "Dance Hall" "Goa" "Drum & Bass" "Club-House"
+ "Hardcore" "Terror" "Indie" "BritPop" "Negerpunk"
+ "Polsk Punk" "Beat" "Christian Gangsta Rap" "Heavy Metal"
+ "Black Metal" "Crossover" "Contemporary Christian"
+ "Christian Rock"
}
TUPLE: header version flags size ;
-TUPLE: frame frame-id flags size data ;
+TUPLE: frame tag flags size data ;
-TUPLE: id3v2-info header frames ;
+TUPLE: id3 header frames
+title artist album year comment genre
+speed genre-name start-time end-time ;
-TUPLE: id3v1-info title artist album year comment genre ;
-
-: <id3v1-info> ( -- object ) id3v1-info new ; inline
-
-: <id3v2-info> ( header frames -- object )
- [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
+: <id3> ( -- id3 )
+ id3 new
+ H{ } clone >>frames ; inline
: <header> ( -- object ) header new ; inline
: <frame> ( -- object ) frame new ; inline
-: id3v2? ( mmap -- ? ) "ID3" head? ; inline
+: id3v2? ( seq -- ? ) "ID3" head? ; inline
-: id3v1? ( mmap -- ? )
- { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
+CONSTANT: id3v1-length 128
+CONSTANT: id3v1-offset 128
+CONSTANT: id3v1+-length 227
+CONSTANT: id3v1+-offset $[ 128 227 + ]
-: id3v1-frame ( string key -- frame )
- <frame>
- swap >>frame-id
- swap >>data ; inline
+: id3v1? ( seq -- ? )
+ {
+ [ length id3v1-offset >= ]
+ [ id3v1-length tail-slice* "TAG" head? ]
+ } 1&& ;
-: id3v1>id3v2 ( id3v1 -- id3v2 )
+: id3v1+? ( seq -- ? )
+ {
+ [ length id3v1+-offset >= ]
+ [ id3v1+-length tail-slice* "TAG+" head? ]
+ } 1&& ;
+
+: pair>frame ( string key -- frame/f )
+ over [
+ <frame>
+ swap >>tag
+ swap >>data
+ ] [
+ 2drop f
+ ] if ;
+
+: id3v1>frames ( id3v1 -- seq )
[
{
- [ title>> "TIT2" id3v1-frame ]
- [ artist>> "TPE1" id3v1-frame ]
- [ album>> "TALB" id3v1-frame ]
- [ year>> "TYER" id3v1-frame ]
- [ comment>> "COMM" id3v1-frame ]
- [ genre>> "TCON" id3v1-frame ]
+ [ title>> "TIT2" pair>frame ]
+ [ artist>> "TPE1" pair>frame ]
+ [ album>> "TALB" pair>frame ]
+ [ year>> "TYER" pair>frame ]
+ [ comment>> "COMM" pair>frame ]
+ [ genre>> "TCON" pair>frame ]
} cleave
- ] output>array f swap <id3v2-info> ; inline
+ ] output>array sift ;
-: >28bitword ( seq -- int )
- 0 [ [ 7 shift ] dip bitor ] reduce ; inline
+: seq>synchsafe ( seq -- n )
+ 0 [ [ 7 shift ] dip bitor ] reduce ;
+
+: synchsafe>seq ( n -- seq )
+ dup 1+ log2 1+ 7 / ceiling
+ [ [ -7 shift ] keep HEX: 7f bitand ] replicate nip reverse ;
: filter-text-data ( data -- filtered )
- [ printable? ] filter ; inline
+ [ printable? ] filter ;
-: valid-frame-id? ( id -- ? )
- [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline
+: valid-tag? ( id -- ? )
+ [ { [ digit? ] [ LETTER? ] } 1|| ] all? ;
-: read-frame-data ( frame mmap -- frame data )
- [ 10 over size>> 10 + ] dip <slice> filter-text-data ; inline
+: read-frame-data ( frame seq -- frame data )
+ [ 10 over size>> 10 + ] dip <slice> filter-text-data ;
: decode-text ( string -- string' )
dup 2 short head
{ { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member?
- utf16 ascii ? decode ; inline
+ utf16 ascii ? decode ;
-: (read-frame) ( mmap -- frame )
+: (read-frame) ( seq -- frame )
[ <frame> ] dip
{
- [ 4 head-slice decode-text >>frame-id ]
- [ [ 4 8 ] dip subseq >28bitword >>size ]
+ [ 4 head-slice decode-text >>tag ]
+ [ [ 4 8 ] dip subseq seq>synchsafe >>size ]
[ [ 8 10 ] dip subseq >byte-array >>flags ]
[ read-frame-data decode-text >>data ]
- } cleave ; inline
+ } cleave ;
-: read-frame ( mmap -- frame/f )
- dup 4 head-slice valid-frame-id?
- [ (read-frame) ] [ drop f ] if ; inline
+: read-frame ( seq -- frame/f )
+ dup 4 head-slice valid-tag?
+ [ (read-frame) ] [ drop f ] if ;
-: remove-frame ( mmap frame -- mmap )
- size>> 10 + tail-slice ; inline
+: remove-frame ( seq frame -- seq )
+ size>> 10 + tail-slice ;
-: read-frames ( mmap -- frames )
- [ dup read-frame dup ]
- [ [ remove-frame ] keep ]
- produce 2nip ; inline
+: frames>assoc ( seq -- assoc )
+ [ [ tag>> ] keep ] H{ } map>assoc ;
+
+: read-frames ( seq -- assoc )
+ [ dup read-frame dup ] [ [ remove-frame ] keep ] produce 2nip ;
-: read-v2-header ( seq -- id3header )
+: read-v2-header ( seq -- header )
[ <header> ] dip
{
[ [ 3 5 ] dip <slice> >array >>version ]
[ [ 5 ] dip nth >>flags ]
- [ [ 6 10 ] dip <slice> >28bitword >>size ]
- } cleave ; inline
+ [ [ 6 10 ] dip <slice> seq>synchsafe >>size ]
+ } cleave ;
-: read-v2-tag-data ( seq -- id3v2-info )
+: merge-frames ( id3 assoc -- id3 )
+ [ dup frames>> ] dip update ;
+
+: merge-id3v1 ( id3 -- id3 )
+ dup id3v1>frames frames>assoc merge-frames ;
+
+: read-v2-tags ( id3 seq -- id3 )
10 cut-slice
- [ read-v2-header ]
- [ read-frames ] bi* <id3v2-info> ; inline
+ [ read-v2-header >>header ]
+ [ read-frames frames>assoc merge-frames ] bi* ;
-: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
-
-: (read-v1-tag-data) ( seq -- mp3-file )
- [ <id3v1-info> ] dip
+: extract-v1-tags ( id3 seq -- id3 )
{
[ 30 head-slice decode-text filter-text-data >>title ]
[ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ]
@@ -141,10 +170,32 @@ TUPLE: id3v1-info title artist album year comment genre ;
[ [ 90 94 ] dip subseq decode-text filter-text-data >>year ]
[ [ 94 124 ] dip subseq decode-text filter-text-data >>comment ]
[ [ 124 ] dip nth number>string >>genre ]
- } cleave ; inline
+ } cleave ;
-: read-v1-tag-data ( seq -- mp3-file )
- skip-to-v1-data (read-v1-tag-data) ; inline
+: read-v1-tags ( id3 seq -- id3 )
+ id3v1-offset tail-slice* 3 tail-slice
+ extract-v1-tags ;
+
+: extract-v1+-tags ( id3 seq -- id3 )
+ {
+ [ 60 head-slice decode-text filter-text-data [ append ] change-title ]
+ [
+ [ 60 120 ] dip subseq decode-text filter-text-data
+ [ append ] change-artist
+ ]
+ [
+ [ 120 180 ] dip subseq decode-text filter-text-data
+ [ append ] change-album
+ ]
+ [ [ 180 ] dip nth >>speed ]
+ [ [ 181 211 ] dip subseq decode-text >>genre-name ]
+ [ [ 211 217 ] dip subseq decode-text >>start-time ]
+ [ [ 217 223 ] dip subseq decode-text >>end-time ]
+ } cleave ;
+
+: read-v1+-tags ( id3 seq -- id3 )
+ id3v1+-offset tail-slice* 4 tail-slice
+ extract-v1+-tags ;
: parse-genre ( string -- n/f )
dup "(" ?head-slice drop ")" ?tail-slice drop
@@ -152,47 +203,47 @@ TUPLE: id3v1-info title artist album year comment genre ;
genres ?nth swap or
] [
drop
- ] if ; inline
-
-: (mp3>id3) ( path -- id3v2-info/f )
- [
- {
- { [ dup id3v2? ] [ read-v2-tag-data ] }
- { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] }
- [ drop f ]
- } cond
- ] with-mapped-uchar-file ;
-
-: (find-id3-frame) ( id3 name quot: ( obj -- obj' ) -- obj' )
- [ swap frames>> at* ] dip
- [ data>> ] prepose [ drop f ] if ; inline
+ ] if ;
PRIVATE>
-: mp3>id3 ( path -- id3v2-info/f )
- dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
+: mp3>id3 ( path -- id3/f )
+ [
+ [ <id3> ] dip
+ {
+ [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
+ } cleave
+ ] with-mapped-uchar-file-reader ;
: find-id3-frame ( id3 name -- obj/f )
- [ ] (find-id3-frame) ; inline
+ swap frames>> at* [ data>> ] when ;
-: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
+: title ( id3 -- string/f ) "TIT2" find-id3-frame ;
-: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
+: artist ( id3 -- string/f ) "TPE1" find-id3-frame ;
-: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
+: album ( id3 -- string/f ) "TALB" find-id3-frame ;
-: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
+: year ( id3 -- string/f ) "TYER" find-id3-frame ;
-: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
+: comment ( id3 -- string/f ) "COMM" find-id3-frame ;
-: genre ( id3 -- genre/f )
- "TCON" [ parse-genre ] (find-id3-frame) ; inline
+: genre ( id3 -- string/f )
+ "TCON" find-id3-frame parse-genre ;
: find-mp3s ( path -- seq )
- [ >lower ".mp3" tail? ] find-all-files ; inline
+ [ >lower ".mp3" tail? ] find-all-files ;
+
+ERROR: id3-parse-error path error ;
+
+: (mp3-paths>id3s) ( seq -- seq' )
+ [ dup [ mp3>id3 ] [ \ id3-parse-error boa ] recover ] { } map>assoc ;
: mp3-paths>id3s ( seq -- seq' )
- [ dup mp3>id3 ] { } map>assoc ; inline
+ (mp3-paths>id3s)
+ [ dup second id3-parse-error? [ f over set-second ] when ] map ;
: parse-mp3-directory ( path -- seq )
find-mp3s mp3-paths>id3s ;
diff --git a/extra/images/normalization/authors.txt b/extra/images/normalization/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/images/normalization/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/images/normalization/normalization.factor b/extra/images/normalization/normalization.factor
similarity index 100%
rename from basis/images/normalization/normalization.factor
rename to extra/images/normalization/normalization.factor
diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor
index 4eaa984953..2818c16f9f 100644
--- a/extra/images/viewer/viewer.factor
+++ b/extra/images/viewer/viewer.factor
@@ -1,37 +1,27 @@
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel namespaces
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
-ui.gadgets.panes ui.render ;
+ui.gadgets.panes ui.render ui.images ;
IN: images.viewer
-TUPLE: image-gadget < gadget { image image } ;
+TUPLE: image-gadget < gadget image-name ;
M: image-gadget pref-dim*
- image>> dim>> ;
-
-: draw-image ( image -- )
- 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
- [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
- glDrawPixels ;
+ image-name>> image-dim ;
M: image-gadget draw-gadget* ( gadget -- )
- image>> draw-image ;
+ image-name>> draw-image ;
-: <image-gadget> ( image -- gadget )
+: <image-gadget> ( image-name -- gadget )
\ image-gadget new
- swap >>image ;
+ swap >>image-name ;
: image-window ( path -- gadget )
- [ load-image <image-gadget> dup ] [ open-window ] bi ;
+ [ <image-name> <image-gadget> dup ] [ open-window ] bi ;
GENERIC: image. ( object -- )
-: default-image. ( path -- )
- <image-gadget> gadget. ;
+M: string image. ( image -- ) <image-name> <image-gadget> gadget. ;
-M: string image. ( image -- ) load-image default-image. ;
-
-M: pathname image. ( image -- ) load-image default-image. ;
-
-M: image image. ( image -- ) default-image. ;
+M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;
diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor
index ed268e558d..5597422898 100644
--- a/extra/infix/infix.factor
+++ b/extra/infix/infix.factor
@@ -40,7 +40,7 @@ M: ast-array infix-codegen
M: ast-op infix-codegen
[ left>> infix-codegen ] [ right>> infix-codegen ]
[ op>> select-op ] tri
- 2over [ number? ] both? [ call ] [
+ 2over [ number? ] both? [ call( a b -- c ) ] [
[ [ prepare-operand ] bi@ ] dip '[ @ @ @ ]
] if ;
diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor
index d6b5d0559c..fa598a4ac6 100644
--- a/extra/infix/parser/parser-tests.factor
+++ b/extra/infix/parser/parser-tests.factor
@@ -3,9 +3,6 @@
USING: infix.ast infix.parser infix.tokenizer tools.test ;
IN: infix.parser.tests
-\ parse-infix must-infer
-\ build-infix-ast must-infer
-
[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test
[ T{ ast-negation f T{ ast-number { value 1 } } } ]
[ "-1" build-infix-ast ] unit-test
diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor
index f9c908414a..b068881b84 100644
--- a/extra/infix/tokenizer/tokenizer-tests.factor
+++ b/extra/infix/tokenizer/tokenizer-tests.factor
@@ -3,7 +3,6 @@
USING: infix.ast infix.tokenizer tools.test ;
IN: infix.tokenizer.tests
-\ tokenize-infix must-infer
[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test
[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test
[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ]
diff --git a/extra/irc/client/base/authors.txt b/extra/irc/client/base/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/irc/client/base/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/irc/client/base/base.factor b/extra/irc/client/base/base.factor
new file mode 100644
index 0000000000..f54e18ac4b
--- /dev/null
+++ b/extra/irc/client/base/base.factor
@@ -0,0 +1,37 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs concurrency.mailboxes io kernel namespaces
+strings words.symbol irc.client.chats irc.messages ;
+EXCLUDE: sequences => join ;
+IN: irc.client.base
+
+SYMBOL: current-irc-client
+
+: irc> ( -- irc-client ) current-irc-client get ;
+: stream> ( -- stream ) irc> stream>> ;
+: irc-print ( s -- ) stream> [ stream-print ] [ stream-flush ] bi ;
+: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
+: chats> ( -- seq ) irc> chats>> values ;
+: me? ( string -- ? ) irc> nick>> = ;
+
+: with-irc ( irc-client quot: ( -- ) -- )
+ \ current-irc-client swap with-variable ; inline
+
+UNION: to-target privmsg notice ;
+UNION: to-channel join part topic kick rpl-channel-modes
+ rpl-notopic rpl-topic rpl-names rpl-names-end ;
+UNION: to-one-chat to-target to-channel mode ;
+UNION: to-many-chats nick quit ;
+UNION: to-all-chats irc-end irc-disconnected irc-connected ;
+PREDICATE: to-me < to-target target>> me? ;
+
+GENERIC: chat-name ( irc-message -- name )
+M: mode chat-name name>> ;
+M: to-target chat-name target>> ;
+M: to-me chat-name sender>> ;
+M: to-channel chat-name channel>> ;
+
+GENERIC: chat> ( obj -- chat/f )
+M: string chat> irc> chats>> at ;
+M: symbol chat> irc> chats>> at ;
+M: to-one-chat chat> chat-name +server-chat+ or chat> ;
diff --git a/extra/irc/client/chats/authors.txt b/extra/irc/client/chats/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/irc/client/chats/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/irc/client/chats/chats-docs.factor b/extra/irc/client/chats/chats-docs.factor
new file mode 100644
index 0000000000..8ab2968eb7
--- /dev/null
+++ b/extra/irc/client/chats/chats-docs.factor
@@ -0,0 +1,22 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax quotations kernel ;
+IN: irc.client.chats
+
+HELP: irc-client "IRC Client object" ;
+
+HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
+
+HELP: irc-channel-chat "Chat for irc channels" ;
+
+HELP: irc-nick-chat "Chat for irc users" ;
+
+HELP: irc-profile "IRC Client profile object" ;
+
+HELP: irc-chat-end "Message sent to a chat when it has been detached from the client, the chat should stop after it receives this message." ;
+
+HELP: irc-end "Message sent when the client isn't running anymore, the chat should stop after it receives this message." ;
+
+HELP: irc-disconnected "Message sent to notify chats that connection was lost." ;
+
+HELP: irc-connected "Message sent to notify chats that a connection with the irc server was established." ;
diff --git a/extra/irc/client/chats/chats.factor b/extra/irc/client/chats/chats.factor
new file mode 100644
index 0000000000..7910afb22a
--- /dev/null
+++ b/extra/irc/client/chats/chats.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors concurrency.mailboxes kernel calendar io.sockets io.encodings.8-bit
+destructors arrays sequences ;
+IN: irc.client.chats
+
+CONSTANT: irc-port 6667 ! Default irc port
+
+TUPLE: irc-chat in-messages client ;
+TUPLE: irc-server-chat < irc-chat ;
+TUPLE: irc-channel-chat < irc-chat name password participants clear-participants ;
+TUPLE: irc-nick-chat < irc-chat name ;
+SYMBOL: +server-chat+
+
+: <irc-server-chat> ( -- irc-server-chat )
+ irc-server-chat new
+ <mailbox> >>in-messages ;
+
+: <irc-channel-chat> ( name -- irc-channel-chat )
+ irc-channel-chat new
+ swap >>name
+ <mailbox> >>in-messages
+ f >>password
+ H{ } clone >>participants
+ t >>clear-participants ;
+
+: <irc-nick-chat> ( name -- irc-nick-chat )
+ irc-nick-chat new
+ swap >>name
+ <mailbox> >>in-messages ;
+
+TUPLE: irc-profile server port nickname password ;
+C: <irc-profile> irc-profile
+
+TUPLE: irc-client profile stream in-messages out-messages
+ chats is-running nick connect reconnect-time is-ready
+ exceptions ;
+
+: <irc-client> ( profile -- irc-client )
+ dup nickname>> irc-client new
+ swap >>nick
+ swap >>profile
+ <mailbox> >>in-messages
+ <mailbox> >>out-messages
+ H{ } clone >>chats
+ 15 seconds >>reconnect-time
+ V{ } clone >>exceptions
+ [ <inet> latin1 <client> ] >>connect ;
+
+SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;
diff --git a/extra/irc/client/chats/summary.txt b/extra/irc/client/chats/summary.txt
new file mode 100644
index 0000000000..6e9493bfa5
--- /dev/null
+++ b/extra/irc/client/chats/summary.txt
@@ -0,0 +1 @@
+IRC Client and Chat object definitions
diff --git a/extra/irc/client/client-docs.factor b/extra/irc/client/client-docs.factor
index 6d4fae9b83..aa0bcb3bf3 100644
--- a/extra/irc/client/client-docs.factor
+++ b/extra/irc/client/client-docs.factor
@@ -1,16 +1,9 @@
-USING: help.markup help.syntax quotations kernel irc.messages ;
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax quotations kernel
+irc.messages irc.messages.base irc.messages.parser irc.client.chats ;
IN: irc.client
-HELP: irc-client "IRC Client object" ;
-
-HELP: irc-server-chat "Chat for server messages unmanaged by other chats" ;
-
-HELP: irc-channel-chat "Chat for irc channels" ;
-
-HELP: irc-nick-chat "Chat for irc users" ;
-
-HELP: irc-profile "IRC Client profile object" ;
-
HELP: connect-irc "Connecting to an irc server"
{ $values { "irc-client" "an irc client object" } }
{ $description "Connects and logins " { $link irc-client } " using the settings specified on its " { $link irc-profile } "." } ;
@@ -56,30 +49,31 @@ ARTICLE: "irc.client" "IRC Client"
"Some of the RFC defined irc messages as objects:"
{ $table
{ { $link irc-message } "base of all irc messages" }
- { { $link logged-in } "logged in to server" }
+ { { $link rpl-welcome } "logged in to server" }
{ { $link ping } "ping message" }
{ { $link join } "channel join" }
{ { $link part } "channel part" }
{ { $link quit } "quit from irc" }
{ { $link privmsg } "private message (to client or channel)" }
{ { $link kick } "kick from channel" }
- { { $link roomlist } "list of participants in channel" }
- { { $link nick-in-use } "chosen nick is in use by another client" }
+ { { $link rpl-names } "list of participants in channel" }
+ { { $link rpl-nickname-in-use } "chosen nick is in use by another client" }
{ { $link notice } "notice message" }
{ { $link mode } "mode change" }
{ { $link unhandled } "uninmplemented/unhandled message" }
}
+
{ $heading "Special messages" }
"Some special messages that are created by the library and not by the irc server."
{ $table
{ { $link irc-chat-end } "sent to a chat when it has been detached from the client, the chat should stop after it receives this message. " }
- { { $link irc-end } " sent when the client isn't running anymore, chats should stop after it receives this message." }
+ { { $link irc-end } " sent when the client isn't running anymore, the chat should stop after it receives this message." }
{ { $link irc-disconnected } " sent to notify chats that connection was lost." }
{ { $link irc-connected } " sent to notify chats that a connection with the irc server was established." } }
{ $heading "Example:" }
{ $code
- "USING: irc.client ;"
+ "USING: irc.client irc.client.chats ;"
"SYMBOL: bot"
"SYMBOL: mychannel"
"! Create the profile and client objects"
@@ -91,7 +85,7 @@ ARTICLE: "irc.client" "IRC Client"
"! Register and start chat (this joins the channel)"
"mychannel get bot get attach-chat"
"! Send a message to the channel"
- "\"what's up?\" mychannel get speak"
+ "\"Hello World!\" mychannel get speak"
"! Read a message from the channel"
"mychannel get hear"
}
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 97fa659209..ae48d3ac4e 100755
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -1,383 +1,15 @@
! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
- accessors destructors namespaces io assocs arrays fry
- continuations threads strings classes combinators splitting hashtables
- ascii irc.messages ;
-RENAME: join sequences => sjoin
-EXCLUDE: sequences => join ;
+USING: accessors concurrency.mailboxes destructors
+irc.client.base irc.client.chats irc.client.internals kernel
+namespaces sequences ;
IN: irc.client
-! ======================================
-! Setup and running objects
-! ======================================
-
-CONSTANT: irc-port 6667 ! Default irc port
-
-TUPLE: irc-profile server port nickname password ;
-C: <irc-profile> irc-profile
-
-TUPLE: irc-client profile stream in-messages out-messages
- chats is-running nick connect reconnect-time is-ready ;
-
-: <irc-client> ( profile -- irc-client )
- irc-client new
- swap >>profile
- <mailbox> >>in-messages
- <mailbox> >>out-messages
- H{ } clone >>chats
- dup profile>> nickname>> >>nick
- [ <inet> latin1 <client> ] >>connect
- 15 seconds >>reconnect-time ;
-
-TUPLE: irc-chat in-messages client ;
-TUPLE: irc-server-chat < irc-chat ;
-TUPLE: irc-channel-chat < irc-chat name password timeout participants clean-participants ;
-TUPLE: irc-nick-chat < irc-chat name ;
-SYMBOL: +server-chat+
-
-! participant modes
-SYMBOL: +operator+
-SYMBOL: +voice+
-SYMBOL: +normal+
-
-: participant-mode ( n -- mode )
- H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
-
-! participant changed actions
-SYMBOL: +join+
-SYMBOL: +part+
-SYMBOL: +mode+
-SYMBOL: +nick+
-
-! chat objects
-: <irc-server-chat> ( -- irc-server-chat )
- <mailbox> f irc-server-chat boa ;
-
-: <irc-channel-chat> ( name -- irc-channel-chat )
- [ <mailbox> f ] dip f 60 seconds H{ } clone t
- irc-channel-chat boa ;
-
-: <irc-nick-chat> ( name -- irc-nick-chat )
- [ <mailbox> f ] dip irc-nick-chat boa ;
-
-! ======================================
-! Message objects
-! ======================================
-
-TUPLE: participant-changed nick action parameter ;
-C: <participant-changed> participant-changed
-
-SINGLETON: irc-chat-end ! sent to a chat to stop its execution
-SINGLETON: irc-end ! sent when the client isn't running anymore
-SINGLETON: irc-disconnected ! sent when connection is lost
-SINGLETON: irc-connected ! sent when connection is established
-
-: terminate-irc ( irc-client -- )
- [ is-running>> ] keep and [
- f >>is-running
- [ stream>> dispose ] keep
- [ in-messages>> ] [ out-messages>> ] bi 2array
- [ irc-end swap mailbox-put ] each
- ] when* ;
-
-<PRIVATE
-
-SYMBOL: current-irc-client
-
-! ======================================
-! Utils
-! ======================================
-
-: irc> ( -- irc-client ) current-irc-client get ;
-: irc-write ( s -- ) irc> stream>> stream-write ;
-: irc-print ( s -- ) irc> stream>> [ stream-print ] keep stream-flush ;
-: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
-: chat> ( name -- chat/f ) irc> chats>> at ;
-: channel-mode? ( mode -- ? ) name>> first "#&" member? ;
-: me? ( string -- ? ) irc> nick>> = ;
-
-GENERIC: to-chat ( message obj -- )
-
-M: string to-chat
- chat> [ +server-chat+ chat> ] unless*
- [ to-chat ] [ drop ] if* ;
-
-M: irc-chat to-chat in-messages>> mailbox-put ;
-
-: unregister-chat ( name -- )
- irc> chats>>
- [ at [ irc-chat-end ] dip to-chat ]
- [ delete-at ]
- 2bi ;
-
-: (remove-participant) ( nick chat -- )
- [ participants>> delete-at ]
- [ [ +part+ f <participant-changed> ] dip to-chat ] 2bi ;
-
-: remove-participant ( nick channel -- )
- chat> [ (remove-participant) ] [ drop ] if* ;
-
-: chats-with-participant ( nick -- seq )
- irc> chats>> values
- [ [ irc-channel-chat? ] keep and [ participants>> key? ] [ drop f ] if* ]
- with filter ;
-
-: to-chats-with-participant ( message nickname -- )
- chats-with-participant [ to-chat ] with each ;
-
-: remove-participant-from-all ( nick -- )
- dup chats-with-participant [ (remove-participant) ] with each ;
-
-: notify-rename ( newnick oldnick chat -- )
- [ participant-changed new +nick+ >>action
- [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-chat ;
-
-: rename-participant ( newnick oldnick chat -- )
- [ participants>> [ delete-at* drop ] [ swapd set-at ] bi ]
- [ notify-rename ] 3bi ;
-
-: rename-participant-in-all ( oldnick newnick -- )
- swap dup chats-with-participant [ rename-participant ] with with each ;
-
-: add-participant ( mode nick channel -- )
- chat>
- [ participants>> set-at ]
- [ [ +join+ f <participant-changed> ] dip to-chat ] 2bi ;
-
-: change-participant-mode ( channel mode nick -- )
- rot chat>
- [ participants>> set-at ]
- [ [ participant-changed new
- [ (>>nick) ] [ (>>parameter) ] [ +mode+ >>action ] tri ] dip to-chat ]
- 3bi ; ! FIXME
-
-! ======================================
-! IRC client messages
-! ======================================
-
-: /NICK ( nick -- )
- "NICK " irc-write irc-print ;
-
-: /LOGIN ( nick -- )
- dup /NICK
- "USER " irc-write irc-write
- " hostname servername :irc.factor" irc-print ;
-
-: /CONNECT ( server port -- stream )
- irc> connect>> call drop ; inline
-
-: /JOIN ( channel password -- )
- "JOIN " irc-write
- [ [ " :" ] dip 3append ] when* irc-print ;
-
-: /PONG ( text -- )
- "PONG " irc-write irc-print ;
-
-! ======================================
-! Server message handling
-! ======================================
-
-GENERIC: initialize-chat ( chat -- )
-M: irc-chat initialize-chat drop ;
-M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
-
-GENERIC: forward-name ( irc-message -- name )
-M: join forward-name trailing>> ;
-M: part forward-name channel>> ;
-M: kick forward-name channel>> ;
-M: mode forward-name name>> ;
-M: privmsg forward-name dup name>> me? [ irc-message-sender ] [ name>> ] if ;
-
-UNION: single-forward join part kick mode privmsg ;
-UNION: multiple-forward nick quit ;
-UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
-GENERIC: forward-message ( irc-message -- )
-
-M: irc-message forward-message
- +server-chat+ chat> [ to-chat ] [ drop ] if* ;
-
-M: single-forward forward-message dup forward-name to-chat ;
-
-M: multiple-forward forward-message
- dup irc-message-sender to-chats-with-participant ;
-
-M: broadcast-forward forward-message
- irc> chats>> values [ to-chat ] with each ;
-
-GENERIC: process-message ( irc-message -- )
-M: object process-message drop ;
-M: logged-in process-message
- name>> t irc> [ (>>is-ready) ] [ (>>nick) ] [ chats>> ] tri
- values [ initialize-chat ] each ;
-M: ping process-message trailing>> /PONG ;
-M: nick-in-use process-message name>> "_" append /NICK ;
-
-M: join process-message
- [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri
- dup chat> [ add-participant ] [ 3drop ] if ;
-
-M: part process-message
- [ irc-message-sender ] [ channel>> ] bi remove-participant ;
-
-M: kick process-message
- [ [ who>> ] [ channel>> ] bi remove-participant ]
- [ dup who>> me? [ unregister-chat ] [ drop ] if ]
- bi ;
-
-M: quit process-message
- irc-message-sender remove-participant-from-all ;
-
-M: nick process-message
- [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
-
-M: mode process-message ( mode -- )
- [ channel-mode? ] keep and [
- [ name>> ] [ mode>> ] [ parameter>> ] tri
- [ change-participant-mode ] [ 2drop ] if*
- ] when* ;
-
-: >nick/mode ( string -- nick mode )
- dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
-
-: names-reply>participants ( names-reply -- participants )
- trailing>> [ blank? ] trim " " split
- [ >nick/mode 2array ] map >hashtable ;
-
-: maybe-clean-participants ( channel-chat -- )
- dup clean-participants>> [
- H{ } clone >>participants f >>clean-participants
- ] when drop ;
-
-M: names-reply process-message
- [ names-reply>participants ] [ channel>> chat> ] bi [
- [ maybe-clean-participants ]
- [ participants>> 2array assoc-combine ]
- [ (>>participants) ] tri
- ] [ drop ] if* ;
-
-M: end-of-names process-message
- channel>> chat> [
- t >>clean-participants
- [ f f f <participant-changed> ] dip name>> to-chat
- ] when* ;
-
-! ======================================
-! Client message handling
-! ======================================
-
-GENERIC: handle-outgoing-irc ( irc-message -- ? )
-M: irc-end handle-outgoing-irc drop f ;
-M: irc-message handle-outgoing-irc irc-message>client-line irc-print t ;
-
-! ======================================
-! Reader/Writer
-! ======================================
-
-: handle-reader-message ( irc-message -- )
- irc> in-messages>> mailbox-put ;
-
-DEFER: (connect-irc)
-
-: (handle-disconnect) ( -- )
- irc>
- [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
- [ dup reconnect-time>> sleep (connect-irc) ]
- [ nick>> /LOGIN ]
- tri ;
-
-! FIXME: do something with the exception, store somewhere to help debugging
-: handle-disconnect ( error -- ? )
- drop irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
-
-: (reader-loop) ( -- ? )
- irc> stream>> [
- |dispose stream-readln [
- parse-irc-line handle-reader-message t
- ] [
- handle-disconnect
- ] if*
- ] with-destructors ;
-
-: reader-loop ( -- ? )
- [ (reader-loop) ] [ handle-disconnect ] recover ;
-
-: writer-loop ( -- ? )
- irc> out-messages>> mailbox-get handle-outgoing-irc ;
-
-! ======================================
-! Processing loops
-! ======================================
-
-: in-multiplexer-loop ( -- ? )
- irc> in-messages>> mailbox-get
- [ forward-message ] [ process-message ] [ irc-end? not ] tri ;
-
-: strings>privmsg ( name string -- privmsg )
- privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
-
-: maybe-annotate-with-name ( name obj -- obj )
- { { [ dup string? ] [ strings>privmsg ] }
- { [ dup privmsg instance? ] [ swap >>name ] }
- [ nip ]
- } cond ;
-
-GENERIC: annotate-message ( chat object -- object )
-M: object annotate-message nip ;
-M: part annotate-message swap name>> >>channel ;
-M: privmsg annotate-message swap name>> >>name ;
-M: string annotate-message [ name>> ] dip strings>privmsg ;
-
-: spawn-irc ( -- )
- [ reader-loop ] "irc-reader-loop" spawn-server
- [ writer-loop ] "irc-writer-loop" spawn-server
- [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
- 3drop ;
-
-GENERIC: (attach-chat) ( irc-chat -- )
-USE: prettyprint
-M: irc-chat (attach-chat)
- [ [ irc> >>client ] [ name>> ] bi irc> chats>> set-at ]
- [ [ irc> is-ready>> ] dip and [ initialize-chat ] when* ]
- bi ;
-
-M: irc-server-chat (attach-chat)
- irc> >>client +server-chat+ irc> chats>> set-at ;
-
-GENERIC: (remove-chat) ( irc-chat -- )
-
-M: irc-nick-chat (remove-chat)
- name>> unregister-chat ;
-
-M: irc-channel-chat (remove-chat)
- [ part new annotate-message irc> out-messages>> mailbox-put ] keep
- name>> unregister-chat ;
-
-M: irc-server-chat (remove-chat)
- drop +server-chat+ unregister-chat ;
-
-: (connect-irc) ( irc-client -- )
- {
- [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
- [ (>>stream) ]
- [ t swap (>>is-running) ]
- [ in-messages>> [ irc-connected ] dip mailbox-put ]
- } cleave ;
-
-: with-irc-client ( irc-client quot: ( -- ) -- )
- [ \ current-irc-client ] dip with-variable ; inline
-
-PRIVATE>
-
: connect-irc ( irc-client -- )
- dup [ [ (connect-irc) ] [ nick>> /LOGIN ] bi spawn-irc ] with-irc-client ;
-
-: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc-client ;
-
-: detach-chat ( irc-chat -- )
- [ client>> ] keep '[ _ (remove-chat) ] with-irc-client ;
-
-: speak ( message irc-chat -- )
- [ swap annotate-message ] [ client>> out-messages>> mailbox-put ] bi ;
+ [ (connect-irc) (do-login) spawn-irc ] with-irc ;
+: attach-chat ( irc-chat irc-client -- ) [ (attach-chat) ] with-irc ;
+: detach-chat ( irc-chat -- ) dup [ client>> remove-chat ] with-irc ;
+: speak ( message irc-chat -- ) dup client>> [ (speak) ] with-irc ;
: hear ( irc-chat -- message ) in-messages>> mailbox-get ;
+: terminate-irc ( irc-client -- ) [ (terminate-irc) ] with-irc ;
diff --git a/extra/irc/client/internals/authors.txt b/extra/irc/client/internals/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/irc/client/internals/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/internals/internals-tests.factor
similarity index 52%
rename from extra/irc/client/client-tests.factor
rename to extra/irc/client/internals/internals-tests.factor
index c1cbdcf8b8..27b5648f97 100644
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/internals/internals-tests.factor
@@ -1,10 +1,13 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test accessors arrays sequences
- io io.streams.duplex namespaces threads destructors
- calendar irc.client.private irc.client irc.messages.private
- concurrency.mailboxes classes assocs combinators ;
+io io.streams.duplex namespaces threads destructors
+calendar concurrency.mailboxes classes assocs combinators
+irc.messages.parser irc.client.base irc.client.chats
+irc.client.participants irc.client.internals ;
EXCLUDE: irc.messages => join ;
RENAME: join irc.messages => join_
-IN: irc.client.tests
+IN: irc.client.internals.tests
! Streams for testing
TUPLE: mb-writer lines last-line disposed ;
@@ -28,18 +31,20 @@ M: mb-writer dispose drop ;
t >>is-ready
t >>is-running
<test-stream> >>stream
- dup [ spawn-irc yield ] with-irc-client ;
+ dup [ spawn-irc yield ] with-irc ;
-! to be used inside with-irc-client quotations
-: %add-named-chat ( chat -- ) irc> attach-chat ;
+! to be used inside with-irc quotations
+: %add-named-chat ( chat -- ) (attach-chat) ;
: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
-: %join ( channel -- ) <irc-channel-chat> irc> attach-chat ;
+: %push-lines ( lines -- ) [ %push-line ] each ;
+: %join ( channel -- ) <irc-channel-chat> (attach-chat) ;
+: %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ;
: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
- [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
+ [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; inline
-: with-irc ( quot: ( -- ) -- )
- [ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline
+: spawning-irc ( quot: ( -- ) -- )
+ [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! TESTS
@@ -49,170 +54,160 @@ M: mb-writer dispose drop ;
{ "factorbot" } [ irc> nick>> ] unit-test
- { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
-
{ "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- parse-irc-line forward-name ] unit-test
+ string>irc-message chat-name ] unit-test
{ "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
- parse-irc-line forward-name ] unit-test
-] with-irc
+ string>irc-message chat-name ] unit-test
+] spawning-irc
+
+{ privmsg "#channel" "hello" } [
+ "#channel" "hello" strings>privmsg
+ [ class ] [ target>> ] [ trailing>> ] tri
+] unit-test
! Test login and nickname set
[ { "factorbot2" } [
":some.where 001 factorbot2 :Welcome factorbot2" %push-line
irc> nick>>
] unit-test
-] with-irc
+] spawning-irc
! Test connect
{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
"someserver" irc-port "factorbot" f <irc-profile> <irc-client>
[ 2drop <test-stream> t ] >>connect
- [ connect-irc ] [ stream>> out>> lines>> ] [ terminate-irc ] tri
+ [
+ (connect-irc)
+ (do-login)
+ irc> stream>> out>> lines>>
+ (terminate-irc)
+ ] with-irc
] unit-test
! Test join
[ { "JOIN #factortest" } [
- "#factortest" %join
- irc> stream>> out>> lines>> pop
+ "#factortest" %join %pop-output-line
] unit-test
-] with-irc
+] spawning-irc
-[ { join_ "#factortest" } [
+[ { join_ "#factortest"} [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
{ ":factorbot!n=factorbo@some.where JOIN :#factortest"
":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list."
":ircserver.net 477 factorbot #factortest :[ircserver-info] blah blah"
- } [ %push-line ] each
- in-messages>> 0.1 seconds mailbox-get-timeout
- [ class ] [ trailing>> ] bi
+ } %push-lines
+ [ join? ] read-matching-message
+ [ class ] [ channel>> ] bi
] unit-test
-] with-irc
-
-[ { T{ participant-changed f "somebody" +join+ } } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":somebody!n=somebody@some.where JOIN :#factortest" %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
+] spawning-irc
[ { privmsg "#factortest" "hello" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":somebody!n=somebody@some.where PRIVMSG #factortest :hello" %push-line
[ privmsg? ] read-matching-message
- [ class ] [ name>> ] [ trailing>> ] tri
+ [ class ] [ target>> ] [ trailing>> ] tri
] unit-test
-] with-irc
+] spawning-irc
[ { privmsg "factorbot" "hello" } [
"ircuser" <irc-nick-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net PRIVMSG factorbot :hello" %push-line
[ privmsg? ] read-matching-message
- [ class ] [ name>> ] [ trailing>> ] tri
+ [ class ] [ target>> ] [ trailing>> ] tri
] unit-test
-] with-irc
+] spawning-irc
-[ { mode } [
+[ { mode "#factortest" "+ns" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircserver.net MODE #factortest +ns" %push-line
- [ mode? ] read-matching-message class
+ [ mode? ] read-matching-message
+ [ class ] [ name>> ] [ mode>> ] tri
] unit-test
-] with-irc
+] spawning-irc
! Participant lists tests
-[ { H{ { "ircuser" +normal+ } } } [
+[ { { "ircuser" } } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
":ircuser!n=user@isp.net JOIN :#factortest" %push-line
- participants>>
+ participants>> keys
] unit-test
-] with-irc
+] spawning-irc
-[ { H{ { "ircuser2" +normal+ } } } [
+[ { { "ircuser2" } } [
"#factortest" <irc-channel-chat>
- H{ { "ircuser2" +normal+ }
- { "ircuser" +normal+ } } clone >>participants
+ { "ircuser2" "ircuser" } [ over join-participant ] each
[ %add-named-chat ] keep
":ircuser!n=user@isp.net PART #factortest" %push-line
- participants>>
+ participants>> keys
] unit-test
-] with-irc
+] spawning-irc
-[ { H{ { "ircuser2" +normal+ } } } [
+[ { { "ircuser2" } } [
"#factortest" <irc-channel-chat>
- H{ { "ircuser2" +normal+ }
- { "ircuser" +normal+ } } clone >>participants
+ { "ircuser2" "ircuser" } [ over join-participant ] each
[ %add-named-chat ] keep
":ircuser!n=user@isp.net QUIT" %push-line
- participants>>
+ participants>> keys
] unit-test
-] with-irc
+] spawning-irc
-[ { H{ { "ircuser2" +normal+ } } } [
+[ { { "ircuser2" } } [
"#factortest" <irc-channel-chat>
- H{ { "ircuser2" +normal+ }
- { "ircuser" +normal+ } } clone >>participants
+ { "ircuser2" "ircuser" } [ over join-participant ] each
[ %add-named-chat ] keep
":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
- participants>>
+ participants>> keys
] unit-test
-] with-irc
+] spawning-irc
-[ { H{ { "ircuser2" +normal+ } } } [
+[ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [
"#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
+ "ircuser" over join-participant
[ %add-named-chat ] keep
":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
participants>>
] unit-test
-] with-irc
+] spawning-irc
-[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [
+[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } }
+ { "ircuser" T{ participant { nick "ircuser" } } }
+ { "voiced" T{ participant { nick "voiced" } { voice t } } } } } [
"#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
+ "ircuser" over join-participant
[ %add-named-chat ] keep
- ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
- ":ircserver.net 353 factorbot @ #factortest :ircuser2 " %push-line
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
- ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
- ":ircserver.net 353 factorbot @ #factortest :ircuser " %push-line
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
+ { ":ircserver.net 353 factorbot @ #factortest :@factorbot "
+ ":ircserver.net 353 factorbot @ #factortest :ircuser2 "
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+ ":ircserver.net 353 factorbot @ #factortest :@factorbot +voiced "
+ ":ircserver.net 353 factorbot @ #factortest :ircuser "
+ ":ircserver.net 366 factorbot #factortest :End of /NAMES list."
+ } %push-lines
participants>>
] unit-test
-] with-irc
+] spawning-irc
-! Namelist change notification
-[ { T{ participant-changed f f f f } } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":ircserver.net 353 factorbot @ #factortest :@factorbot " %push-line
- ":ircserver.net 366 factorbot #factortest :End of /NAMES list." %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
-
-[ { T{ participant-changed f "ircuser" +part+ f } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user@isp.net QUIT" %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
-
-[ { T{ participant-changed f "ircuser" +nick+ "ircuser2" } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
-
-! Mode change
-[ { T{ participant-changed f "ircuser" +mode+ "+o" } } [
+[ { mode "#factortest" "+o" "ircuser" } [
"#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ "ircuser" over join-participant
":ircserver.net MODE #factortest +o ircuser" %push-line
- [ participant-changed? ] read-matching-message
+ [ mode? ] read-matching-message
+ { [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave
] unit-test
-] with-irc
+] spawning-irc
+
+[ { T{ participant { nick "ircuser" } { operator t } } } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ "ircuser" over join-participant
+ ":ircserver.net MODE #factortest +o ircuser" %push-line
+ participants>> "ircuser" swap at
+ ] unit-test
+] spawning-irc
+
+! Send privmsg
+[ { "PRIVMSG #factortest :hello" } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ "hello" swap (speak) %pop-output-line
+ ] unit-test
+] spawning-irc
diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor
new file mode 100644
index 0000000000..5bae054e18
--- /dev/null
+++ b/extra/irc/client/internals/internals.factor
@@ -0,0 +1,166 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs arrays concurrency.mailboxes continuations destructors
+hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
+strings words.symbol irc.messages.base irc.client.participants fry threads
+combinators irc.messages.parser ;
+EXCLUDE: sequences => join ;
+IN: irc.client.internals
+
+: /NICK ( nick -- ) "NICK " prepend irc-print ;
+: /PONG ( text -- ) "PONG " prepend irc-print ;
+
+: /LOGIN ( nick -- )
+ dup /NICK
+ "USER " prepend " hostname servername :irc.factor" append irc-print ;
+
+: /CONNECT ( server port -- stream )
+ irc> connect>> call( host port -- stream local ) drop ;
+
+: /JOIN ( channel password -- )
+ [ " :" swap 3append ] when* "JOIN " prepend irc-print ;
+
+: (connect-irc) ( -- )
+ irc> {
+ [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
+ [ (>>stream) ]
+ [ t swap (>>is-running) ]
+ [ in-messages>> [ irc-connected ] dip mailbox-put ]
+ } cleave ;
+
+: (do-login) ( -- ) irc> nick>> /LOGIN ;
+
+GENERIC: initialize-chat ( chat -- )
+M: irc-chat initialize-chat drop ;
+M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
+
+GENERIC: chat-put ( message obj -- )
+M: irc-chat chat-put in-messages>> mailbox-put ;
+M: symbol chat-put chat> [ chat-put ] [ drop ] if* ;
+M: string chat-put chat> +server-chat+ or chat-put ;
+M: sequence chat-put [ chat-put ] with each ;
+
+: delete-chat ( name -- ) irc> chats>> delete-at ;
+: unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ;
+
+! Server message handling
+
+GENERIC: message-forwards ( irc-message -- seq )
+M: irc-message message-forwards drop +server-chat+ ;
+M: to-one-chat message-forwards chat> ;
+M: to-all-chats message-forwards drop chats> ;
+M: to-many-chats message-forwards sender>> participant-chats ;
+
+GENERIC: process-message ( irc-message -- )
+M: object process-message drop ;
+M: ping process-message trailing>> /PONG ;
+M: join process-message [ sender>> ] [ chat> ] bi join-participant ;
+M: part process-message [ sender>> ] [ chat> ] bi part-participant ;
+M: quit process-message sender>> quit-participant ;
+M: nick process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
+M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
+
+M: rpl-welcome process-message
+ irc>
+ swap nickname>> >>nick
+ t >>is-ready
+ chats>> values [ initialize-chat ] each ;
+
+M: kick process-message
+ [ [ user>> ] [ chat> ] bi part-participant ]
+ [ dup user>> me? [ unregister-chat ] [ drop ] if ]
+ bi ;
+
+M: participant-mode process-message ( participant-mode -- )
+ [ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ;
+
+M: rpl-names process-message
+ [ nicks>> ] [ chat> ] bi dup ?clear-participants
+ '[ _ join-participant ] each ;
+
+M: rpl-names-end process-message chat> t >>clear-participants drop ;
+
+! Client message handling
+
+GENERIC: handle-outgoing-irc ( irc-message -- ? )
+M: irc-end handle-outgoing-irc drop f ;
+M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
+
+! Reader/Writer
+
+: handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
+
+: (handle-disconnect) ( -- )
+ irc-disconnected irc> in-messages>> mailbox-put
+ irc> reconnect-time>> sleep
+ (connect-irc)
+ (do-login) ;
+
+: handle-disconnect ( error -- ? )
+ [ irc> exceptions>> push ] when*
+ irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
+
+GENERIC: handle-input ( line/f -- ? )
+M: string handle-input string>irc-message handle-reader-message t ;
+M: f handle-input handle-disconnect ;
+
+: (reader-loop) ( -- ? )
+ stream> [ |dispose stream-readln handle-input ] with-destructors ;
+
+: reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ;
+: writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ;
+
+! Processing loops
+
+: in-multiplexer-loop ( -- ? )
+ irc> in-messages>> mailbox-get {
+ [ message-forwards ]
+ [ process-message ]
+ [ swap chat-put ]
+ [ irc-end? not ]
+ } cleave ;
+
+: strings>privmsg ( name string -- privmsg )
+ " :" prepend append "PRIVMSG " prepend string>irc-message ;
+
+GENERIC: annotate-message ( chat object -- object )
+M: object annotate-message nip ;
+M: to-channel annotate-message swap name>> >>channel ;
+M: to-target annotate-message swap name>> >>target ;
+M: mode annotate-message swap name>> >>name ;
+M: string annotate-message [ name>> ] dip strings>privmsg ;
+
+: spawn-irc ( -- )
+ [ reader-loop ] "irc-reader-loop" spawn-server
+ [ writer-loop ] "irc-writer-loop" spawn-server
+ [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
+ 3drop ;
+
+GENERIC: (attach-chat) ( irc-chat -- )
+
+M: irc-chat (attach-chat)
+ irc>
+ [ [ chats>> ] [ >>client name>> swap ] 2bi set-at ]
+ [ is-ready>> [ initialize-chat ] [ drop ] if ]
+ 2bi ;
+
+M: irc-server-chat (attach-chat)
+ irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ;
+
+GENERIC: remove-chat ( irc-chat -- )
+M: irc-nick-chat remove-chat name>> unregister-chat ;
+M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
+
+M: irc-channel-chat remove-chat
+ [ part new annotate-message irc-send ]
+ [ name>> unregister-chat ] bi ;
+
+: (terminate-irc) ( -- )
+ irc> dup is-running>> [
+ f >>is-running
+ [ stream>> dispose ] keep
+ [ in-messages>> ] [ out-messages>> ] bi 2array
+ [ irc-end swap mailbox-put ] each
+ ] [ drop ] if ;
+
+: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
\ No newline at end of file
diff --git a/extra/irc/client/internals/summary.txt b/extra/irc/client/internals/summary.txt
new file mode 100644
index 0000000000..a831199ba0
--- /dev/null
+++ b/extra/irc/client/internals/summary.txt
@@ -0,0 +1 @@
+IRC Client internals
diff --git a/extra/irc/client/participants/authors.txt b/extra/irc/client/participants/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/irc/client/participants/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/irc/client/participants/participants.factor b/extra/irc/client/participants/participants.factor
new file mode 100644
index 0000000000..8d367dbb95
--- /dev/null
+++ b/extra/irc/client/participants/participants.factor
@@ -0,0 +1,55 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators fry hashtables
+irc.client.base irc.client.chats kernel sequences splitting ;
+IN: irc.client.participants
+
+TUPLE: participant nick operator voice ;
+: <participant> ( name -- participant )
+ {
+ { [ "@" ?head ] [ t f ] }
+ { [ "+" ?head ] [ f t ] }
+ [ f f ]
+ } cond participant boa ;
+
+GENERIC: has-participant? ( name irc-chat -- ? )
+M: irc-chat has-participant? 2drop f ;
+M: irc-channel-chat has-participant? participants>> key? ;
+
+: rename-X ( new old assoc quot: ( obj value -- obj ) -- )
+ '[ delete-at* drop swap @ ] [ nip set-at ] 3bi ; inline
+
+: rename-nick-chat ( new old -- ) irc> chats>> [ >>name ] rename-X ;
+: rename-participant ( new old chat -- ) participants>> [ >>nick ] rename-X ;
+: part-participant ( nick irc-chat -- ) participants>> delete-at ;
+: participant-chats ( nick -- seq ) chats> [ has-participant? ] with filter ;
+
+: quit-participant ( nick -- )
+ dup participant-chats [ part-participant ] with each ;
+
+: rename-participant* ( new old -- )
+ [ dup participant-chats [ rename-participant ] with with each ]
+ [ dup chat> [ rename-nick-chat ] [ 2drop ] if ]
+ 2bi ;
+
+: join-participant ( nick irc-channel-chat -- )
+ participants>> [ <participant> dup nick>> ] dip set-at ;
+
+: apply-mode ( ? participant mode -- )
+ {
+ { CHAR: o [ (>>operator) ] }
+ { CHAR: v [ (>>voice) ] }
+ [ 3drop ]
+ } case ;
+
+: apply-modes ( mode-line participant -- )
+ [ unclip CHAR: + = ] dip
+ '[ [ _ _ ] dip apply-mode ] each ;
+
+: change-participant-mode ( mode channel nick -- )
+ swap chat> participants>> at apply-modes ;
+
+: ?clear-participants ( channel-chat -- )
+ dup clear-participants>> [
+ f >>clear-participants participants>> clear-assoc
+ ] [ drop ] if ;
diff --git a/extra/irc/client/participants/summary.txt b/extra/irc/client/participants/summary.txt
new file mode 100644
index 0000000000..3e88e61f5d
--- /dev/null
+++ b/extra/irc/client/participants/summary.txt
@@ -0,0 +1 @@
+IRC Client chat participants handling
diff --git a/extra/irc/gitbot/gitbot.factor b/extra/irc/gitbot/gitbot.factor
index 3b7694a347..161a81d555 100644
--- a/extra/irc/gitbot/gitbot.factor
+++ b/extra/irc/gitbot/gitbot.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry irc.client irc.client.private kernel namespaces
+USING: fry irc.client irc.client.chats kernel namespaces
sequences threads io.encodings.8-bit io.launcher io splitting
make mason.common mason.updates calendar math alarms ;
IN: irc.gitbot
@@ -33,7 +33,7 @@ M: object handle-message drop ;
"--pretty=format:%h %an: %s" ,
".." glue ,
] { } make
- latin1 [ input-stream get lines ] with-process-reader ;
+ latin1 [ lines ] with-process-reader ;
: updates ( from to -- lines )
git-log reverse
diff --git a/extra/irc/logbot/authors.txt b/extra/irc/logbot/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/irc/logbot/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/irc/logbot/log-line/authors.txt b/extra/irc/logbot/log-line/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/irc/logbot/log-line/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/irc/logbot/log-line/log-line.factor b/extra/irc/logbot/log-line/log-line.factor
new file mode 100644
index 0000000000..b3af41ad3d
--- /dev/null
+++ b/extra/irc/logbot/log-line/log-line.factor
@@ -0,0 +1,37 @@
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors irc.messages irc.messages.base kernel make ;
+EXCLUDE: sequences => join ;
+IN: irc.logbot.log-line
+
+: dot-or-parens ( string -- string )
+ [ "." ] [ " (" prepend ")." append ] if-empty ;
+
+GENERIC: >log-line ( object -- line )
+
+M: irc-message >log-line line>> ;
+
+M: privmsg >log-line
+ [ "<" % dup sender>> % "> " % text>> % ] "" make ;
+
+M: join >log-line
+ [ "* " % sender>> % " has joined the channel." % ] "" make ;
+
+M: part >log-line
+ [ "* " % dup sender>> % " has left the channel" %
+ comment>> dot-or-parens % ] "" make ;
+
+M: quit >log-line
+ [ "* " % dup sender>> % " has quit" %
+ comment>> dot-or-parens % ] "" make ;
+
+M: kick >log-line
+ [ "* " % dup sender>> % " has kicked " % dup user>> %
+ " from the channel" % comment>> dot-or-parens % ] "" make ;
+
+M: participant-mode >log-line
+ [ "* " % dup sender>> % " has set mode " % dup mode>> %
+ " to " % parameter>> % ] "" make ;
+
+M: nick >log-line
+ [ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
diff --git a/extra/irc/logbot/log-line/summary.txt b/extra/irc/logbot/log-line/summary.txt
new file mode 100644
index 0000000000..96ab2bf7a2
--- /dev/null
+++ b/extra/irc/logbot/log-line/summary.txt
@@ -0,0 +1 @@
+IRC message formatting for logs
diff --git a/extra/irc/logbot/logbot.factor b/extra/irc/logbot/logbot.factor
new file mode 100644
index 0000000000..a389304b14
--- /dev/null
+++ b/extra/irc/logbot/logbot.factor
@@ -0,0 +1,56 @@
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar calendar.format destructors fry io io.encodings.8-bit
+io.files io.pathnames irc.client irc.client.chats irc.messages
+irc.messages.base kernel make namespaces sequences threads
+irc.logbot.log-line ;
+IN: irc.logbot
+
+CONSTANT: bot-channel "#concatenative"
+CONSTANT: log-directory "/tmp/logs"
+
+SYMBOL: current-day
+SYMBOL: current-stream
+
+: bot-profile ( -- obj )
+ "irc.freenode.org" 6667 "flogger" f <irc-profile> ;
+
+: add-timestamp ( string timestamp -- string )
+ timestamp>hms "[" prepend "] " append prepend ;
+
+: timestamp-path ( timestamp -- path )
+ timestamp>ymd ".log" append log-directory prepend-path ;
+
+: timestamp>stream ( timestamp -- stream )
+ dup day-of-year current-day get = [
+ drop
+ ] [
+ current-stream get [ dispose ] when*
+ [ day-of-year current-day set ]
+ [ timestamp-path latin1 <file-writer> ] bi
+ current-stream set
+ ] if current-stream get ;
+
+: log-message ( string timestamp -- )
+ [ add-timestamp ] [ timestamp>stream ] bi
+ [ stream-print ] [ stream-flush ] bi ;
+
+GENERIC: handle-message ( msg -- )
+
+M: object handle-message drop ;
+M: irc-message handle-message [ >log-line ] [ timestamp>> ] bi log-message ;
+
+: bot-loop ( chat -- ) dup hear handle-message bot-loop ;
+
+: start-bot ( -- )
+ bot-profile <irc-client>
+ [ connect-irc ]
+ [
+ [ bot-channel <irc-channel-chat> ] dip
+ '[ _ [ _ attach-chat ] [ bot-loop ] bi ]
+ "LogBot" spawn drop
+ ] bi ;
+
+: logbot ( -- ) start-bot ;
+
+MAIN: logbot
diff --git a/extra/irc/logbot/summary.txt b/extra/irc/logbot/summary.txt
new file mode 100644
index 0000000000..1e49fcb240
--- /dev/null
+++ b/extra/irc/logbot/summary.txt
@@ -0,0 +1 @@
+An IRC logging bot
diff --git a/extra/irc/messages/base/authors.txt b/extra/irc/messages/base/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/irc/messages/base/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor
new file mode 100644
index 0000000000..d67d226d9b
--- /dev/null
+++ b/extra/irc/messages/base/base.factor
@@ -0,0 +1,115 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes.parser classes.tuple
+ combinators fry generic.parser kernel lexer
+ mirrors namespaces parser sequences splitting strings words ;
+IN: irc.messages.base
+
+TUPLE: irc-message line prefix command parameters trailing timestamp sender ;
+TUPLE: unhandled < irc-message ;
+
+SYMBOL: string-irc-type-mapping
+string-irc-type-mapping [ H{ } clone ] initialize
+
+: register-irc-message-type ( type string -- )
+ string-irc-type-mapping get set-at ;
+
+: irc>type ( string -- irc-message-class )
+ string-irc-type-mapping get at unhandled or ;
+
+GENERIC: irc-trailing-slot ( irc-message -- string/f )
+M: irc-message irc-trailing-slot
+ drop f ;
+
+GENERIC: irc-parameter-slots ( irc-message -- seq )
+M: irc-message irc-parameter-slots
+ drop f ;
+
+GENERIC: process-irc-trailing ( irc-message -- )
+M: irc-message process-irc-trailing
+ dup irc-trailing-slot [
+ swap [ trailing>> swap ] [ <mirror> ] bi set-at
+ ] [ drop ] if* ;
+
+GENERIC: process-irc-prefix ( irc-message -- )
+M: irc-message process-irc-prefix
+ drop ;
+
+<PRIVATE
+: [slot-setter] ( mirror -- quot )
+ '[ [ _ set-at ] [ drop ] if* ] ; inline
+PRIVATE>
+
+GENERIC: process-irc-parameters ( irc-message -- )
+M: irc-message process-irc-parameters
+ dup irc-parameter-slots [
+ swap [ parameters>> swap ] [ <mirror> [slot-setter] ] bi 2each
+ ] [ drop ] if* ;
+
+GENERIC: post-process-irc-message ( irc-message -- )
+M: irc-message post-process-irc-message drop ;
+
+GENERIC: fill-irc-message-slots ( irc-message -- )
+M: irc-message fill-irc-message-slots
+ {
+ [ process-irc-trailing ]
+ [ process-irc-prefix ]
+ [ process-irc-parameters ]
+ [ post-process-irc-message ]
+ } cleave ;
+
+GENERIC: irc-command-string ( irc-message -- string )
+M: irc-message irc-command-string drop f ;
+
+! FIXME: inverse of post-process is missing
+GENERIC: set-irc-parameters ( irc-message -- )
+M: irc-message set-irc-parameters
+ dup irc-parameter-slots
+ [ over <mirror> '[ _ at ] map >>parameters ] when* drop ;
+
+GENERIC: set-irc-trailing ( irc-message -- )
+M: irc-message set-irc-trailing
+ dup irc-trailing-slot [ over <mirror> at >>trailing ] when* drop ;
+
+GENERIC: set-irc-command ( irc-message -- )
+M: irc-message set-irc-command
+ [ irc-command-string ] [ (>>command) ] bi ;
+
+: irc-message>string ( irc-message -- string )
+ {
+ [ prefix>> ]
+ [ command>> ]
+ [ parameters>> " " join ]
+ [ trailing>> dup [ CHAR: : prefix ] when ]
+ } cleave 4array sift " " join ;
+
+<PRIVATE
+: ?define-irc-parameters ( class slot-names -- )
+ dup empty? not [
+ [ \ irc-parameter-slots create-method-in ] dip
+ [ [ "_" = not ] keep and ] map '[ drop _ ] define
+ ] [ 2drop ] if ;
+
+: ?define-irc-trailing ( class slot-name -- )
+ [
+ [ \ irc-trailing-slot create-method-in ] dip
+ first '[ drop _ ] define
+ ] [ drop ] if* ;
+
+: define-irc-class ( class params -- )
+ [ { ":" "_" } member? not ] filter
+ [ irc-message ] dip define-tuple-class ;
+
+: define-irc-parameter-slots ( class params -- )
+ { ":" } split1 [ over ] dip
+ [ ?define-irc-parameters ] [ ?define-irc-trailing ] 2bi* ;
+PRIVATE>
+
+#! SYNTAX:
+#! IRC: type "COMMAND" slot1 ...;
+#! IRC: type "COMMAND" slot1 ... : trailing-slot;
+SYNTAX: IRC: ( name string parameters -- )
+ CREATE-CLASS
+ [ scan-object register-irc-message-type ] keep
+ ";" parse-tokens
+ [ define-irc-class ] [ define-irc-parameter-slots ] 2bi ;
diff --git a/extra/irc/messages/base/summary.txt b/extra/irc/messages/base/summary.txt
new file mode 100644
index 0000000000..1a05067707
--- /dev/null
+++ b/extra/irc/messages/base/summary.txt
@@ -0,0 +1 @@
+IRC messages base implementation
diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor
index ac1d003b1b..539fba54eb 100644
--- a/extra/irc/messages/messages-tests.factor
+++ b/extra/irc/messages/messages-tests.factor
@@ -1,19 +1,12 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test accessors arrays
- irc.messages irc.messages.private ;
+ irc.messages.parser irc.messages ;
EXCLUDE: sequences => join ;
IN: irc.messages.tests
-{ "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
-
-{ T{ irc-message
- { line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
- { prefix "someuser!n=user@some.where" }
- { command "PRIVMSG" }
- { parameters { "#factortest" } }
- { trailing "hi" } } }
-[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- string>irc-message f >>timestamp ] unit-test
+! { "someuser" } [ "someuser!n=user@some.where" parse-name ] unit-test
{ T{ privmsg
{ line ":someuser!n=user@some.where PRIVMSG #factortest :hi" }
@@ -21,18 +14,22 @@ IN: irc.messages.tests
{ command "PRIVMSG" }
{ parameters { "#factortest" } }
{ trailing "hi" }
- { name "#factortest" } } }
+ { target "#factortest" }
+ { text "hi" }
+ { sender "someuser" } } }
[ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
{ T{ join
{ line ":someuser!n=user@some.where JOIN :#factortest" }
{ prefix "someuser!n=user@some.where" }
{ command "JOIN" }
{ parameters { } }
- { trailing "#factortest" } } }
+ { trailing "#factortest" }
+ { sender "someuser" }
+ { channel "#factortest" } } }
[ ":someuser!n=user@some.where JOIN :#factortest"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
{ T{ mode
{ line ":ircserver.net MODE #factortest +ns" }
@@ -42,7 +39,7 @@ IN: irc.messages.tests
{ name "#factortest" }
{ mode "+ns" } } }
[ ":ircserver.net MODE #factortest +ns"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
{ T{ mode
{ line ":ircserver.net MODE #factortest +o someuser" }
@@ -53,18 +50,20 @@ IN: irc.messages.tests
{ mode "+o" }
{ parameter "someuser" } } }
[ ":ircserver.net MODE #factortest +o someuser"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
{ T{ nick
{ line ":someuser!n=user@some.where NICK :someuser2" }
{ prefix "someuser!n=user@some.where" }
{ command "NICK" }
{ parameters { } }
- { trailing "someuser2" } } }
+ { trailing "someuser2" }
+ { sender "someuser" }
+ { nickname "someuser2" } } }
[ ":someuser!n=user@some.where NICK :someuser2"
- parse-irc-line f >>timestamp ] unit-test
+ string>irc-message f >>timestamp ] unit-test
-{ T{ nick-in-use
+{ T{ rpl-nickname-in-use
{ line ":ircserver.net 433 * nickname :Nickname is already in use" }
{ prefix "ircserver.net" }
{ command "433" }
@@ -72,4 +71,4 @@ IN: irc.messages.tests
{ name "nickname" }
{ trailing "Nickname is already in use" } } }
[ ":ircserver.net 433 * nickname :Nickname is already in use"
- parse-irc-line f >>timestamp ] unit-test
\ No newline at end of file
+ string>irc-message f >>timestamp ] unit-test
\ No newline at end of file
diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor
index c88bbc072a..a6bf02f8a7 100755
--- a/extra/irc/messages/messages.factor
+++ b/extra/irc/messages/messages.factor
@@ -1,179 +1,68 @@
-! Copyright (C) 2008 Bruno Deferrari
+! Copyright (C) 2009 Bruno Deferrari
! See http://factorcode.org/license.txt for BSD license.
USING: kernel fry splitting ascii calendar accessors combinators
- arrays classes.tuple math.order ;
-RENAME: join sequences => sjoin
+arrays classes.tuple math.order words assocs strings irc.messages.base ;
EXCLUDE: sequences => join ;
IN: irc.messages
-TUPLE: irc-message line prefix command parameters trailing timestamp ;
-TUPLE: logged-in < irc-message name ;
-TUPLE: ping < irc-message ;
-TUPLE: join < irc-message ;
-TUPLE: part < irc-message channel ;
-TUPLE: quit < irc-message ;
-TUPLE: nick < irc-message ;
-TUPLE: privmsg < irc-message name ;
-TUPLE: kick < irc-message channel who ;
-TUPLE: roomlist < irc-message channel names ;
-TUPLE: nick-in-use < irc-message name ;
-TUPLE: notice < irc-message type ;
-TUPLE: mode < irc-message name mode parameter ;
-TUPLE: names-reply < irc-message who channel ;
-TUPLE: end-of-names < irc-message who channel ;
-TUPLE: unhandled < irc-message ;
+! connection
+IRC: pass "PASS" password ;
+IRC: nick "NICK" : nickname ;
+IRC: user "USER" user mode _ : realname ;
+IRC: oper "OPER" name password ;
+IRC: mode "MODE" name mode parameter ;
+IRC: service "SERVICE" nickname _ distribution type _ : info ;
+IRC: quit "QUIT" : comment ;
+IRC: squit "SQUIT" server : comment ;
+! channel operations
+IRC: join "JOIN" : channel ;
+IRC: part "PART" channel : comment ;
+IRC: topic "TOPIC" channel : topic ;
+IRC: names "NAMES" channel ;
+IRC: list "LIST" channel ;
+IRC: invite "INVITE" nickname channel ;
+IRC: kick "KICK" channel user : comment ;
+! chating
+IRC: privmsg "PRIVMSG" target : text ;
+IRC: notice "NOTICE" target : text ;
+! server queries
+IRC: motd "MOTD" target ;
+IRC: lusers "LUSERS" mask target ;
+IRC: version "VERSION" target ;
+IRC: stats "STATS" query target ;
+IRC: links "LINKS" server mask ;
+IRC: time "TIME" target ;
+IRC: connect "CONNECT" server port remote-server ;
+IRC: trace "TRACE" target ;
+IRC: admin "ADMIN" target ;
+IRC: info "INFO" target ;
+! service queries
+IRC: servlist "SERVLIST" mask type ;
+IRC: squery "SQUERY" service-name : text ;
+! user queries
+IRC: who "WHO" mask operator ;
+IRC: whois "WHOIS" target mask ;
+IRC: whowas "WHOWAS" nickname count target ;
+! misc
+IRC: kill "KILL" nickname : comment ;
+IRC: ping "PING" server1 server2 ;
+IRC: pong "PONG" server1 server2 ;
+IRC: error "ERROR" : message ;
+! numeric replies
+IRC: rpl-welcome "001" nickname : comment ;
+IRC: rpl-whois-user "311" nicnamek user host _ : real-name ;
+IRC: rpl-channel-modes "324" channel mode params ;
+IRC: rpl-notopic "331" channel : topic ;
+IRC: rpl-topic "332" channel : topic ;
+IRC: rpl-inviting "341" channel nickname ;
+IRC: rpl-names "353" nickname _ channel : nicks ;
+IRC: rpl-names-end "366" nickname channel : comment ;
+! error replies
+IRC: rpl-nickname-in-use "433" _ name ;
+IRC: rpl-nick-collision "436" nickname : comment ;
-: <irc-client-message> ( command parameters trailing -- irc-message )
- irc-message new
- now >>timestamp
- swap >>trailing
- swap >>parameters
- swap >>command ;
+M: rpl-names post-process-irc-message ( rpl-names -- )
+ [ [ blank? ] trim " " split ] change-nicks drop ;
-<PRIVATE
-
-GENERIC: command-string>> ( irc-message -- string )
-
-M: irc-message command-string>> ( irc-message -- string ) command>> ;
-M: ping command-string>> ( ping -- string ) drop "PING" ;
-M: join command-string>> ( join -- string ) drop "JOIN" ;
-M: part command-string>> ( part -- string ) drop "PART" ;
-M: quit command-string>> ( quit -- string ) drop "QUIT" ;
-M: nick command-string>> ( nick -- string ) drop "NICK" ;
-M: privmsg command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
-M: notice command-string>> ( notice -- string ) drop "NOTICE" ;
-M: mode command-string>> ( mode -- string ) drop "MODE" ;
-M: kick command-string>> ( kick -- string ) drop "KICK" ;
-
-GENERIC: command-parameters>> ( irc-message -- seq )
-
-M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
-M: ping command-parameters>> ( ping -- seq ) drop { } ;
-M: join command-parameters>> ( join -- seq ) drop { } ;
-M: part command-parameters>> ( part -- seq ) channel>> 1array ;
-M: quit command-parameters>> ( quit -- seq ) drop { } ;
-M: nick command-parameters>> ( nick -- seq ) drop { } ;
-M: privmsg command-parameters>> ( privmsg -- seq ) name>> 1array ;
-M: notice command-parameters>> ( norice -- seq ) type>> 1array ;
-M: kick command-parameters>> ( kick -- seq )
- [ channel>> ] [ who>> ] bi 2array ;
-M: mode command-parameters>> ( mode -- seq )
- [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
-
-GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
-
-M: irc-message >>command-parameters ( irc-message params -- irc-message )
- drop ;
-
-M: logged-in >>command-parameters ( part params -- part )
- first >>name ;
-
-M: privmsg >>command-parameters ( privmsg params -- privmsg )
- first >>name ;
-
-M: notice >>command-parameters ( notice params -- notice )
- first >>type ;
-
-M: part >>command-parameters ( part params -- part )
- first >>channel ;
-
-M: kick >>command-parameters ( kick params -- kick )
- first2 [ >>channel ] [ >>who ] bi* ;
-
-M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
- second >>name ;
-
-M: names-reply >>command-parameters ( names-reply params -- names-reply )
- first3 nip [ >>who ] [ >>channel ] bi* ;
-
-M: end-of-names >>command-parameters ( names-reply params -- names-reply )
- first2 [ >>who ] [ >>channel ] bi* ;
-
-M: mode >>command-parameters ( mode params -- mode )
- dup length {
- { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
- { 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
- [ drop first >>name dup trailing>> >>mode ]
- } case ;
-
-PRIVATE>
-
-GENERIC: irc-message>client-line ( irc-message -- string )
-
-M: irc-message irc-message>client-line ( irc-message -- string )
- [ command-string>> ]
- [ command-parameters>> " " sjoin ]
- [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
- tri 3array " " sjoin ;
-
-GENERIC: irc-message>server-line ( irc-message -- string )
-
-M: irc-message irc-message>server-line ( irc-message -- string )
- drop "not implemented yet" ;
-
-<PRIVATE
-
-! ======================================
-! Message parsing
-! ======================================
-
-: split-at-first ( seq separators -- before after )
- dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
-
-: remove-heading-: ( seq -- seq )
- ":" ?head drop ;
-
-: parse-name ( string -- string )
- remove-heading-: "!" split-at-first drop ;
-
-: split-prefix ( string -- string/f string )
- dup ":" head?
- [ remove-heading-: " " split1 ] [ f swap ] if ;
-
-: split-trailing ( string -- string string/f )
- ":" split1 ;
-
-: copy-message-in ( command irc-message -- command )
- {
- [ line>> >>line ]
- [ prefix>> >>prefix ]
- [ command>> >>command ]
- [ trailing>> >>trailing ]
- [ timestamp>> >>timestamp ]
- [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
- } cleave ;
-
-PRIVATE>
-
-UNION: sender-in-prefix privmsg join part quit kick mode nick ;
-GENERIC: irc-message-sender ( irc-message -- sender )
-M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
- prefix>> parse-name ;
-
-: string>irc-message ( string -- object )
- dup split-prefix split-trailing
- [ [ blank? ] trim " " split unclip swap ] dip
- now irc-message boa ;
-
-: irc-message>command ( irc-message -- command )
- [
- command>> {
- { "PING" [ ping ] }
- { "NOTICE" [ notice ] }
- { "001" [ logged-in ] }
- { "433" [ nick-in-use ] }
- { "353" [ names-reply ] }
- { "366" [ end-of-names ] }
- { "JOIN" [ join ] }
- { "PART" [ part ] }
- { "NICK" [ nick ] }
- { "PRIVMSG" [ privmsg ] }
- { "QUIT" [ quit ] }
- { "MODE" [ mode ] }
- { "KICK" [ kick ] }
- [ drop unhandled ]
- } case new
- ] keep copy-message-in ;
-
-: parse-irc-line ( string -- message )
- string>irc-message irc-message>command ;
+PREDICATE: channel-mode < mode name>> first "#&" member? ;
+PREDICATE: participant-mode < channel-mode parameter>> ;
diff --git a/extra/irc/messages/parser/authors.txt b/extra/irc/messages/parser/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/irc/messages/parser/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor
new file mode 100644
index 0000000000..1fa07fc772
--- /dev/null
+++ b/extra/irc/messages/parser/parser.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel fry splitting ascii calendar accessors combinators
+ arrays classes.tuple math.order words assocs
+ irc.messages.base sequences ;
+IN: irc.messages.parser
+
+<PRIVATE
+: split-at-first ( seq separators -- before after )
+ dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
+
+: split-trailing ( string -- string string/f ) ":" split1 ;
+: remove-heading-: ( seq -- seq ) ":" ?head drop ;
+
+: split-prefix ( string -- string/f string )
+ dup ":" head? [
+ remove-heading-: " " split1
+ ] [ f swap ] if ;
+
+: split-message ( string -- prefix command parameters trailing )
+ split-prefix split-trailing
+ [ [ blank? ] trim " " split unclip swap ] dip ;
+
+: sender ( irc-message -- sender )
+ prefix>> [ remove-heading-: "!" split-at-first drop ] [ f ] if* ;
+PRIVATE>
+
+: string>irc-message ( string -- irc-message )
+ dup split-message
+ [ [ irc>type new ] [ >>command ] bi ]
+ [ >>parameters ]
+ [ >>trailing ]
+ tri*
+ [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
+ now >>timestamp dup sender >>sender ;
diff --git a/extra/irc/messages/parser/summary.txt b/extra/irc/messages/parser/summary.txt
new file mode 100644
index 0000000000..7ec732aae1
--- /dev/null
+++ b/extra/irc/messages/parser/summary.txt
@@ -0,0 +1 @@
+Basic parser for irc messages
diff --git a/extra/irc/messages/summary.txt b/extra/irc/messages/summary.txt
new file mode 100644
index 0000000000..cf3a8ae07a
--- /dev/null
+++ b/extra/irc/messages/summary.txt
@@ -0,0 +1 @@
+IRC message definitions
diff --git a/unmaintained/synth/authors.txt b/extra/jamshred/authors.txt
similarity index 100%
rename from unmaintained/synth/authors.txt
rename to extra/jamshred/authors.txt
diff --git a/extra/jamshred/deploy.factor b/extra/jamshred/deploy.factor
new file mode 100644
index 0000000000..9a18cf1f9b
--- /dev/null
+++ b/extra/jamshred/deploy.factor
@@ -0,0 +1,12 @@
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Jamshred" }
+}
diff --git a/unmaintained/synth/buffers/authors.txt b/extra/jamshred/game/authors.txt
similarity index 100%
rename from unmaintained/synth/buffers/authors.txt
rename to extra/jamshred/game/authors.txt
diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor
new file mode 100644
index 0000000000..14bf18a9c1
--- /dev/null
+++ b/extra/jamshred/game/game.factor
@@ -0,0 +1,40 @@
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
+IN: jamshred.game
+
+TUPLE: jamshred sounds tunnel players running quit ;
+
+: <jamshred> ( -- jamshred )
+ <sounds> <random-tunnel> "Player 1" pick <player>
+ 2dup swap play-in-tunnel 1array f f jamshred boa ;
+
+: jamshred-player ( jamshred -- player )
+ ! TODO: support more than one player
+ players>> first ;
+
+: jamshred-update ( jamshred -- )
+ dup running>> [
+ jamshred-player update-player
+ ] [ drop ] if ;
+
+: toggle-running ( jamshred -- )
+ dup running>> [
+ f >>running drop
+ ] [
+ [ jamshred-player moved ]
+ [ t >>running drop ] bi
+ ] if ;
+
+: mouse-moved ( x-radians y-radians jamshred -- )
+ jamshred-player -rot turn-player ;
+
+CONSTANT: units-per-full-roll 50
+
+: jamshred-roll ( jamshred n -- )
+ [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
+
+: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
+
+: mouse-scroll-y ( jamshred y -- )
+ neg swap jamshred-player change-player-speed ;
diff --git a/unmaintained/synth/example/authors.txt b/extra/jamshred/gl/authors.txt
similarity index 100%
rename from unmaintained/synth/example/authors.txt
rename to extra/jamshred/gl/authors.txt
diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor
new file mode 100644
index 0000000000..a1d22c48dc
--- /dev/null
+++ b/extra/jamshred/gl/gl.factor
@@ -0,0 +1,111 @@
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types jamshred.game jamshred.oint
+jamshred.player jamshred.tunnel kernel math math.constants
+math.functions math.vectors opengl opengl.gl opengl.glu
+opengl.demo-support sequences specialized-arrays.float ;
+IN: jamshred.gl
+
+CONSTANT: min-vertices 6
+CONSTANT: max-vertices 32
+
+CONSTANT: n-vertices 32
+
+! render enough of the tunnel that it looks continuous
+CONSTANT: n-segments-ahead 60
+CONSTANT: n-segments-behind 40
+
+! so that we can't see through the wall, we draw it a bit further away
+CONSTANT: wall-drawing-offset 0.15
+
+: wall-drawing-radius ( segment -- r )
+ radius>> wall-drawing-offset + ;
+
+: wall-up ( segment -- v )
+ [ wall-drawing-radius ] [ up>> ] bi n*v ;
+
+: wall-left ( segment -- v )
+ [ wall-drawing-radius ] [ left>> ] bi n*v ;
+
+: segment-vertex ( theta segment -- vertex )
+ [
+ [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
+ ] [
+ location>> v+
+ ] bi ;
+
+: segment-vertex-normal ( vertex segment -- normal )
+ location>> swap v- normalize ;
+
+: segment-vertex-and-normal ( segment theta -- vertex normal )
+ swap [ segment-vertex ] keep dupd segment-vertex-normal ;
+
+: equally-spaced-radians ( n -- seq )
+ #! return a sequence of n numbers between 0 and 2pi
+ dup [ / pi 2 * * ] curry map ;
+
+: draw-segment-vertex ( segment theta -- )
+ over color>> gl-color segment-vertex-and-normal
+ gl-normal gl-vertex ;
+
+: draw-vertex-pair ( theta next-segment segment -- )
+ rot tuck draw-segment-vertex draw-segment-vertex ;
+
+: draw-segment ( next-segment segment -- )
+ GL_QUAD_STRIP [
+ [ draw-vertex-pair ] 2curry
+ n-vertices equally-spaced-radians float-array{ 0.0 } append swap each
+ ] do-state ;
+
+: draw-segments ( segments -- )
+ 1 over length pick subseq swap [ draw-segment ] 2each ;
+
+: segments-to-render ( player -- segments )
+ dup nearest-segment>> number>> dup n-segments-behind -
+ swap n-segments-ahead + rot tunnel>> sub-tunnel ;
+
+: draw-tunnel ( player -- )
+ segments-to-render draw-segments ;
+
+: init-graphics ( -- )
+ GL_DEPTH_TEST glEnable
+ GL_SCISSOR_TEST glDisable
+ 1.0 glClearDepth
+ 0.0 0.0 0.0 0.0 glClearColor
+ GL_PROJECTION glMatrixMode glPushMatrix
+ GL_MODELVIEW glMatrixMode glPushMatrix
+ GL_LEQUAL glDepthFunc
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_FOG glEnable
+ GL_FOG_DENSITY 0.09 glFogf
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ GL_COLOR_MATERIAL glEnable
+ GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
+
+: cleanup-graphics ( -- )
+ GL_DEPTH_TEST glDisable
+ GL_SCISSOR_TEST glEnable
+ GL_MODELVIEW glMatrixMode glPopMatrix
+ GL_PROJECTION glMatrixMode glPopMatrix
+ GL_LIGHTING glDisable
+ GL_LIGHT0 glDisable
+ GL_FOG glDisable
+ GL_COLOR_MATERIAL glDisable ;
+
+: pre-draw ( width height -- )
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_PROJECTION glMatrixMode glLoadIdentity
+ dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
+ GL_MODELVIEW glMatrixMode glLoadIdentity ;
+
+: player-view ( player -- )
+ [ location>> ]
+ [ [ location>> ] [ forward>> ] bi v+ ]
+ [ up>> ] tri gl-look-at ;
+
+: draw-jamshred ( jamshred width height -- )
+ pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ;
diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor
new file mode 100644
index 0000000000..fd683e3bc4
--- /dev/null
+++ b/extra/jamshred/jamshred.factor
@@ -0,0 +1,94 @@
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.rectangles math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
+IN: jamshred
+
+TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
+
+: <jamshred-gadget> ( jamshred -- gadget )
+ jamshred-gadget new swap >>jamshred ;
+
+CONSTANT: default-width 800
+CONSTANT: default-height 600
+
+M: jamshred-gadget pref-dim*
+ drop default-width default-height 2array ;
+
+M: jamshred-gadget draw-gadget* ( gadget -- )
+ [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ;
+
+: jamshred-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ [ jamshred>> jamshred-update ]
+ [ relayout-1 ]
+ [ 100 milliseconds sleep jamshred-loop ] tri
+ ] if ;
+
+: fullscreen ( gadget -- )
+ find-world t swap set-fullscreen* ;
+
+: no-fullscreen ( gadget -- )
+ find-world f swap set-fullscreen* ;
+
+: toggle-fullscreen ( world -- )
+ [ fullscreen? not ] keep set-fullscreen* ;
+
+M: jamshred-gadget graft* ( gadget -- )
+ [ find-gl-context init-graphics ]
+ [ [ jamshred-loop ] curry in-thread ] bi ;
+
+M: jamshred-gadget ungraft* ( gadget -- )
+ dup find-gl-context cleanup-graphics jamshred>> t swap (>>quit) ;
+
+: jamshred-restart ( jamshred-gadget -- )
+ <jamshred> >>jamshred drop ;
+
+: pix>radians ( n m -- theta )
+ / pi 4 * * ; ! 2 / / pi 2 * * ;
+
+: x>radians ( x gadget -- theta )
+ #! translate motion of x pixels to an angle
+ dim>> first pix>radians neg ;
+
+: y>radians ( y gadget -- theta )
+ #! translate motion of y pixels to an angle
+ dim>> second pix>radians ;
+
+: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
+ dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
+ rot jamshred>> mouse-moved ;
+
+: handle-mouse-motion ( jamshred-gadget -- )
+ hand-loc get [
+ over last-hand-loc>> [
+ v- (handle-mouse-motion)
+ ] [ 2drop ] if*
+ ] 2keep >>last-hand-loc drop ;
+
+: handle-mouse-scroll ( jamshred-gadget -- )
+ jamshred>> scroll-direction get
+ [ first mouse-scroll-x ]
+ [ second mouse-scroll-y ] 2bi ;
+
+: quit ( gadget -- )
+ [ no-fullscreen ] [ close-window ] bi ;
+
+jamshred-gadget H{
+ { T{ key-down f f "r" } [ jamshred-restart ] }
+ { T{ key-down f f " " } [ jamshred>> toggle-running ] }
+ { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
+ { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
+ { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
+ { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
+ { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
+ { T{ key-down f f "q" } [ quit ] }
+ { motion [ handle-mouse-motion ] }
+ { mouse-scroll [ handle-mouse-scroll ] }
+} set-gestures
+
+: jamshred-window ( -- )
+ [ <jamshred> <jamshred-gadget> "Jamshred" open-window ] with-ui ;
+
+MAIN: jamshred-window
diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor
new file mode 100644
index 0000000000..f2517d1ec3
--- /dev/null
+++ b/extra/jamshred/log/log.factor
@@ -0,0 +1,10 @@
+USING: kernel logging ;
+IN: jamshred.log
+
+LOG: (jamshred-log) DEBUG
+
+: with-jamshred-log ( quot -- )
+ "jamshred" swap with-logging ; inline
+
+: jamshred-log ( message -- )
+ [ (jamshred-log) ] with-jamshred-log ; ! ugly...
diff --git a/extra/jamshred/oint/authors.txt b/extra/jamshred/oint/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/jamshred/oint/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/extra/jamshred/oint/oint-tests.factor b/extra/jamshred/oint/oint-tests.factor
new file mode 100644
index 0000000000..401935fd01
--- /dev/null
+++ b/extra/jamshred/oint/oint-tests.factor
@@ -0,0 +1,8 @@
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
+[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
+[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
+[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
+[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor
new file mode 100644
index 0000000000..ae72bd847c
--- /dev/null
+++ b/extra/jamshred/oint/oint.factor
@@ -0,0 +1,73 @@
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+IN: jamshred.oint
+
+! An oint is a point with three linearly independent unit vectors
+! given relative to that point. In jamshred a player's location and
+! direction are given by the player's oint. Similarly, a tunnel
+! segment's location and orientation are given by an oint.
+
+TUPLE: oint location forward up left ;
+C: <oint> oint
+
+: rotation-quaternion ( theta axis -- quaternion )
+ swap 2 / dup cos swap sin rot n*v first3 rect> [ rect> ] dip 2array ;
+
+: rotate-vector ( q qrecip v -- v )
+ v>q swap q* q* q>v ;
+
+: rotate-oint ( oint theta axis -- )
+ rotation-quaternion dup qrecip pick
+ [ forward>> rotate-vector >>forward ]
+ [ up>> rotate-vector >>up ]
+ [ left>> rotate-vector >>left ] 3tri drop ;
+
+: left-pivot ( oint theta -- )
+ over left>> rotate-oint ;
+
+: up-pivot ( oint theta -- )
+ over up>> rotate-oint ;
+
+: forward-pivot ( oint theta -- )
+ over forward>> rotate-oint ;
+
+: random-float+- ( n -- m )
+ #! find a random float between -n/2 and n/2
+ dup 10000 * >fixnum random 10000 / swap 2 / - ;
+
+: random-turn ( oint theta -- )
+ 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
+
+: location+ ( v oint -- )
+ [ location>> v+ ] [ (>>location) ] bi ;
+
+: go-forward ( distance oint -- )
+ [ forward>> n*v ] [ location+ ] bi ;
+
+: distance-vector ( oint oint -- vector )
+ [ location>> ] bi@ swap v- ;
+
+: distance ( oint oint -- distance )
+ distance-vector norm ;
+
+: scalar-projection ( v1 v2 -- n )
+ #! the scalar projection of v1 onto v2
+ tuck v. swap norm / ;
+
+: proj-perp ( u v -- w )
+ dupd proj v- ;
+
+: perpendicular-distance ( oint oint -- distance )
+ tuck distance-vector swap 2dup left>> scalar-projection abs
+ -rot up>> scalar-projection abs + ;
+
+:: reflect ( v n -- v' )
+ #! bounce v on a surface with normal n
+ v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+ over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+ [ location>> ] bi@ half-way ;
diff --git a/extra/jamshred/player/authors.txt b/extra/jamshred/player/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/jamshred/player/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor
new file mode 100644
index 0000000000..5b92b3a434
--- /dev/null
+++ b/extra/jamshred/player/player.factor
@@ -0,0 +1,137 @@
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors colors.constants combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle specialized-arrays.float strings system ;
+IN: jamshred.player
+
+TUPLE: player < oint
+ { name string }
+ { sounds sounds }
+ tunnel
+ nearest-segment
+ { last-move integer }
+ { speed float } ;
+
+! speeds are in GL units / second
+CONSTANT: default-speed 1.0
+CONSTANT: max-speed 30.0
+
+: <player> ( name sounds -- player )
+ [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
+ f f 0 default-speed player boa ;
+
+: turn-player ( player x-radians y-radians -- )
+ [ over ] dip left-pivot up-pivot ;
+
+: roll-player ( player z-radians -- )
+ forward-pivot ;
+
+: to-tunnel-start ( player -- )
+ [ tunnel>> first dup location>> ]
+ [ tuck (>>location) (>>nearest-segment) ] bi ;
+
+: play-in-tunnel ( player segments -- )
+ >>tunnel to-tunnel-start ;
+
+: update-nearest-segment ( player -- )
+ [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
+ [ (>>nearest-segment) ] tri ;
+
+: update-time ( player -- seconds-passed )
+ millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
+
+: moved ( player -- ) millis swap (>>last-move) ;
+
+: speed-range ( -- range )
+ max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+ [ + speed-range clamp-to-range ] change-speed drop ;
+
+: multiply-player-speed ( n player -- )
+ [ * speed-range clamp-to-range ] change-speed drop ;
+
+: distance-to-move ( seconds-passed player -- distance )
+ speed>> * ;
+
+: bounce ( d-left player -- d-left' player )
+ {
+ [ dup nearest-segment>> bounce-off-wall ]
+ [ sounds>> bang ]
+ [ 3/4 swap multiply-player-speed ]
+ [ ]
+ } cleave ;
+
+:: (distance) ( heading player -- current next location heading )
+ player nearest-segment>>
+ player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+ player location>> heading ;
+
+: distance-to-heading-segment ( heading player -- distance )
+ (distance) distance-to-next-segment ;
+
+: distance-to-heading-segment-area ( heading player -- distance )
+ (distance) distance-to-next-segment-area ;
+
+: distance-to-collision ( player -- distance )
+ dup nearest-segment>> (distance-to-collision) ;
+
+: almost-to-collision ( player -- distance )
+ distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
+
+: from ( player -- radius distance-from-centre )
+ [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+ distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+ fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
+ ] [
+ 2drop
+ ] if ;
+
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+ [let* | d-to-move [ d-left distance min ]
+ move-v [ d-to-move heading n*v ] |
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ] ;
+
+: distance-to-move-freely ( player -- distance )
+ [ almost-to-collision ]
+ [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
+
+: ?move-player-freely ( d-left player -- d-left' player )
+ over 0 > [
+ ! must make sure we are moving a significant distance, otherwise
+ ! we can recurse endlessly due to floating-point imprecision.
+ ! (at least I /think/ that's what causes it...)
+ dup distance-to-move-freely dup 0.1 > [
+ over forward>> move-player-on-heading ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: drag-heading ( player -- heading )
+ [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+ [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+ ?move-player-freely over 0 > [
+ ! bounce
+ drag-player
+ (move-player)
+ ] when ;
+
+: move-player ( player -- )
+ [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
+
+: update-player ( player -- )
+ [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ;
diff --git a/extra/jamshred/sound/sound.factor b/extra/jamshred/sound/sound.factor
new file mode 100644
index 0000000000..6a9b331f33
--- /dev/null
+++ b/extra/jamshred/sound/sound.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.pathnames kernel openal sequences ;
+IN: jamshred.sound
+
+TUPLE: sounds bang ;
+
+: assign-sound ( source wav-path -- )
+ resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
+
+: <sounds> ( -- sounds )
+ init-openal 1 gen-sources first sounds boa
+ dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
+
+: bang ( sounds -- ) bang>> source-play check-error ;
diff --git a/extra/jamshred/summary.txt b/extra/jamshred/summary.txt
new file mode 100644
index 0000000000..e26fc1cf8b
--- /dev/null
+++ b/extra/jamshred/summary.txt
@@ -0,0 +1 @@
+A simple 3d tunnel racing game
diff --git a/extra/jamshred/tags.txt b/extra/jamshred/tags.txt
new file mode 100644
index 0000000000..8ae5957a4b
--- /dev/null
+++ b/extra/jamshred/tags.txt
@@ -0,0 +1,2 @@
+applications
+games
diff --git a/extra/jamshred/tunnel/authors.txt b/extra/jamshred/tunnel/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/jamshred/tunnel/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/extra/jamshred/tunnel/tunnel-tests.factor b/extra/jamshred/tunnel/tunnel-tests.factor
new file mode 100644
index 0000000000..8e2f1a6fab
--- /dev/null
+++ b/extra/jamshred/tunnel/tunnel-tests.factor
@@ -0,0 +1,45 @@
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences specialized-arrays.float tools.test ;
+IN: jamshred.tunnel.tests
+
+[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
+ T{ segment f { 1 1 1 } f f f 1 }
+ T{ oint f { 0 0 0.25 } }
+ nearer-segment number>> ] unit-test
+
+[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
+
+[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
+
+[ float-array{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
+
+: test-segment-oint ( -- oint )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
+
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
+
+: simplest-straight-ahead ( -- oint segment )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
+
+: simple-collision-up ( -- oint segment )
+ { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
+[ { 0.0 1.0 0.0 } ]
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor
new file mode 100644
index 0000000000..6171c3053b
--- /dev/null
+++ b/extra/jamshred/tunnel/tunnel.factor
@@ -0,0 +1,165 @@
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors combinators kernel literals locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences specialized-arrays.float vectors jamshred.oint ;
+IN: jamshred.tunnel
+
+CONSTANT: n-segments 5000
+
+TUPLE: segment < oint number color radius ;
+C: <segment> segment
+
+: segment-number++ ( segment -- )
+ [ number>> 1+ ] keep (>>number) ;
+
+: random-color ( -- color )
+ { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
+
+CONSTANT: tunnel-segment-distance 0.4
+CONSTANT: random-rotation-angle $[ pi 20 / ]
+
+: random-segment ( previous-segment -- segment )
+ clone dup random-rotation-angle random-turn
+ tunnel-segment-distance over go-forward
+ random-color >>color dup segment-number++ ;
+
+: (random-segments) ( segments n -- segments )
+ dup 0 > [
+ [ dup peek random-segment over push ] dip 1- (random-segments)
+ ] [ drop ] if ;
+
+CONSTANT: default-segment-radius 1
+
+: initial-segment ( -- segment )
+ float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
+ 0 random-color default-segment-radius <segment> ;
+
+: random-segments ( n -- segments )
+ initial-segment 1vector swap (random-segments) ;
+
+: simple-segment ( n -- segment )
+ [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
+ random-color default-segment-radius <segment> ;
+
+: simple-segments ( n -- segments )
+ [ simple-segment ] map ;
+
+: <random-tunnel> ( -- segments )
+ n-segments random-segments ;
+
+: <straight-tunnel> ( -- segments )
+ n-segments simple-segments ;
+
+: sub-tunnel ( from to segments -- segments )
+ #! return segments between from and to, after clamping from and to to
+ #! valid values
+ [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
+
+: nearer-segment ( segment segment oint -- segment )
+ #! return whichever of the two segments is nearer to the oint
+ [ 2dup ] dip tuck distance [ distance ] dip < -rot ? ;
+
+: (find-nearest-segment) ( nearest next oint -- nearest ? )
+ #! find the nearest of 'next' and 'nearest' to 'oint', and return
+ #! t if the nearest hasn't changed
+ pick [ nearer-segment dup ] dip = ;
+
+: find-nearest-segment ( oint segments -- segment )
+ dup first swap rest-slice rot [ (find-nearest-segment) ] curry
+ find 2drop ;
+
+: nearest-segment-forward ( segments oint start -- segment )
+ rot dup length swap <slice> find-nearest-segment ;
+
+: nearest-segment-backward ( segments oint start -- segment )
+ swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
+
+: nearest-segment ( segments oint start-segment -- segment )
+ #! find the segment nearest to 'oint', and return it.
+ #! start looking at segment 'start-segment'
+ number>> over [
+ [ nearest-segment-forward ] 3keep nearest-segment-backward
+ ] dip nearer-segment ;
+
+: get-segment ( segments n -- segment )
+ over sequence-index-range clamp-to-range swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+ number>> 1+ get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+ number>> 1- get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+ #! the next segment on the given heading
+ over forward>> v. 0 <=> {
+ { +gt+ [ next-segment ] }
+ { +lt+ [ previous-segment ] }
+ { +eq+ [ nip ] } ! current segment
+ } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+ [let | cf [ current forward>> ] |
+ cf next location>> v. cf location v. - cf heading v. / ] ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ [let | cf [ current forward>> ]
+ h [ next current half-way-between-oints ] |
+ cf h v. cf location v. - cf heading v. / ] ;
+
+: vector-to-centre ( seg loc -- v )
+ over location>> swap v- swap forward>> proj-perp ;
+
+: distance-from-centre ( seg loc -- distance )
+ vector-to-centre norm ;
+
+: wall-normal ( seg oint -- n )
+ location>> vector-to-centre normalize ;
+
+CONSTANT: distant 1000
+
+: max-real ( a b -- c )
+ #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ dup real? [
+ over real? [ max ] [ nip ] if
+ ] [
+ drop dup real? [ drop distant ] unless
+ ] if ;
+
+:: collision-coefficient ( v w r -- c )
+ v norm 0 = [
+ distant
+ ] [
+ [let* | a [ v dup v. ]
+ b [ v w v. 2 * ]
+ c [ w dup v. r sq - ] |
+ c b a quadratic max-real ]
+ ] if ;
+
+: sideways-heading ( oint segment -- v )
+ [ forward>> ] bi@ proj-perp ;
+
+: sideways-relative-location ( oint segment -- loc )
+ [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
+
+: (distance-to-collision) ( oint segment -- distance )
+ [ sideways-heading ] [ sideways-relative-location ]
+ [ nip radius>> ] 2tri collision-coefficient ;
+
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
+
+: bounce-forward ( segment oint -- )
+ [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-left ( segment oint -- )
+ #! must be done after forward
+ [ forward>> vneg ] dip [ left>> swap reflect ]
+ [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
+
+: bounce-up ( segment oint -- )
+ #! must be done after forward and left!
+ nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
+
+: bounce-off-wall ( oint segment -- )
+ swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+
diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor
index 02f5ce8b21..9f86336f96 100755
--- a/extra/key-caps/key-caps.factor
+++ b/extra/key-caps/key-caps.factor
@@ -141,7 +141,7 @@ TUPLE: key-caps-gadget < gadget keys alarm ;
swap [
" " [ drop ] <border-button>
swap [ first >>loc ] [ second >>dim ] bi
- ] [ execute ] bi*
+ ] [ execute( -- value ) ] bi*
] dip set-nth ;
: add-keys-gadgets ( gadget -- gadget )
diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor
index 7ac69d2980..4ba8e2f66b 100755
--- a/extra/koszul/koszul.factor
+++ b/extra/koszul/koszul.factor
@@ -165,7 +165,7 @@ DEFER: (d)
swap call [ at 0 or ] curry map ; inline
: op-matrix ( domain range quot -- matrix )
- rot [ [ 2dup ] dip (op-matrix) ] map 2nip ; inline
+ rot [ (op-matrix) ] with with map ; inline
: d-matrix ( domain range -- matrix )
[ (d) ] op-matrix ;
diff --git a/extra/mason/build/build-tests.factor b/extra/mason/build/build-tests.factor
index 1e3705629f..4f5825e4dd 100644
--- a/extra/mason/build/build-tests.factor
+++ b/extra/mason/build/build-tests.factor
@@ -1,5 +1,2 @@
USING: mason.build tools.test sequences ;
IN: mason.build.tests
-
-{ create-build-dir enter-build-dir clone-builds-factor record-id }
-[ must-infer ] each
diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor
index 90ca1d31ff..199d48dec0 100644
--- a/extra/mason/build/build.factor
+++ b/extra/mason/build/build.factor
@@ -1,8 +1,9 @@
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays calendar io.directories io.encodings.utf8
+USING: arrays kernel calendar io.directories io.encodings.utf8
io.files io.launcher mason.child mason.cleanup mason.common
-mason.help mason.release mason.report namespaces prettyprint ;
+mason.help mason.release mason.report mason.email mason.notify
+namespaces prettyprint ;
IN: mason.build
QUALIFIED: continuations
@@ -14,20 +15,21 @@ QUALIFIED: continuations
: enter-build-dir ( -- ) build-dir set-current-directory ;
: clone-builds-factor ( -- )
- "git" "clone" builds/factor 3array try-process ;
+ "git" "clone" builds/factor 3array try-output-process ;
-: record-id ( -- )
- "factor" [ git-id ] with-directory "git-id" to-file ;
+: begin-build ( -- )
+ "factor" [ git-id ] with-directory
+ [ "git-id" to-file ] [ notify-begin-build ] bi ;
: build ( -- )
create-build-dir
enter-build-dir
clone-builds-factor
[
- record-id
+ begin-build
build-child
- upload-help
- release
+ [ notify-report ]
+ [ status-clean eq? [ upload-help release ] when ] bi
] [ cleanup ] [ ] continuations:cleanup ;
MAIN: build
diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor
index 27bb42ed07..2d5a7c6635 100644
--- a/extra/mason/child/child-tests.factor
+++ b/extra/mason/child/child-tests.factor
@@ -1,5 +1,5 @@
IN: mason.child.tests
-USING: mason.child mason.config tools.test namespaces ;
+USING: mason.child mason.config tools.test namespaces io kernel sequences ;
[ { "make" "winnt-x86-32" } ] [
[
@@ -40,3 +40,23 @@ USING: mason.child mason.config tools.test namespaces ;
boot-cmd
] with-scope
] unit-test
+
+[ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] must-infer
+
+[ 4 ] [ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] unit-test
+
+[ 3 ] [ [ "Hi" throw ] [ drop 3 ] [ 4 ] recover-else ] unit-test
+
+[ "A" ] [
+ {
+ { [ 3 throw ] [ { "X" "Y" "Z" "A" } nth ] }
+ [ "B" ]
+ } recover-cond
+] unit-test
+
+[ "B" ] [
+ {
+ { [ ] [ ] }
+ [ "B" ]
+ } recover-cond
+] unit-test
\ No newline at end of file
diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor
index feb11933fb..8132e62078 100755
--- a/extra/mason/child/child.factor
+++ b/extra/mason/child/child.factor
@@ -1,9 +1,10 @@
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar combinators.short-circuit
+USING: accessors arrays calendar combinators.short-circuit fry
continuations debugger io.directories io.files io.launcher
io.pathnames io.encodings.ascii kernel make mason.common mason.config
-mason.platform mason.report mason.email namespaces sequences ;
+mason.platform mason.report mason.notify namespaces sequences
+quotations macros ;
IN: mason.child
: make-cmd ( -- args )
@@ -58,29 +59,18 @@ IN: mason.child
try-process
] with-directory ;
-: return-with ( obj -- * ) return-continuation get continue-with ;
+: recover-else ( try catch else -- )
+ [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline
-: build-clean? ( -- ? )
+MACRO: recover-cond ( alist -- )
+ dup { [ length 1 = ] [ first callable? ] } 1&&
+ [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ;
+
+: build-child ( -- status )
+ copy-image
{
- [ load-everything-vocabs-file eval-file empty? ]
- [ test-all-vocabs-file eval-file empty? ]
- [ help-lint-vocabs-file eval-file empty? ]
- [ compiler-errors-file eval-file empty? ]
- } 0&& ;
-
-: build-child ( -- )
- [
- return-continuation set
-
- copy-image
-
- [ make-vm ] [ compile-failed-report status-error return-with ] recover
- [ boot ] [ boot-failed-report status-error return-with ] recover
- [ test ] [ test-failed-report status-error return-with ] recover
-
- successful-report
-
- build-clean? status-clean status-dirty ? return-with
- ] callcc1
- status set
- email-report ;
\ No newline at end of file
+ { [ notify-make-vm make-vm ] [ compile-failed ] }
+ { [ notify-boot boot ] [ boot-failed ] }
+ { [ notify-test test ] [ test-failed ] }
+ [ success ]
+ } recover-cond ;
\ No newline at end of file
diff --git a/extra/mason/cleanup/cleanup-tests.factor b/extra/mason/cleanup/cleanup-tests.factor
index 9158536ffb..49a5153a8e 100644
--- a/extra/mason/cleanup/cleanup-tests.factor
+++ b/extra/mason/cleanup/cleanup-tests.factor
@@ -1,4 +1,2 @@
USING: tools.test mason.cleanup ;
IN: mason.cleanup.tests
-
-\ cleanup must-infer
diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor
old mode 100644
new mode 100755
index a2c087392a..3e6209fed0
--- a/extra/mason/cleanup/cleanup.factor
+++ b/extra/mason/cleanup/cleanup.factor
@@ -5,19 +5,20 @@ io.directories.hierarchy io.files io.launcher kernel
mason.common mason.config mason.platform namespaces ;
IN: mason.cleanup
+: compress ( filename -- )
+ dup exists? [ "bzip2" swap 2array try-output-process ] [ drop ] if ;
+
: compress-image ( -- )
- "bzip2" boot-image-name 2array try-process ;
+ boot-image-name compress ;
: compress-test-log ( -- )
- "test-log" exists? [
- { "bzip2" "test-log" } try-process
- ] when ;
+ "test-log" compress ;
: cleanup ( -- )
builder-debug get [
build-dir [
compress-image
compress-test-log
- "factor" delete-tree
+ "factor" really-delete-tree
] with-directory
] unless ;
diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor
old mode 100644
new mode 100755
index 3cd38e1ff4..e4a9d9da13
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@@ -2,17 +2,40 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences splitting system accessors
math.functions make io io.files io.pathnames io.directories
-io.launcher io.encodings.utf8 prettyprint
+io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
-calendar.format arrays mason.config locals ;
+calendar.format arrays mason.config locals system debugger ;
IN: mason.common
+ERROR: output-process-error output process ;
+
+M: output-process-error error.
+ [ "Process:" print process>> . nl ]
+ [ "Output:" print output>> print ]
+ bi ;
+
+: try-output-process ( command -- )
+ >process +stdout+ >>stderr utf8 <process-reader*>
+ [ stream-contents ] [ dup wait-for-process ] bi*
+ 0 = [ 2drop ] [ output-process-error ] if ;
+
+HOOK: really-delete-tree os ( path -- )
+
+M: windows really-delete-tree
+ #! Workaround: Cygwin GIT creates read-only files for
+ #! some reason.
+ [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ]
+ [ delete-tree ]
+ bi ;
+
+M: unix really-delete-tree delete-tree ;
+
: short-running-process ( command -- )
#! Give network operations at most 15 minutes to complete.
<process>
swap >>command
15 minutes >>timeout
- try-process ;
+ try-output-process ;
:: upload-safely ( local username host remote -- )
[let* | temp [ remote ".incomplete" append ]
@@ -57,7 +80,7 @@ SYMBOL: stamp
: prepare-build-machine ( -- )
builds-dir get make-directories
builds-dir get
- [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ]
+ [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ]
with-directory ;
: git-id ( -- id )
@@ -67,8 +90,8 @@ SYMBOL: stamp
: ?prepare-build-machine ( -- )
builds/factor exists? [ prepare-build-machine ] unless ;
-CONSTANT: load-everything-vocabs-file "load-everything-vocabs"
-CONSTANT: load-everything-errors-file "load-everything-errors"
+CONSTANT: load-all-vocabs-file "load-everything-vocabs"
+CONSTANT: load-all-errors-file "load-everything-errors"
CONSTANT: test-all-vocabs-file "test-all-vocabs"
CONSTANT: test-all-errors-file "test-all-errors"
@@ -76,17 +99,19 @@ CONSTANT: test-all-errors-file "test-all-errors"
CONSTANT: help-lint-vocabs-file "help-lint-vocabs"
CONSTANT: help-lint-errors-file "help-lint-errors"
+CONSTANT: compiler-errors-file "compiler-errors"
+CONSTANT: compiler-error-messages-file "compiler-error-messages"
+
CONSTANT: boot-time-file "boot-time"
CONSTANT: load-time-file "load-time"
-CONSTANT: compiler-errors-file "compiler-errors"
CONSTANT: test-time-file "test-time"
CONSTANT: help-lint-time-file "help-lint-time"
CONSTANT: benchmark-time-file "benchmark-time"
CONSTANT: html-help-time-file "html-help-time"
CONSTANT: benchmarks-file "benchmarks"
-
-SYMBOL: status
+CONSTANT: benchmark-error-messages-file "benchmark-error-messages"
+CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs"
SYMBOL: status-error ! didn't bootstrap, or crashed
SYMBOL: status-dirty ! bootstrapped but not all tests passed
diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor
index 51b09543f4..5ec44df0a9 100644
--- a/extra/mason/config/config.factor
+++ b/extra/mason/config/config.factor
@@ -11,12 +11,17 @@ builds-dir get-global [
home "builds" append-path builds-dir set-global
] unless
-! Who sends build reports.
+! Who sends build report e-mails.
SYMBOL: builder-from
-! Who receives build reports.
+! Who receives build report e-mails.
SYMBOL: builder-recipients
+! (Optional) twitter credentials for status updates.
+SYMBOL: builder-twitter-username
+
+SYMBOL: builder-twitter-password
+
! (Optional) CPU architecture to build for.
SYMBOL: target-cpu
@@ -34,6 +39,12 @@ target-os get-global [
! Keep test-log around?
SYMBOL: builder-debug
+! Host to send status notifications to.
+SYMBOL: status-host
+
+! Username to log in.
+SYMBOL: status-username
+
SYMBOL: upload-help?
! The below are only needed if upload-help is true.
diff --git a/extra/mason/email/email-tests.factor b/extra/mason/email/email-tests.factor
index 5bde9a9cfe..e2afe01a56 100644
--- a/extra/mason/email/email-tests.factor
+++ b/extra/mason/email/email-tests.factor
@@ -5,7 +5,6 @@ USING: mason.email mason.common mason.config namespaces tools.test ;
[
"linux" target-os set
"x86.64" target-cpu set
- status-error status set
- subject prefix-subject
+ status-error subject prefix-subject
] with-scope
] unit-test
diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor
index f25f7e5cfa..23203e5222 100644
--- a/extra/mason/email/email.factor
+++ b/extra/mason/email/email.factor
@@ -1,35 +1,35 @@
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces accessors combinators make smtp
-debugger prettyprint io io.streams.string io.encodings.utf8
-io.files io.sockets
+USING: kernel namespaces accessors combinators make smtp debugger
+prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets
mason.common mason.platform mason.config ;
IN: mason.email
: prefix-subject ( str -- str' )
[ "mason on " % platform % ": " % % ] "" make ;
-: email-status ( body subject -- )
+: email-status ( body content-type subject -- )
<email>
builder-from get >>from
builder-recipients get >>to
swap prefix-subject >>subject
+ swap >>content-type
swap >>body
send-email ;
-: subject ( -- str )
- status get {
+: subject ( status -- str )
+ {
{ status-clean [ "clean" ] }
{ status-dirty [ "dirty" ] }
{ status-error [ "error" ] }
} case ;
-: email-report ( -- )
- "report" utf8 file-contents subject email-status ;
+: email-report ( report status -- )
+ [ "text/html" ] dip subject email-status ;
: email-error ( error callstack -- )
[
"Fatal error on " write host-name print nl
[ error. ] [ callstack. ] bi*
- ] with-string-writer "fatal error"
+ ] with-string-writer "text/plain" "fatal error"
email-status ;
diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor
index 9a4e2be996..9ed9653a08 100644
--- a/extra/mason/help/help.factor
+++ b/extra/mason/help/help.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays help.html io.directories io.files io.launcher
kernel make mason.common mason.config namespaces sequences ;
@@ -6,7 +6,7 @@ IN: mason.help
: make-help-archive ( -- )
"factor/temp" [
- { "tar" "cfz" "docs.tar.gz" "docs" } try-process
+ { "tar" "cfz" "docs.tar.gz" "docs" } try-output-process
] with-directory ;
: upload-help-archive ( -- )
@@ -16,11 +16,8 @@ IN: mason.help
help-directory get "/docs.tar.gz" append
upload-safely ;
-: (upload-help) ( -- )
+: upload-help ( -- )
upload-help? get [
make-help-archive
upload-help-archive
- ] when ;
-
-: upload-help ( -- )
- status get status-clean eq? [ (upload-help) ] when ;
+ ] when ;
\ No newline at end of file
diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor
index 299a2f4e1f..d425985e76 100644
--- a/extra/mason/mason.factor
+++ b/extra/mason/mason.factor
@@ -6,7 +6,8 @@ mason.email mason.updates namespaces threads ;
IN: mason
: build-loop-error ( error -- )
- error-continuation get call>> email-error ;
+ [ "Build loop error:" print flush error. flush ]
+ [ error-continuation get call>> email-error ] bi ;
: build-loop-fatal ( error -- )
"FATAL BUILDER ERROR:" print
diff --git a/extra/mason/notify/authors.txt b/extra/mason/notify/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/mason/notify/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor
new file mode 100644
index 0000000000..96e31c4a45
--- /dev/null
+++ b/extra/mason/notify/notify.factor
@@ -0,0 +1,48 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors io io.sockets io.encodings.utf8 io.files
+io.launcher kernel make mason.config mason.common mason.email
+mason.twitter namespaces sequences prettyprint ;
+IN: mason.notify
+
+: status-notify ( input-file args -- )
+ status-host get [
+ [
+ "ssh" , status-host get , "-l" , status-username get ,
+ "./mason-notify" ,
+ host-name ,
+ target-cpu get ,
+ target-os get ,
+ ] { } make prepend
+ <process>
+ swap >>command
+ swap [ +closed+ ] unless* >>stdin
+ try-output-process
+ ] [ 2drop ] if ;
+
+: notify-begin-build ( git-id -- )
+ [ "Starting build of GIT ID " write print flush ]
+ [ f swap "git-id" swap 2array status-notify ]
+ bi ;
+
+: notify-make-vm ( -- )
+ "Compiling VM" print flush
+ f { "make-vm" } status-notify ;
+
+: notify-boot ( -- )
+ "Bootstrapping" print flush
+ f { "boot" } status-notify ;
+
+: notify-test ( -- )
+ "Running tests" print flush
+ f { "test" } status-notify ;
+
+: notify-report ( status -- )
+ [ "Build finished with status: " write . flush ]
+ [
+ [ "report" utf8 file-contents ] dip email-report
+ "report" { "report" } status-notify
+ ] bi ;
+
+: notify-release ( archive-name -- )
+ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
\ No newline at end of file
diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor
old mode 100644
new mode 100755
index 5ef424ad4f..79d6993a91
--- a/extra/mason/release/archive/archive.factor
+++ b/extra/mason/release/archive/archive.factor
@@ -18,23 +18,23 @@ IN: mason.release.archive
: archive-name ( -- string ) base-name extension append ;
-: make-windows-archive ( -- )
- [ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ;
+: make-windows-archive ( archive-name -- )
+ [ "zip" , "-r" , , "factor" , ] { } make try-output-process ;
-: make-macosx-archive ( -- )
- { "mkdir" "dmg-root" } try-process
- { "cp" "-R" "factor" "dmg-root" } try-process
+: make-macosx-archive ( archive-name -- )
+ { "mkdir" "dmg-root" } try-output-process
+ { "cp" "-R" "factor" "dmg-root" } try-output-process
{ "hdiutil" "create"
"-srcfolder" "dmg-root"
"-fs" "HFS+"
"-volname" "factor" }
- archive-name suffix try-process
- "dmg-root" delete-tree ;
+ swap suffix try-output-process
+ "dmg-root" really-delete-tree ;
-: make-unix-archive ( -- )
- [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ;
+: make-unix-archive ( archive-name -- )
+ [ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ;
-: make-archive ( -- )
+: make-archive ( archive-name -- )
target-os get {
{ "winnt" [ make-windows-archive ] }
{ "macosx" [ make-macosx-archive ] }
@@ -44,5 +44,5 @@ IN: mason.release.archive
: releases ( -- path )
builds-dir get "releases" append-path dup make-directories ;
-: save-archive ( -- )
- archive-name releases move-file-into ;
\ No newline at end of file
+: save-archive ( archive-name -- )
+ releases move-file-into ;
\ No newline at end of file
diff --git a/extra/mason/release/release.factor b/extra/mason/release/release.factor
index bbb47ba0d3..fc4ad0b08a 100644
--- a/extra/mason/release/release.factor
+++ b/extra/mason/release/release.factor
@@ -1,16 +1,17 @@
-! Copyright (C) 2008 Eduardo Cavazos.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel debugger namespaces sequences splitting
+USING: kernel debugger namespaces sequences splitting combinators
combinators io io.files io.launcher prettyprint bootstrap.image
mason.common mason.release.branch mason.release.tidy
-mason.release.archive mason.release.upload ;
+mason.release.archive mason.release.upload mason.notify ;
IN: mason.release
-: (release) ( -- )
+: release ( -- )
update-clean-branch
tidy
- make-archive
- upload
- save-archive ;
-
-: release ( -- ) status get status-clean eq? [ (release) ] when ;
\ No newline at end of file
+ archive-name {
+ [ make-archive ]
+ [ upload ]
+ [ save-archive ]
+ [ notify-release ]
+ } cleave ;
\ No newline at end of file
diff --git a/extra/mason/release/tidy/tidy.factor b/extra/mason/release/tidy/tidy.factor
old mode 100644
new mode 100755
index 497be09044..054b15f0f5
--- a/extra/mason/release/tidy/tidy.factor
+++ b/extra/mason/release/tidy/tidy.factor
@@ -12,11 +12,11 @@ IN: mason.release.tidy
append ;
: remove-common-files ( -- )
- common-files [ delete-tree ] each ;
+ common-files [ really-delete-tree ] each ;
: remove-factor-app ( -- )
target-os get "macosx" =
- [ "Factor.app" delete-tree ] unless ;
+ [ "Factor.app" really-delete-tree ] unless ;
: tidy ( -- )
"factor" [ remove-factor-app remove-common-files ] with-directory ;
diff --git a/extra/mason/release/upload/upload-tests.factor b/extra/mason/release/upload/upload-tests.factor
index 73fc311399..09f1e13ae9 100644
--- a/extra/mason/release/upload/upload-tests.factor
+++ b/extra/mason/release/upload/upload-tests.factor
@@ -1,4 +1,3 @@
IN: mason.release.upload.tests
USING: mason.release.upload tools.test ;
-\ upload must-infer
diff --git a/extra/mason/release/upload/upload.factor b/extra/mason/release/upload/upload.factor
index 68f2ffcdb5..d3e11c3fc3 100644
--- a/extra/mason/release/upload/upload.factor
+++ b/extra/mason/release/upload/upload.factor
@@ -8,14 +8,13 @@ IN: mason.release.upload
: remote-location ( -- dest )
upload-directory get "/" platform 3append ;
-: remote-archive-name ( -- dest )
- remote-location "/" archive-name 3append ;
+: remote-archive-name ( archive-name -- dest )
+ [ remote-location "/" ] dip 3append ;
-: upload ( -- )
+: upload ( archive-name -- )
upload-to-factorcode? get [
- archive-name
upload-username get
upload-host get
- remote-archive-name
+ pick remote-archive-name
upload-safely
- ] when ;
+ ] [ drop ] if ;
diff --git a/extra/mason/report/fake-data/benchmark-error-messages b/extra/mason/report/fake-data/benchmark-error-messages
new file mode 100644
index 0000000000..f738144e3c
--- /dev/null
+++ b/extra/mason/report/fake-data/benchmark-error-messages
@@ -0,0 +1 @@
+Benchmarks
diff --git a/extra/mason/report/fake-data/benchmark-error-vocabs b/extra/mason/report/fake-data/benchmark-error-vocabs
new file mode 100644
index 0000000000..b5a85b9c41
--- /dev/null
+++ b/extra/mason/report/fake-data/benchmark-error-vocabs
@@ -0,0 +1 @@
+{ "benchmarks" }
diff --git a/extra/mason/report/fake-data/benchmark-time b/extra/mason/report/fake-data/benchmark-time
new file mode 100644
index 0000000000..81c545efeb
--- /dev/null
+++ b/extra/mason/report/fake-data/benchmark-time
@@ -0,0 +1 @@
+1234
diff --git a/extra/mason/report/fake-data/benchmarks b/extra/mason/report/fake-data/benchmarks
new file mode 100644
index 0000000000..ed8ec42879
--- /dev/null
+++ b/extra/mason/report/fake-data/benchmarks
@@ -0,0 +1 @@
+H{ { "a" 1 } { "b" 2 } }
diff --git a/extra/mason/report/fake-data/boot-log b/extra/mason/report/fake-data/boot-log
new file mode 100644
index 0000000000..d9e4d79562
--- /dev/null
+++ b/extra/mason/report/fake-data/boot-log
@@ -0,0 +1,2 @@
+Boot
+Log
diff --git a/extra/mason/report/fake-data/boot-time b/extra/mason/report/fake-data/boot-time
new file mode 100644
index 0000000000..81c545efeb
--- /dev/null
+++ b/extra/mason/report/fake-data/boot-time
@@ -0,0 +1 @@
+1234
diff --git a/extra/mason/report/fake-data/compile-log b/extra/mason/report/fake-data/compile-log
new file mode 100644
index 0000000000..5007c38d13
--- /dev/null
+++ b/extra/mason/report/fake-data/compile-log
@@ -0,0 +1,2 @@
+Compile
+Log
diff --git a/extra/mason/report/fake-data/compiler-error-messages b/extra/mason/report/fake-data/compiler-error-messages
new file mode 100644
index 0000000000..1a58d6dcf0
--- /dev/null
+++ b/extra/mason/report/fake-data/compiler-error-messages
@@ -0,0 +1 @@
+Compiler errors
diff --git a/extra/mason/report/fake-data/compiler-errors b/extra/mason/report/fake-data/compiler-errors
new file mode 100644
index 0000000000..4e5eee20e2
--- /dev/null
+++ b/extra/mason/report/fake-data/compiler-errors
@@ -0,0 +1 @@
+{ "compiler-errors" }
diff --git a/extra/mason/report/fake-data/git-id b/extra/mason/report/fake-data/git-id
new file mode 100644
index 0000000000..d4d308b176
--- /dev/null
+++ b/extra/mason/report/fake-data/git-id
@@ -0,0 +1 @@
+"deadbeef"
diff --git a/extra/mason/report/fake-data/help-lint-errors b/extra/mason/report/fake-data/help-lint-errors
new file mode 100644
index 0000000000..da540b4802
--- /dev/null
+++ b/extra/mason/report/fake-data/help-lint-errors
@@ -0,0 +1 @@
+Help lint
diff --git a/extra/mason/report/fake-data/help-lint-time b/extra/mason/report/fake-data/help-lint-time
new file mode 100644
index 0000000000..81c545efeb
--- /dev/null
+++ b/extra/mason/report/fake-data/help-lint-time
@@ -0,0 +1 @@
+1234
diff --git a/extra/mason/report/fake-data/help-lint-vocabs b/extra/mason/report/fake-data/help-lint-vocabs
new file mode 100644
index 0000000000..6d88a7fff8
--- /dev/null
+++ b/extra/mason/report/fake-data/help-lint-vocabs
@@ -0,0 +1 @@
+{ "help-lint" }
diff --git a/extra/mason/report/fake-data/html-help-time b/extra/mason/report/fake-data/html-help-time
new file mode 100644
index 0000000000..81c545efeb
--- /dev/null
+++ b/extra/mason/report/fake-data/html-help-time
@@ -0,0 +1 @@
+1234
diff --git a/extra/mason/report/fake-data/load-everything-errors b/extra/mason/report/fake-data/load-everything-errors
new file mode 100644
index 0000000000..00d830932d
--- /dev/null
+++ b/extra/mason/report/fake-data/load-everything-errors
@@ -0,0 +1 @@
+Load everything
diff --git a/extra/mason/report/fake-data/load-everything-vocabs b/extra/mason/report/fake-data/load-everything-vocabs
new file mode 100644
index 0000000000..2ecd4f611c
--- /dev/null
+++ b/extra/mason/report/fake-data/load-everything-vocabs
@@ -0,0 +1 @@
+{ "load-everything" }
diff --git a/extra/mason/report/fake-data/load-time b/extra/mason/report/fake-data/load-time
new file mode 100644
index 0000000000..81c545efeb
--- /dev/null
+++ b/extra/mason/report/fake-data/load-time
@@ -0,0 +1 @@
+1234
diff --git a/extra/mason/report/fake-data/test-all-errors b/extra/mason/report/fake-data/test-all-errors
new file mode 100644
index 0000000000..13a64ee834
--- /dev/null
+++ b/extra/mason/report/fake-data/test-all-errors
@@ -0,0 +1 @@
+Test all errors
diff --git a/extra/mason/report/fake-data/test-all-vocabs b/extra/mason/report/fake-data/test-all-vocabs
new file mode 100644
index 0000000000..ef6294b9c7
--- /dev/null
+++ b/extra/mason/report/fake-data/test-all-vocabs
@@ -0,0 +1 @@
+{ "test-all" }
diff --git a/extra/mason/report/fake-data/test-log b/extra/mason/report/fake-data/test-log
new file mode 100644
index 0000000000..0b8521b008
--- /dev/null
+++ b/extra/mason/report/fake-data/test-log
@@ -0,0 +1,2 @@
+Test
+Log
diff --git a/extra/mason/report/fake-data/test-time b/extra/mason/report/fake-data/test-time
new file mode 100644
index 0000000000..81c545efeb
--- /dev/null
+++ b/extra/mason/report/fake-data/test-time
@@ -0,0 +1 @@
+1234
diff --git a/extra/mason/report/report-tests.factor b/extra/mason/report/report-tests.factor
index 7f5c4f1d30..92cada72da 100644
--- a/extra/mason/report/report-tests.factor
+++ b/extra/mason/report/report-tests.factor
@@ -1,2 +1,28 @@
IN: mason.report.tests
-USING: mason.report tools.test ;
+USING: io.files io.directories kernel mason.report mason.common
+tools.test xml xml.writer ;
+
+{ 0 0 } [ [ ] with-report ] must-infer-as
+
+: verify-report ( -- )
+ [ t ] [ "report" exists? ] unit-test
+ [ ] [ "report" file>xml drop ] unit-test
+ [ ] [ "report" delete-file ] unit-test ;
+
+"resource:extra/mason/report/fake-data/" [
+ [ ] [
+ timings-table pprint-xml
+ ] unit-test
+
+ [ ] [ successful-report ] unit-test
+ verify-report
+
+ [ status-error ] [ 1234 compile-failed ] unit-test
+ verify-report
+
+ [ status-error ] [ 1235 boot-failed ] unit-test
+ verify-report
+
+ [ status-error ] [ 1236 test-failed ] unit-test
+ verify-report
+] with-directory
diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor
index 52e1608885..7707d16299 100644
--- a/extra/mason/report/report.factor
+++ b/extra/mason/report/report.factor
@@ -1,74 +1,131 @@
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces debugger fry io io.files io.sockets
-io.encodings.utf8 prettyprint benchmark mason.common
-mason.platform mason.config sequences ;
+USING: benchmark combinators.smart debugger fry io assocs
+io.encodings.utf8 io.files io.sockets io.streams.string kernel
+locals mason.common mason.config mason.platform math namespaces
+prettyprint sequences xml.syntax xml.writer combinators.short-circuit
+literals ;
IN: mason.report
-: time. ( file -- )
- [ write ": " write ] [ eval-file milli-seconds>time print ] bi ;
-
-: common-report ( -- )
- "Build machine: " write host-name print
- "CPU: " write target-cpu get print
- "OS: " write target-os get print
- "Build directory: " write build-dir print
- "git id: " write "git-id" eval-file print nl ;
+: common-report ( -- xml )
+ target-os get
+ target-cpu get
+ host-name
+ build-dir
+ "git-id" eval-file
+ [XML
+ <h1>Build report for <->/<-></h1>
+ <table>
+ <tr><td>Build machine:</td><td><-></td></tr>
+ <tr><td>Build directory:</td><td><-></td></tr>
+ <tr><td>GIT ID:</td><td><-></td></tr>
+ </table>
+ XML] ;
: with-report ( quot -- )
- [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; inline
+ [ "report" utf8 ] dip
+ '[
+ common-report
+ _ call( -- xml )
+ [XML <html><body><-><-></body></html> XML]
+ write-xml
+ ] with-file-writer ; inline
-: compile-failed-report ( error -- )
+:: failed-report ( error file what -- status )
[
- "VM compile failed:" print nl
- "compile-log" cat nl
- error.
- ] with-report ;
+ error [ error. ] with-string-writer :> error
+ file utf8 file-contents 400 short tail* :> output
+
+ [XML
+ <h2><-what-></h2>
+ Build output:
+ <pre><-output-></pre>
+ Launcher error:
+ <pre><-error-></pre>
+ XML]
+ ] with-report
+ status-error ;
-: boot-failed-report ( error -- )
- [
- "Bootstrap failed:" print nl
- "boot-log" 100 cat-n nl
- error.
- ] with-report ;
+: compile-failed ( error -- status )
+ "compile-log" "VM compilation failed" failed-report ;
-: test-failed-report ( error -- )
+: boot-failed ( error -- status )
+ "boot-log" "Bootstrap failed" failed-report ;
+
+: test-failed ( error -- status )
+ "test-log" "Tests failed" failed-report ;
+
+: timings-table ( -- xml )
+ {
+ $ boot-time-file
+ $ load-time-file
+ $ test-time-file
+ $ help-lint-time-file
+ $ benchmark-time-file
+ $ html-help-time-file
+ } [
+ dup eval-file milli-seconds>time
+ [XML <tr><td><-></td><td><-></td></tr> XML]
+ ] map [XML <h2>Timings</h2> <table><-></table> XML] ;
+
+: error-dump ( heading vocabs-file messages-file -- xml )
+ [ eval-file ] dip over empty? [ 3drop f ] [
+ [ ]
+ [ [ [XML <li><-></li> XML] ] map [XML <ul><-></ul> XML] ]
+ [ utf8 file-contents ]
+ tri*
+ [XML <h1><-></h1> <-> Details: <pre><-></pre> XML]
+ ] if ;
+
+: benchmarks-table ( assoc -- xml )
[
- "Tests failed:" print nl
- "test-log" 100 cat-n nl
- error.
- ] with-report ;
+ 1000000 /f
+ [XML <tr><td><-></td><td><-></td></tr> XML]
+ ] { } assoc>map [XML <h2>Benchmarks</h2> <table><-></table> XML] ;
: successful-report ( -- )
[
- boot-time-file time.
- load-time-file time.
- test-time-file time.
- help-lint-time-file time.
- benchmark-time-file time.
- html-help-time-file time.
+ [
+ timings-table
- nl
+ "Load failures"
+ load-all-vocabs-file
+ load-all-errors-file
+ error-dump
- load-everything-vocabs-file eval-file [
- "== Did not pass load-everything:" print .
- load-everything-errors-file cat
- ] unless-empty
+ "Compiler errors"
+ compiler-errors-file
+ compiler-error-messages-file
+ error-dump
- compiler-errors-file eval-file [
- "== Vocabularies with compiler errors:" print .
- ] unless-empty
+ "Unit test failures"
+ test-all-vocabs-file
+ test-all-errors-file
+ error-dump
+
+ "Help lint failures"
+ help-lint-vocabs-file
+ help-lint-errors-file
+ error-dump
- test-all-vocabs-file eval-file [
- "== Did not pass test-all:" print .
- test-all-errors-file cat
- ] unless-empty
+ "Benchmark errors"
+ benchmark-error-vocabs-file
+ benchmark-error-messages-file
+ error-dump
+
+ "Benchmark timings"
+ benchmarks-file eval-file benchmarks-table
+ ] output>array
+ ] with-report ;
- help-lint-vocabs-file eval-file [
- "== Did not pass help-lint:" print .
- help-lint-errors-file cat
- ] unless-empty
+: build-clean? ( -- ? )
+ {
+ [ load-all-vocabs-file eval-file empty? ]
+ [ test-all-vocabs-file eval-file empty? ]
+ [ help-lint-vocabs-file eval-file empty? ]
+ [ compiler-errors-file eval-file empty? ]
+ [ benchmark-error-vocabs-file eval-file empty? ]
+ } 0&& ;
- "== Benchmarks:" print
- benchmarks-file eval-file benchmarks.
- ] with-report ;
\ No newline at end of file
+: success ( -- status )
+ successful-report build-clean? status-clean status-dirty ? ;
\ No newline at end of file
diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor
index a15a96c63e..d50c77f71b 100644
--- a/extra/mason/test/test.factor
+++ b/extra/mason/test/test.factor
@@ -1,16 +1,17 @@
-! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
+! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs benchmark bootstrap.stage2
-compiler.errors generic help.html help.lint io.directories
+USING: accessors assocs benchmark bootstrap.stage2 compiler.errors
+source-files.errors generic help.html help.lint io.directories
io.encodings.utf8 io.files kernel mason.common math namespaces
prettyprint sequences sets sorting tools.test tools.time
-tools.vocabs words ;
+words system io tools.errors vocabs.hierarchy vocabs.errors
+vocabs.refresh locals ;
IN: mason.test
: do-load ( -- )
- try-everything
- [ keys load-everything-vocabs-file to-file ]
- [ load-everything-errors-file utf8 [ load-failures. ] with-file-writer ]
+ "" (load)
+ [ keys load-all-vocabs-file to-file ]
+ [ load-all-errors-file utf8 [ load-failures. ] with-file-writer ]
bi ;
GENERIC: word-vocabulary ( word -- vocabulary )
@@ -19,39 +20,59 @@ M: word word-vocabulary vocabulary>> ;
M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
-: do-compile-errors ( -- )
- compiler-errors-file utf8 [
- +error+ errors-of-type keys
- [ word-vocabulary ] map
- prune natural-sort .
- ] with-file-writer ;
+:: do-step ( errors summary-file details-file -- )
+ errors
+ [ error-type +linkage-error+ eq? not ] filter
+ [ file>> ] map prune natural-sort summary-file to-file
+ errors details-file utf8 [ errors. ] with-file-writer ;
: do-tests ( -- )
- run-all-tests
- [ keys test-all-vocabs-file to-file ]
- [ test-all-errors-file utf8 [ test-failures. ] with-file-writer ]
- bi ;
+ test-all test-failures get
+ test-all-vocabs-file
+ test-all-errors-file
+ do-step ;
: do-help-lint ( -- )
- "" run-help-lint
- [ keys help-lint-vocabs-file to-file ]
- [ help-lint-errors-file utf8 [ typos. ] with-file-writer ]
- bi ;
+ help-lint-all lint-failures get values
+ help-lint-vocabs-file
+ help-lint-errors-file
+ do-step ;
: do-benchmarks ( -- )
- run-benchmarks benchmarks-file to-file ;
+ run-benchmarks
+ [ benchmarks-file to-file ] [
+ [ keys benchmark-error-vocabs-file to-file ]
+ [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi
+ ] bi* ;
+
+: do-compile-errors ( -- )
+ compiler-errors get values
+ compiler-errors-file
+ compiler-error-messages-file
+ do-step ;
: benchmark-ms ( quot -- ms )
benchmark 1000 /i ; inline
+: check-boot-image ( -- )
+ "" to-refresh drop 2dup [ empty? not ] either?
+ [
+ "Boot image is out of date. Changed vocabs:" print
+ append prune [ print ] each
+ flush
+ 1 exit
+ ] [ 2drop ] if ;
+
: do-all ( -- )
".." [
bootstrap-time get boot-time-file to-file
- [ do-load do-compile-errors ] benchmark-ms load-time-file to-file
+ check-boot-image
+ [ do-load ] benchmark-ms load-time-file to-file
[ generate-help ] benchmark-ms html-help-time-file to-file
[ do-tests ] benchmark-ms test-time-file to-file
[ do-help-lint ] benchmark-ms help-lint-time-file to-file
[ do-benchmarks ] benchmark-ms benchmark-time-file to-file
+ do-compile-errors
] with-directory ;
MAIN: do-all
\ No newline at end of file
diff --git a/extra/mason/twitter/authors.txt b/extra/mason/twitter/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/mason/twitter/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/mason/twitter/twitter.factor b/extra/mason/twitter/twitter.factor
new file mode 100644
index 0000000000..21f1bcabc3
--- /dev/null
+++ b/extra/mason/twitter/twitter.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: debugger fry kernel mason.config namespaces twitter ;
+IN: mason.twitter
+
+: mason-tweet ( message -- )
+ builder-twitter-username get builder-twitter-password get and
+ [
+ [
+ builder-twitter-username get twitter-username set
+ builder-twitter-password get twitter-password set
+ '[ _ tweet ] try
+ ] with-scope
+ ] [ drop ] if ;
\ No newline at end of file
diff --git a/extra/math/analysis/analysis.factor b/extra/math/analysis/analysis.factor
index fa01b0376d..a1fc0bd07b 100755
--- a/extra/math/analysis/analysis.factor
+++ b/extra/math/analysis/analysis.factor
@@ -42,7 +42,7 @@ PRIVATE>
#! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
#! gamma(n+1) = n! for n > 0
dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
- drop 1./0.
+ drop 1/0.
] [
[ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
@@ -51,7 +51,7 @@ PRIVATE>
#! gammaln(x) is an alternative when gamma(x)'s range
#! varies too widely
dup 0 < [
- drop 1./0.
+ drop 1/0.
] [
[ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
] if ;
diff --git a/extra/math/binpack/binpack.factor b/extra/math/binpack/binpack.factor
index e3a009feb5..4bd1bc1b81 100644
--- a/extra/math/binpack/binpack.factor
+++ b/extra/math/binpack/binpack.factor
@@ -18,5 +18,5 @@ IN: math.binpack
[ dup zip ] dip binpack [ keys ] map ;
: binpack! ( items quot n -- bins )
- [ dupd map zip ] dip binpack [ keys ] map ;
+ [ dupd map zip ] dip binpack [ keys ] map ; inline
diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor
index 11e57d2639..78c726d370 100644
--- a/extra/math/function-tools/function-tools.factor
+++ b/extra/math/function-tools/function-tools.factor
@@ -9,10 +9,10 @@ IN: math.function-tools
[ bi - ] 2curry ; inline
: eval ( x func -- pt )
- dupd call 2array ; inline
+ dupd call( x -- y ) 2array ; inline
: eval-inverse ( y func -- pt )
- dupd call swap 2array ; inline
+ dupd call( y -- x ) swap 2array ; inline
: eval3d ( x y func -- pt )
- [ 2dup ] dip call 3array ; inline
+ [ 2dup ] dip call( x y -- z ) 3array ; inline
diff --git a/extra/math/matrices/elimination/authors.txt b/extra/math/matrices/elimination/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/extra/math/matrices/elimination/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/extra/math/numerical-integration/numerical-integration.factor b/extra/math/numerical-integration/numerical-integration.factor
index 6b46ba0243..261f33c4f3 100644
--- a/extra/math/numerical-integration/numerical-integration.factor
+++ b/extra/math/numerical-integration/numerical-integration.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel sequences namespaces make math math.ranges
-math.vectors vectors ;
+USING: kernel math math.ranges math.vectors namespaces
+sequences ;
IN: math.numerical-integration
SYMBOL: num-steps
@@ -15,7 +15,7 @@ SYMBOL: num-steps
length 2 / 2 - { 2 4 } <repetition> concat
{ 1 4 } { 1 } surround ;
-: integrate-simpson ( from to f -- x )
+: integrate-simpson ( from to quot -- x )
[ setup-simpson-range dup ] dip
map dup generate-simpson-weights
- v. swap [ third ] keep first - 6 / * ;
+ v. swap [ third ] keep first - 6 / * ; inline
diff --git a/extra/merger/deploy.factor b/extra/merger/deploy.factor
new file mode 100644
index 0000000000..54535d5bc8
--- /dev/null
+++ b/extra/merger/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-unicode? t }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-name "Merger" }
+ { deploy-word-props? f }
+ { deploy-threads? t }
+ { deploy-word-defs? f }
+}
diff --git a/extra/merger/merger.factor b/extra/merger/merger.factor
new file mode 100644
index 0000000000..c4986bf47f
--- /dev/null
+++ b/extra/merger/merger.factor
@@ -0,0 +1,30 @@
+USING: accessors arrays fry io.directories kernel models sequences sets ui
+ui.gadgets ui.gadgets.buttons ui.gadgets.labeled
+ui.gadgets.tracks ui.gadgets.labels ui.gadgets.glass
+math.rectangles cocoa.dialogs ;
+IN: merger
+: main ( -- ) [
+ vertical <track>
+ { "From:" "To:" } f <model> f <model> 2array
+ [
+ [
+ "…" [
+ open-panel [ first
+ [ <label> 1array >>children drop ]
+ [ swap set-control-value ] 2bi ] [ drop ] if*
+ ] <border-button> swap >>model swap <labeled-gadget>
+ 1 track-add
+ ] 2each
+ ] keep
+ dup first2
+ '[ _ [ value>> ] all? [ parent>> "processing..." <label> [
+ <zero-rect> show-glass
+ _ value>> [
+ "." _ value>> [ [ directory-files ] bi@ diff ] keep copy-files-into
+ ] with-directory
+ ] keep hide-glass
+ ] [ drop ] if ]
+ "merge" swap <border-button> 0.4 track-add { 300 220 } >>pref-dim "Merging" open-window
+] with-ui ;
+
+MAIN: main
\ No newline at end of file
diff --git a/extra/merger/tags.txt b/extra/merger/tags.txt
new file mode 100644
index 0000000000..c80b8b4fe1
--- /dev/null
+++ b/extra/merger/tags.txt
@@ -0,0 +1,2 @@
+unportable
+
diff --git a/basis/models/history/history-docs.factor b/extra/models/history/history-docs.factor
similarity index 100%
rename from basis/models/history/history-docs.factor
rename to extra/models/history/history-docs.factor
diff --git a/basis/models/history/history-tests.factor b/extra/models/history/history-tests.factor
similarity index 100%
rename from basis/models/history/history-tests.factor
rename to extra/models/history/history-tests.factor
diff --git a/basis/models/history/history.factor b/extra/models/history/history.factor
similarity index 100%
rename from basis/models/history/history.factor
rename to extra/models/history/history.factor
diff --git a/basis/models/history/summary.txt b/extra/models/history/summary.txt
similarity index 100%
rename from basis/models/history/summary.txt
rename to extra/models/history/summary.txt
diff --git a/extra/modules/remote-loading/authors.txt b/extra/modules/remote-loading/authors.txt
new file mode 100644
index 0000000000..2300f69f11
--- /dev/null
+++ b/extra/modules/remote-loading/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
diff --git a/extra/modules/remote-loading/remote-loading.factor b/extra/modules/remote-loading/remote-loading.factor
new file mode 100644
index 0000000000..7a51f2488d
--- /dev/null
+++ b/extra/modules/remote-loading/remote-loading.factor
@@ -0,0 +1,4 @@
+USING: modules.rpc-server vocabs ;
+IN: modules.remote-loading mem-service
+
+: get-vocab ( vocabstr -- vocab ) vocab ;
\ No newline at end of file
diff --git a/extra/modules/remote-loading/summary.txt b/extra/modules/remote-loading/summary.txt
new file mode 100644
index 0000000000..304f8550e4
--- /dev/null
+++ b/extra/modules/remote-loading/summary.txt
@@ -0,0 +1 @@
+required for listeners allowing remote loading of modules
\ No newline at end of file
diff --git a/extra/modules/rpc-server/authors.txt b/extra/modules/rpc-server/authors.txt
new file mode 100644
index 0000000000..2300f69f11
--- /dev/null
+++ b/extra/modules/rpc-server/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
diff --git a/extra/modules/rpc-server/rpc-server.factor b/extra/modules/rpc-server/rpc-server.factor
new file mode 100644
index 0000000000..525ff35a09
--- /dev/null
+++ b/extra/modules/rpc-server/rpc-server.factor
@@ -0,0 +1,37 @@
+USING: accessors assocs continuations effects io
+io.encodings.binary io.servers.connection kernel
+memoize namespaces parser sets sequences serialize
+threads vocabs vocabs.parser words ;
+
+IN: modules.rpc-server
+
+SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
+
+: do-rpc ( args word -- bytes )
+ [ execute ] curry with-datastack object>bytes ; inline
+
+MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
+
+: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
+ swap at "executer" get execute( args word -- bytes ) write flush ;
+
+: (serve) ( -- ) deserialize dup serving-vocabs get-global index
+ [ process ] [ drop ] if ;
+
+: start-serving-vocabs ( -- ) [
+ <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
+ start-server ] in-thread ;
+
+: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
+ current-vocab serving-vocabs get-global adjoin
+ "get-words" create-in
+ in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
+ (( -- words )) define-inline ;
+
+SYNTAX: service \ do-rpc "executer" set (service) ;
+SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
+
+load-vocab-hook [
+ [ dup words>> values
+ \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
+append ] change-global
\ No newline at end of file
diff --git a/extra/modules/rpc-server/summary.txt b/extra/modules/rpc-server/summary.txt
new file mode 100644
index 0000000000..396a1c8686
--- /dev/null
+++ b/extra/modules/rpc-server/summary.txt
@@ -0,0 +1 @@
+remote procedure call server
\ No newline at end of file
diff --git a/extra/modules/rpc/authors.txt b/extra/modules/rpc/authors.txt
new file mode 100644
index 0000000000..2300f69f11
--- /dev/null
+++ b/extra/modules/rpc/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
diff --git a/extra/modules/rpc/rpc-docs.factor b/extra/modules/rpc/rpc-docs.factor
new file mode 100644
index 0000000000..af99d210ab
--- /dev/null
+++ b/extra/modules/rpc/rpc-docs.factor
@@ -0,0 +1,9 @@
+USING: help.syntax help.markup ;
+IN: modules.rpc
+ARTICLE: { "modules" "protocol" } "RPC Protocol"
+{ $list
+ "Send vocab as string"
+ "Send arglist"
+ "Send word as string"
+ "Receive result list"
+} ;
\ No newline at end of file
diff --git a/extra/modules/rpc/rpc.factor b/extra/modules/rpc/rpc.factor
new file mode 100644
index 0000000000..1c1217a71e
--- /dev/null
+++ b/extra/modules/rpc/rpc.factor
@@ -0,0 +1,26 @@
+USING: accessors compiler.units combinators fry generalizations io
+io.encodings.binary io.sockets kernel namespaces
+parser sequences serialize vocabs vocabs.parser words ;
+IN: modules.rpc
+
+DEFER: get-words
+
+: remote-quot ( addrspec vocabspec effect str -- quot )
+ '[ _ 5000 <inet> binary
+ [
+ _ serialize _ in>> length narray serialize _ serialize flush deserialize dup length firstn
+ ] with-client
+ ] ;
+
+: define-remote ( addrspec vocabspec effect str -- ) [
+ [ remote-quot ] 2keep create-in -rot define-declared word make-inline
+ ] with-compilation-unit ;
+
+: with-in ( vocab quot -- vocab ) over
+ [ '[ _ set-in @ ] in get swap dip set-in ] dip vocab ; inline
+
+: remote-vocab ( addrspec vocabspec -- vocab )
+ dup "-remote" append [
+ [ (( -- words )) [ "get-words" remote-quot ] keep call-effect ] 2keep
+ [ rot first2 swap define-remote ] 2curry each
+ ] with-in ;
\ No newline at end of file
diff --git a/extra/modules/rpc/summary.txt b/extra/modules/rpc/summary.txt
new file mode 100644
index 0000000000..cc1501fa88
--- /dev/null
+++ b/extra/modules/rpc/summary.txt
@@ -0,0 +1 @@
+remote procedure call client
\ No newline at end of file
diff --git a/extra/modules/uploads/authors.txt b/extra/modules/uploads/authors.txt
new file mode 100644
index 0000000000..2300f69f11
--- /dev/null
+++ b/extra/modules/uploads/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
diff --git a/extra/modules/uploads/summary.txt b/extra/modules/uploads/summary.txt
new file mode 100644
index 0000000000..1ba8ffe0f8
--- /dev/null
+++ b/extra/modules/uploads/summary.txt
@@ -0,0 +1 @@
+module pushing in remote-loading listeners
\ No newline at end of file
diff --git a/extra/modules/uploads/uploads.factor b/extra/modules/uploads/uploads.factor
new file mode 100644
index 0000000000..137a2c91d5
--- /dev/null
+++ b/extra/modules/uploads/uploads.factor
@@ -0,0 +1,5 @@
+USING: assocs modules.rpc-server vocabs
+modules.remote-loading words ;
+IN: modules.uploads service
+
+: upload-vocab ( word binary -- ) \ get-vocab "memoize" word-prop set-at ;
\ No newline at end of file
diff --git a/extra/modules/using/authors.txt b/extra/modules/using/authors.txt
new file mode 100644
index 0000000000..2300f69f11
--- /dev/null
+++ b/extra/modules/using/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
diff --git a/extra/modules/using/summary.txt b/extra/modules/using/summary.txt
new file mode 100644
index 0000000000..6bafda776a
--- /dev/null
+++ b/extra/modules/using/summary.txt
@@ -0,0 +1 @@
+improved module import syntax
\ No newline at end of file
diff --git a/extra/modules/using/tests/tags.txt b/extra/modules/using/tests/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/modules/using/tests/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/extra/modules/using/tests/test-server.factor b/extra/modules/using/tests/test-server.factor
new file mode 100644
index 0000000000..3e6b736ae1
--- /dev/null
+++ b/extra/modules/using/tests/test-server.factor
@@ -0,0 +1,3 @@
+USING: modules.rpc-server io.servers.connection ;
+IN: modules.test-server service
+: rpc-hello ( -- str ) "hello world" stop-this-server ;
\ No newline at end of file
diff --git a/extra/modules/using/tests/tests.factor b/extra/modules/using/tests/tests.factor
new file mode 100644
index 0000000000..894075acf8
--- /dev/null
+++ b/extra/modules/using/tests/tests.factor
@@ -0,0 +1,4 @@
+USING: modules.using ;
+IN: modules.using.tests
+USING: tools.test localhost::modules.test-server ;
+[ "hello world" ] [ rpc-hello ] unit-test
\ No newline at end of file
diff --git a/extra/modules/using/using-docs.factor b/extra/modules/using/using-docs.factor
new file mode 100644
index 0000000000..c78e546525
--- /dev/null
+++ b/extra/modules/using/using-docs.factor
@@ -0,0 +1,14 @@
+USING: modules.using modules.rpc-server help.syntax help.markup strings ;
+IN: modules
+
+HELP: service
+{ $syntax "IN: module service" }
+{ $description "Starts a server for requests for remote procedure calls." } ;
+
+ARTICLE: { "modules" "remote-loading" } "Using the remote-loading vocabulary"
+"If loaded, starts serving vocabularies, accessable through a " { $link POSTPONE: USING: } " form" ;
+
+HELP: USING:
+{ $syntax "USING: rpc-server::module fetch-sever::module { module qualified-name } { module => word ... } ... ;" }
+{ $description "Adds vocabularies to the front of the search path. Vocabularies can be fetched remotely, if preceded by a valid hostname. Name pairs facilitate imports like in the "
+{ $link POSTPONE: QUALIFIED: } " or " { $link POSTPONE: FROM: } " forms." } ;
\ No newline at end of file
diff --git a/extra/modules/using/using.factor b/extra/modules/using/using.factor
new file mode 100644
index 0000000000..b0891aa391
--- /dev/null
+++ b/extra/modules/using/using.factor
@@ -0,0 +1,36 @@
+USING: assocs kernel modules.remote-loading modules.rpc
+namespaces peg peg.ebnf peg-lexer sequences vocabs vocabs.parser
+strings ;
+IN: modules.using
+
+: >qualified ( vocab prefix -- assoc )
+ [ vocab-words ] [ 58 suffix ] bi* [ swap [ prepend ] dip ] curry assoc-map ;
+
+: >partial-vocab ( words assoc -- assoc )
+ [ dupd at [ no-word-error ] unless* ] curry { } map>assoc ;
+
+: remote-load ( addr vocabspec -- voab ) [ "modules.remote-loading" remote-vocab (use+) ] dip get-vocab ;
+
+: load'em ( vocab words/? -- ) [ swap >partial-vocab ] when* use get push ;
+
+EBNF: modulize
+tokenpart = (!(':').)+ => [[ >string ]]
+s = ':' => [[ drop ignore ]]
+rpc = tokenpart s s tokenpart => [[ first2 remote-vocab ]]
+remote = tokenpart s tokenpart => [[ first2 remote-load ]]
+plain = tokenpart => [[ load-vocab ]]
+module = rpc | remote | plain
+;EBNF
+
+ON-BNF: USING:
+tokenizer = <foreign factor>
+sym = !(";"|"}"|"=>").
+modspec = sym => [[ modulize ]]
+qualified = modspec sym => [[ first2 >qualified ]]
+unqualified = modspec => [[ vocab-words ]]
+words = ("=>" sym+ )? => [[ [ f ] [ second ] if-empty ]]
+long = "{" ( qualified | unqualified ) words "}" => [[ rest first2 load'em ignore ]]
+short = modspec => [[ use+ ignore ]]
+wordSpec = long | short
+using = wordSpec+ ";" => [[ drop ignore ]]
+;ON-BNF
\ No newline at end of file
diff --git a/extra/mongodb/authors.txt b/extra/mongodb/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/benchmark/authors.txt b/extra/mongodb/benchmark/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/benchmark/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/benchmark/benchmark.factor b/extra/mongodb/benchmark/benchmark.factor
new file mode 100644
index 0000000000..02dfa8add9
--- /dev/null
+++ b/extra/mongodb/benchmark/benchmark.factor
@@ -0,0 +1,312 @@
+USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array
+sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary
+accessors words mongodb.driver strings math.parser tools.walker bson.writer
+tools.continuations ;
+
+IN: mongodb.benchmark
+
+SYMBOL: collection
+
+: get* ( symbol default -- value )
+ [ get ] dip or ; inline
+
+: ensure-number ( v -- n )
+ dup string? [ string>number ] when ; inline
+
+: trial-size ( -- size )
+ "per-trial" 5000 get* ensure-number ; inline flushable
+
+: batch-size ( -- size )
+ "batch-size" 100 get* ensure-number ; inline flushable
+
+TUPLE: result doc collection index batch lasterror ;
+
+: <result> ( -- ) result new result set ; inline
+
+
+CONSTANT: CHECK-KEY f
+
+CONSTANT: DOC-SMALL H{ }
+
+CONSTANT: DOC-MEDIUM H{ { "integer" 5 }
+ { "number" 5.05 }
+ { "boolean" f }
+ { "array"
+ { "test" "benchmark" } } }
+
+CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
+ { "total_word_count" 6743 }
+ { "access_time" f }
+ { "meta_tags" H{ { "description" "i am a long description string" }
+ { "author" "Holly Man" }
+ { "dynamically_created_meta_tag" "who know\n what" } } }
+ { "page_structure" H{ { "counted_tags" 3450 }
+ { "no_of_js_attached" 10 }
+ { "no_of_images" 6 } } }
+ { "harvested_words" { "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo"
+ "10gen" "web" "open" "source" "application" "paas"
+ "platform-as-a-service" "technology" "helps"
+ "developers" "focus" "building" "mongodb" "mongo" } } }
+
+: set-doc ( name -- )
+ [ result ] dip '[ _ >>doc ] change ; inline
+
+: small-doc ( -- quot )
+ "small" set-doc [ ] ; inline
+
+: medium-doc ( -- quot )
+ "medium" set-doc [ ] ; inline
+
+: large-doc ( -- quot )
+ "large" set-doc [ ] ; inline
+
+: small-doc-prepare ( -- quot: ( i -- doc ) )
+ small-doc drop
+ '[ "x" DOC-SMALL clone [ set-at ] keep ] ;
+
+: medium-doc-prepare ( -- quot: ( i -- doc ) )
+ medium-doc drop
+ '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ;
+
+: large-doc-prepare ( -- quot: ( i -- doc ) )
+ large-doc drop
+ [ "x" DOC-LARGE clone [ set-at ] keep
+ [ now "access-time" ] dip
+ [ set-at ] keep ] ;
+
+: (insert) ( quot: ( i -- doc ) collection -- )
+ [ trial-size ] 2dip
+ '[ _ call( i -- doc ) [ _ ] dip
+ result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ;
+
+: (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq )
+ [ [ * ] keep 1 range boa ] dip
+ '[ _ call( i -- doc ) ] map ;
+
+: (insert-batch) ( quot: ( i -- doc ) collection -- )
+ [ trial-size batch-size [ / ] keep ] 2dip
+ '[ _ _ (prepare-batch) [ _ ] dip
+ result get lasterror>> [ save ] [ save-unsafe ] if
+ ] each-integer ;
+
+: bchar ( boolean -- char )
+ [ "t" ] [ "f" ] if ; inline
+
+: collection-name ( -- collection )
+ collection "benchmark" get*
+ result get doc>>
+ result get index>> bchar
+ "%s-%s-%s" sprintf
+ [ [ result get ] dip >>collection drop ] keep ;
+
+: prepare-collection ( -- collection )
+ collection-name
+ [ "_x_idx" drop-index ] keep
+ [ drop-collection ] keep
+ [ create-collection ] keep ;
+
+: prepare-index ( collection -- )
+ "_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ;
+
+: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
+ prepare-collection
+ result get index>> [ [ prepare-index ] keep ] when
+ result get batch>>
+ [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ;
+
+: serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
+ '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ;
+
+: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
+ [ 0 ] dip call( i -- doc ) assoc>bv
+ '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ;
+
+: check-for-key ( assoc key -- )
+ CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ;
+
+: (check-find-result) ( result -- )
+ "x" check-for-key ; inline
+
+: (find) ( cursor -- )
+ [ find [ (check-find-result) ] each (find) ] when* ; inline recursive
+
+: find-one ( quot -- quot: ( -- ) )
+ drop
+ [ trial-size
+ collection-name
+ trial-size 2 / "x" H{ } clone [ set-at ] keep
+ '[ _ _ <query> 1 limit (find) ] times ] ;
+
+: find-all ( quot -- quot: ( -- ) )
+ drop
+ collection-name
+ H{ } clone
+ '[ _ _ <query> (find) ] ;
+
+: find-range ( quot -- quot: ( -- ) )
+ drop
+ [ trial-size batch-size /i
+ collection-name
+ trial-size 2 / "$gt" H{ } clone [ set-at ] keep
+ [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep
+ "x" H{ } clone [ set-at ] keep
+ '[ _ _ <query> (find) ] times ] ;
+
+: batch ( -- )
+ result [ t >>batch ] change ; inline
+
+: index ( -- )
+ result [ t >>index ] change ; inline
+
+: errcheck ( -- )
+ result [ t >>lasterror ] change ; inline
+
+: print-result ( time -- )
+ [ result get [ collection>> ] keep
+ [ batch>> bchar ] keep
+ [ index>> bchar ] keep
+ lasterror>> bchar
+ trial-size ] dip
+ 1000000 / /i
+ "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s"
+ sprintf print flush ;
+
+: print-separator ( -- )
+ "----------------------------------------------------------------" print flush ; inline
+
+: print-separator-bold ( -- )
+ "================================================================" print flush ; inline
+
+: print-header ( -- )
+ trial-size
+ batch-size
+ "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d"
+ sprintf print flush
+ print-separator-bold ;
+
+: with-result ( options quot -- )
+ '[ <result> _ call( options -- time ) print-result ] with-scope ;
+
+: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
+ '[ _ swap _
+ '[ [ [ _ execute( -- quot ) ] dip
+ [ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each
+ print-separator ] ;
+
+: run-serialization-bench ( doc-word-seq feat-seq -- )
+ "Serialization Tests" print
+ print-separator-bold
+ \ serialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-deserialization-bench ( doc-word-seq feat-seq -- )
+ "Deserialization Tests" print
+ print-separator-bold
+ \ deserialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-insert-bench ( doc-word-seq feat-seq -- )
+ "Insert Tests" print
+ print-separator-bold
+ \ insert [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-find-one-bench ( doc-word-seq feat-seq -- )
+ "Query Tests - Find-One" print
+ print-separator-bold
+ \ find-one [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-find-all-bench ( doc-word-seq feat-seq -- )
+ "Query Tests - Find-All" print
+ print-separator-bold
+ \ find-all [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+: run-find-range-bench ( doc-word-seq feat-seq -- )
+ "Query Tests - Find-Range" print
+ print-separator-bold
+ \ find-range [bench-quot] '[ _ call( doc-word -- ) ] each ;
+
+
+: run-benchmarks ( -- )
+ "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
+ [ print-header
+ ! serialization
+ { small-doc-prepare medium-doc-prepare
+ large-doc-prepare }
+ { { } } run-serialization-bench
+ ! deserialization
+ { small-doc-prepare medium-doc-prepare
+ large-doc-prepare }
+ { { } } run-deserialization-bench
+ ! insert
+ { small-doc-prepare medium-doc-prepare
+ large-doc-prepare }
+ { { } { index } { errcheck } { index errcheck }
+ { batch } { batch errcheck } { batch index errcheck }
+ } run-insert-bench
+ ! find-one
+ { small-doc medium-doc large-doc }
+ { { } { index } } run-find-one-bench
+ ! find-all
+ { small-doc medium-doc large-doc }
+ { { } { index } } run-find-all-bench
+ ! find-range
+ { small-doc medium-doc large-doc }
+ { { } { index } } run-find-range-bench
+ ] with-db ;
+
+MAIN: run-benchmarks
+
diff --git a/extra/mongodb/benchmark/summary.txt b/extra/mongodb/benchmark/summary.txt
new file mode 100644
index 0000000000..5d0e4f5e1c
--- /dev/null
+++ b/extra/mongodb/benchmark/summary.txt
@@ -0,0 +1 @@
+serialization/deserialization and insert/query benchmarks for mongodb.driver
diff --git a/extra/mongodb/connection/authors.txt b/extra/mongodb/connection/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/connection/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/connection/connection.factor b/extra/mongodb/connection/connection.factor
new file mode 100644
index 0000000000..7477ee5486
--- /dev/null
+++ b/extra/mongodb/connection/connection.factor
@@ -0,0 +1,146 @@
+USING: accessors assocs fry io.encodings.binary io.sockets kernel math
+math.parser mongodb.msg mongodb.operations namespaces destructors
+constructors sequences splitting checksums checksums.md5 formatting
+io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
+arrays hashtables sequences.deep vectors locals ;
+
+IN: mongodb.connection
+
+: md5-checksum ( string -- digest )
+ utf8 encode md5 checksum-bytes hex-string ; inline
+
+TUPLE: mdb-db name username pwd-digest nodes collections ;
+
+TUPLE: mdb-node master? { address inet } remote ;
+
+CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
+
+TUPLE: mdb-connection instance node handle remote local ;
+
+CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
+
+: check-ok ( result -- errmsg ? )
+ [ [ "errmsg" ] dip at ]
+ [ [ "ok" ] dip at >integer 1 = ] bi ; inline
+
+: <mdb-db> ( name nodes -- mdb-db )
+ mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
+
+: master-node ( mdb -- node )
+ nodes>> t swap at ;
+
+: slave-node ( mdb -- node )
+ nodes>> f swap at ;
+
+: with-connection ( connection quot -- * )
+ [ mdb-connection set ] prepose with-scope ; inline
+
+: mdb-instance ( -- mdb )
+ mdb-connection get instance>> ; inline
+
+: index-collection ( -- ns )
+ mdb-instance name>> "%s.system.indexes" sprintf ; inline
+
+: namespaces-collection ( -- ns )
+ mdb-instance name>> "%s.system.namespaces" sprintf ; inline
+
+: cmd-collection ( -- ns )
+ mdb-instance name>> "%s.$cmd" sprintf ; inline
+
+: index-ns ( colname -- index-ns )
+ [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
+
+: send-message ( message -- )
+ [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
+
+: send-query-plain ( query-message -- result )
+ [ mdb-connection get handle>> ] dip
+ '[ _ write-message read-message ] with-stream* ;
+
+: send-query-1result ( collection assoc -- result )
+ <mdb-query-msg>
+ 1 >>return#
+ send-query-plain objects>>
+ [ f ] [ first ] if-empty ;
+
+<PRIVATE
+
+: get-nonce ( -- nonce )
+ cmd-collection H{ { "getnonce" 1 } } send-query-1result
+ [ "nonce" swap at ] [ f ] if* ;
+
+: auth? ( mdb -- ? )
+ [ username>> ] [ pwd-digest>> ] bi and ;
+
+: calculate-key-digest ( nonce -- digest )
+ mdb-instance
+ [ username>> ]
+ [ pwd-digest>> ] bi
+ 3array concat md5-checksum ; inline
+
+: build-auth-query ( -- query-assoc )
+ { "authenticate" 1 }
+ "user" mdb-instance username>> 2array
+ "nonce" get-nonce 2array
+ 3array >hashtable
+ [ [ "nonce" ] dip at calculate-key-digest "key" ] keep
+ [ set-at ] keep ;
+
+: perform-authentication ( -- )
+ cmd-collection build-auth-query send-query-1result
+ check-ok [ drop ] [ throw ] if ; inline
+
+: authenticate-connection ( mdb-connection -- )
+ [ mdb-connection get instance>> auth?
+ [ perform-authentication ] when
+ ] with-connection ; inline
+
+: open-connection ( mdb-connection node -- mdb-connection )
+ [ >>node ] [ address>> ] bi
+ [ >>remote ] keep binary <client>
+ [ >>handle ] dip >>local ;
+
+: get-ismaster ( -- result )
+ "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
+
+: split-host-str ( hoststr -- host port )
+ ":" split [ first ] [ second string>number ] bi ; inline
+
+: eval-ismaster-result ( node result -- )
+ [ [ "ismaster" ] dip at >integer 1 = >>master? drop ]
+ [ [ "remote" ] dip at
+ [ split-host-str <inet> f <mdb-node> >>remote ] when*
+ drop ] 2bi ;
+
+: check-node ( mdb node -- )
+ [ <mdb-connection> &dispose ] dip
+ [ open-connection ] keep swap
+ [ get-ismaster eval-ismaster-result ] with-connection ;
+
+: nodelist>table ( seq -- assoc )
+ [ [ master?>> ] keep 2array ] map >hashtable ;
+
+PRIVATE>
+
+:: verify-nodes ( mdb -- )
+ [ [let* | acc [ V{ } clone ]
+ node1 [ mdb dup master-node [ check-node ] keep ]
+ node2 [ mdb node1 remote>>
+ [ [ check-node ] keep ]
+ [ drop f ] if* ]
+ | node1 [ acc push ] when*
+ node2 [ acc push ] when*
+ mdb acc nodelist>table >>nodes drop
+ ]
+ ] with-destructors ;
+
+: mdb-open ( mdb -- mdb-connection )
+ clone [ <mdb-connection> ] keep
+ master-node open-connection
+ [ authenticate-connection ] keep ;
+
+: mdb-close ( mdb-connection -- )
+ [ dispose f ] change-handle drop ;
+
+M: mdb-connection dispose
+ mdb-close ;
\ No newline at end of file
diff --git a/extra/mongodb/connection/summary.txt b/extra/mongodb/connection/summary.txt
new file mode 100644
index 0000000000..44cfb3f0ec
--- /dev/null
+++ b/extra/mongodb/connection/summary.txt
@@ -0,0 +1 @@
+low-level connection handling for mongodb.driver
diff --git a/extra/mongodb/driver/authors.txt b/extra/mongodb/driver/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/driver/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/driver/driver-docs.factor b/extra/mongodb/driver/driver-docs.factor
new file mode 100644
index 0000000000..7dbf564df9
--- /dev/null
+++ b/extra/mongodb/driver/driver-docs.factor
@@ -0,0 +1,283 @@
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax kernel quotations ;
+IN: mongodb.driver
+
+HELP: <mdb-collection>
+{ $values
+ { "name" "name of the collection" }
+ { "collection" "mdb-collection instance" }
+}
+{ $examples { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" <mdb-collection> t >>capped 1000000 >>max" "" } }
+{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections." } ;
+
+HELP: <mdb>
+{ $values
+ { "db" "name of the database to use" }
+ { "host" "host name or IP address" }
+ { "port" "port number" }
+ { "mdb" "mdb-db instance" }
+}
+{ $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;" "\"db\" \"127.0.0.1\" 27017 <mdb>" "" } } ;
+
+HELP: <query>
+{ $values
+ { "collection" "collection to query" }
+ { "assoc" "query assoc" }
+ { "mdb-query-msg" "mdb-query-msg instance" }
+}
+{ $description "Creates a new mdb-query-msg instance. "
+ "This word must be called from within a with-db scope."
+ "For more see: "
+ { $link with-db } }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" H{ } <query>" "" } } ;
+
+HELP: <update>
+{ $values
+ { "collection" "collection to update" }
+ { "selector" "selector assoc (selects which object(s) to update" }
+ { "object" "updated object or update instruction" }
+ { "mdb-update-msg" "mdb-update-msg instance" }
+}
+{ $description "Creates an update message for the object(s) identified by the given selector."
+ "MongoDB supports full object updates as well as partial update modifiers such as $set, $inc or $push"
+ "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Updates" } } ;
+
+HELP: >upsert
+{ $values
+ { "mdb-update-msg" "a mdb-update-msg" }
+ { "mdb-update-msg" "mdb-update-msg with the upsert indicator set to t" }
+}
+{ $description "Marks a mdb-update-msg as upsert operation"
+ "(inserts object identified by the update selector if it doesn't exist in the collection)" } ;
+
+HELP: PARTIAL?
+{ $values
+ { "value" "partial?" }
+}
+{ $description "key which refers to a partially loaded object" } ;
+
+HELP: asc
+{ $values
+ { "key" "sort key" }
+ { "spec" "sort spec" }
+}
+{ $description "indicates that the values of the specified key should be sorted in ascending order" } ;
+
+HELP: count
+{ $values
+ { "mdb-query-msg" "query" }
+ { "result" "number of objects in the collection that match the query" }
+}
+{ $description "count objects in a collection" } ;
+
+HELP: create-collection
+{ $values
+ { "name" "collection name" }
+}
+{ $description "Creates a new collection with the given name." } ;
+
+HELP: delete
+{ $values
+ { "collection" "a collection" }
+ { "selector" "assoc which identifies the objects to be removed from the collection" }
+}
+{ $description "removes objects from the collection (with lasterror check)" } ;
+
+HELP: delete-unsafe
+{ $values
+ { "collection" "a collection" }
+ { "selector" "assoc which identifies the objects to be removed from the collection" }
+}
+{ $description "removes objects from the collection (without error check)" } ;
+
+HELP: desc
+{ $values
+ { "key" "sort key" }
+ { "spec" "sort spec" }
+}
+{ $description "indicates that the values of the specified key should be sorted in descending order" } ;
+
+HELP: drop-collection
+{ $values
+ { "name" "a collection" }
+}
+{ $description "removes the collection and all objects in it from the database" } ;
+
+HELP: drop-index
+{ $values
+ { "collection" "a collection" }
+ { "name" "an index name" }
+}
+{ $description "drops the specified index from the collection" } ;
+
+HELP: ensure-collection
+{ $values
+ { "name" "a collection; e.g. mycollection " }
+}
+{ $description "ensures that the collection exists in the database" } ;
+
+HELP: ensure-index
+{ $values
+ { "index-spec" "an index specification" }
+}
+{ $description "Ensures the existence of the given index. "
+ "For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index ] with-db" "" } } ;
+
+HELP: explain.
+{ $values
+ { "mdb-query-msg" "a query message" }
+}
+{ $description "Prints the execution plan for the given query" } ;
+
+HELP: find
+{ $values
+ { "selector" "a mdb-query or mdb-cursor" }
+ { "mdb-cursor/f" "a cursor (if there are more results) or f" }
+ { "seq" "a sequences of objects" }
+}
+{ $description "executes the given query" }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" H{ { \"name\" \"Alfred\" } } <query> find ] with-db" "" } } ;
+
+HELP: find-one
+{ $values
+ { "mdb-query-msg" "a query" }
+ { "result/f" "a single object or f" }
+}
+{ $description "Executes the query and returns one object at most" } ;
+
+HELP: hint
+{ $values
+ { "mdb-query-msg" "a query" }
+ { "index-hint" "a hint to an index" }
+ { "mdb-query-msg" "modified query object" }
+}
+{ $description "Annotates the query with a hint to an index. "
+ "For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } <query> H{ { \"name\" 1 } } hint find ] with-db" "" } } ;
+
+HELP: lasterror
+{ $values
+
+ { "error" "error message or f" }
+}
+{ $description "Checks if the last operation resulted in an error on the MongoDB side"
+ "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Mongo+Commands#MongoCommands-LastErrorCommands" } } ;
+
+HELP: limit
+{ $values
+ { "mdb-query-msg" "a query" }
+ { "limit#" "number of objects that should be returned at most" }
+ { "mdb-query-msg" "modified query object" }
+}
+{ $description "Limits the number of returned objects to limit#" }
+{ $examples
+ { $unchecked-example "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" H{ } <query> 10 limit find ] with-db" "" } } ;
+
+HELP: load-collection-list
+{ $values
+
+ { "collection-list" "list of collections in the current database" }
+}
+{ $description "Returns a list of all collections that exist in the current database" } ;
+
+HELP: load-index-list
+{ $values
+
+ { "index-list" "list of indexes" }
+}
+{ $description "Returns a list of all indexes that exist in the current database" } ;
+
+HELP: mdb-collection
+{ $var-description "MongoDB collection" } ;
+
+HELP: mdb-cursor
+{ $var-description "MongoDB cursor" } ;
+
+HELP: mdb-error
+{ $values
+ { "msg" "error message" }
+}
+{ $description "error class" } ;
+
+HELP: r/
+{ $values
+ { "token" "a regexp string" }
+ { "mdbregexp" "a mdbregexp tuple instance" }
+}
+{ $description "creates a new mdbregexp instance" } ;
+
+HELP: save
+{ $values
+ { "collection" "a collection" }
+ { "assoc" "object" }
+}
+{ $description "Saves the object to the given collection."
+ " If the object contains a field name \"_id\" this command automatically performs an update (with upsert) instead of a plain save" } ;
+
+HELP: save-unsafe
+{ $values
+ { "collection" "a collection" }
+ { "assoc" "object" }
+}
+{ $description "Save the object to the given collection without automatic error check" } ;
+
+HELP: skip
+{ $values
+ { "mdb-query-msg" "a query message" }
+ { "skip#" "number of objects to skip" }
+ { "mdb-query-msg" "annotated query message" }
+}
+{ $description "annotates a query message with a number of objects to skip when returning the results" } ;
+
+HELP: sort
+{ $values
+ { "mdb-query-msg" "a query message" }
+ { "sort-quot" "a quotation with sort specifiers" }
+ { "mdb-query-msg" "annotated query message" }
+}
+{ $description "annotates the query message for sort specifiers" } ;
+
+HELP: update
+{ $values
+ { "mdb-update-msg" "a mdb-update message" }
+}
+{ $description "performs an update" } ;
+
+HELP: update-unsafe
+{ $values
+ { "mdb-update-msg" "a mdb-update message" }
+}
+{ $description "performs an update without automatic error check" } ;
+
+HELP: validate.
+{ $values
+ { "collection" "collection to validate" }
+}
+{ $description "validates the collection" } ;
+
+HELP: with-db
+{ $values
+ { "mdb" "mdb instance" }
+ { "quot" "quotation to execute with the given mdb instance as context" }
+}
+{ $description "executes a quotation with the given mdb instance in its context" } ;
+
+
diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor
new file mode 100644
index 0000000000..967d4f11c5
--- /dev/null
+++ b/extra/mongodb/driver/driver.factor
@@ -0,0 +1,305 @@
+USING: accessors assocs bson.constants bson.writer combinators combinators.smart
+constructors continuations destructors formatting fry io io.pools
+io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables
+namespaces parser prettyprint sequences sets splitting strings uuid arrays
+math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ;
+
+IN: mongodb.driver
+
+TUPLE: mdb-pool < pool mdb ;
+
+TUPLE: mdb-cursor id query ;
+
+TUPLE: mdb-collection
+{ name string }
+{ capped boolean initial: f }
+{ size integer initial: -1 }
+{ max integer initial: -1 } ;
+
+CONSTRUCTOR: mdb-collection ( name -- collection ) ;
+
+TUPLE: index-spec
+{ ns string } { name string } { key hashtable } { unique? boolean initial: f } ;
+
+CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
+
+: unique-index ( index-spec -- index-spec )
+ t >>unique? ;
+
+M: mdb-pool make-connection
+ mdb>> mdb-open ;
+
+: <mdb-pool> ( mdb -- pool ) [ mdb-pool <pool> ] dip >>mdb ; inline
+
+CONSTANT: PARTIAL? "partial?"
+
+ERROR: mdb-error msg ;
+
+: >pwd-digest ( user password -- digest )
+ "mongo" swap 3array ":" join md5-checksum ;
+
+<PRIVATE
+
+GENERIC: <mdb-cursor> ( id mdb-query-msg/mdb-getmore-msg -- mdb-cursor )
+
+M: mdb-query-msg <mdb-cursor>
+ mdb-cursor boa ;
+
+M: mdb-getmore-msg <mdb-cursor>
+ query>> mdb-cursor boa ;
+
+: >mdbregexp ( value -- regexp )
+ first <mdbregexp> ; inline
+
+GENERIC: update-query ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- )
+
+M: mdb-query-msg update-query
+ swap [ start#>> ] [ returned#>> ] bi + >>skip# drop ;
+
+M: mdb-getmore-msg update-query
+ query>> update-query ;
+
+: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
+ over cursor>> 0 >
+ [ [ update-query ]
+ [ [ cursor>> ] dip <mdb-cursor> ] 2bi
+ ] [ 2drop f ] if ;
+
+DEFER: send-query
+
+GENERIC: verify-query-result ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-result-msg mdb-query-msg/mdb-getmore-msg )
+
+M: mdb-query-msg verify-query-result ;
+
+M: mdb-getmore-msg verify-query-result
+ over flags>> ResultFlag_CursorNotFound =
+ [ nip query>> [ send-query-plain ] keep ] when ;
+
+: send-query ( mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f seq )
+ [ send-query-plain ] keep
+ verify-query-result
+ [ collection>> >>collection drop ]
+ [ return#>> >>requested# ]
+ [ make-cursor ] 2tri
+ swap objects>> ;
+
+PRIVATE>
+
+SYNTAX: r/ ( token -- mdbregexp )
+ \ / [ >mdbregexp ] parse-literal ;
+
+: with-db ( mdb quot -- * )
+ '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
+
+: >id-selector ( assoc -- selector )
+ [ MDB_OID_FIELD swap at ] keep
+ H{ } clone [ set-at ] keep ;
+
+: <mdb> ( db host port -- mdb )
+ <inet> t [ <mdb-node> ] keep
+ H{ } clone [ set-at ] keep <mdb-db>
+ [ verify-nodes ] keep ;
+
+GENERIC: create-collection ( name -- )
+
+M: string create-collection
+ <mdb-collection> create-collection ;
+
+M: mdb-collection create-collection
+ [ cmd-collection ] dip
+ <linked-hash> [
+ [ [ name>> "create" ] dip set-at ]
+ [ [ [ capped>> ] keep ] dip
+ '[ _ _
+ [ [ drop t "capped" ] dip set-at ]
+ [ [ size>> "size" ] dip set-at ]
+ [ [ max>> "max" ] dip set-at ] 2tri ] when
+ ] 2bi
+ ] keep <mdb-query-msg> 1 >>return# send-query-plain drop ;
+
+: load-collection-list ( -- collection-list )
+ namespaces-collection
+ H{ } clone <mdb-query-msg> send-query-plain objects>> ;
+
+<PRIVATE
+
+: ensure-valid-collection-name ( collection -- )
+ [ ";$." intersect length 0 > ] keep
+ '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
+
+: (ensure-collection) ( collection -- )
+ mdb-instance collections>> dup keys length 0 =
+ [ load-collection-list
+ [ [ "options" ] dip key? ] filter
+ [ [ "name" ] dip at "." split second <mdb-collection> ] map
+ over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if
+ [ dup ] dip key? [ drop ]
+ [ [ ensure-valid-collection-name ] keep create-collection ] if ;
+
+: reserved-namespace? ( name -- ? )
+ [ "$cmd" = ] [ "system" head? ] bi or ;
+
+: check-collection ( collection -- fq-collection )
+ dup mdb-collection? [ name>> ] when
+ "." split1 over mdb-instance name>> =
+ [ nip ] [ drop ] if
+ [ ] [ reserved-namespace? ] bi
+ [ [ (ensure-collection) ] keep ] unless
+ [ mdb-instance name>> ] dip "%s.%s" sprintf ;
+
+: fix-query-collection ( mdb-query -- mdb-query )
+ [ check-collection ] change-collection ; inline
+
+GENERIC: get-more ( mdb-cursor -- mdb-cursor seq )
+
+M: mdb-cursor get-more
+ [ [ query>> dup [ collection>> ] [ return#>> ] bi ]
+ [ id>> ] bi <mdb-getmore-msg> swap >>query send-query ]
+ [ f f ] if* ;
+
+PRIVATE>
+
+: <query> ( collection assoc -- mdb-query-msg )
+ <mdb-query-msg> ; inline
+
+GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg )
+
+M: mdb-query-msg limit
+ >>return# ; inline
+
+GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg )
+
+M: mdb-query-msg skip
+ >>skip# ; inline
+
+: asc ( key -- spec ) 1 2array ; inline
+: desc ( key -- spec ) -1 2array ; inline
+
+GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg )
+
+M: mdb-query-msg sort
+ output>array [ 1array >hashtable ] map >>orderby ; inline
+
+: key-spec ( spec-quot -- spec-assoc )
+ output>array >hashtable ; inline
+
+GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg )
+
+M: mdb-query-msg hint
+ >>hint ;
+
+GENERIC: find ( selector -- mdb-cursor/f seq )
+
+M: mdb-query-msg find
+ fix-query-collection send-query ;
+
+M: mdb-cursor find
+ get-more ;
+
+GENERIC: explain. ( mdb-query-msg -- )
+
+M: mdb-query-msg explain.
+ t >>explain find nip . ;
+
+GENERIC: find-one ( mdb-query-msg -- result/f )
+
+M: mdb-query-msg find-one
+ fix-query-collection
+ 1 >>return# send-query-plain objects>>
+ dup empty? [ drop f ] [ first ] if ;
+
+GENERIC: count ( mdb-query-msg -- result )
+
+M: mdb-query-msg count
+ [ collection>> "count" H{ } clone [ set-at ] keep ] keep
+ query>> [ over [ "query" ] dip set-at ] when*
+ [ cmd-collection ] dip <mdb-query-msg> find-one
+ [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
+
+: lasterror ( -- error )
+ cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
+ find-one [ "err" ] dip at ;
+
+GENERIC: validate. ( collection -- )
+
+M: string validate.
+ [ cmd-collection ] dip
+ "validate" H{ } clone [ set-at ] keep
+ <mdb-query-msg> find-one [ check-ok nip ] keep
+ '[ "result" _ at print ] [ ] if ;
+
+M: mdb-collection validate.
+ name>> validate. ;
+
+<PRIVATE
+
+: send-message-check-error ( message -- )
+ send-message lasterror [ mdb-error ] when* ;
+
+PRIVATE>
+
+GENERIC: save ( collection assoc -- )
+M: assoc save
+ [ check-collection ] dip
+ <mdb-insert-msg> send-message-check-error ;
+
+GENERIC: save-unsafe ( collection assoc -- )
+M: assoc save-unsafe
+ [ check-collection ] dip
+ <mdb-insert-msg> send-message ;
+
+GENERIC: ensure-index ( index-spec -- )
+M: index-spec ensure-index
+ <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
+ [ { [ [ name>> "name" ] dip set-at ]
+ [ [ ns>> index-ns "ns" ] dip set-at ]
+ [ [ key>> "key" ] dip set-at ]
+ [ swap unique?>>
+ [ swap [ "unique" ] dip set-at ] [ drop ] if* ] } 2cleave
+ ] keep
+ [ index-collection ] dip save ;
+
+: drop-index ( collection name -- )
+ H{ } clone
+ [ [ "index" ] dip set-at ] keep
+ [ [ "deleteIndexes" ] dip set-at ] keep
+ [ cmd-collection ] dip <mdb-query-msg>
+ find-one drop ;
+
+: <update> ( collection selector object -- mdb-update-msg )
+ [ check-collection ] 2dip <mdb-update-msg> ;
+
+: >upsert ( mdb-update-msg -- mdb-update-msg )
+ 1 >>upsert? ;
+
+GENERIC: update ( mdb-update-msg -- )
+M: mdb-update-msg update
+ send-message-check-error ;
+
+GENERIC: update-unsafe ( mdb-update-msg -- )
+M: mdb-update-msg update-unsafe
+ send-message ;
+
+GENERIC: delete ( collection selector -- )
+M: assoc delete
+ [ check-collection ] dip
+ <mdb-delete-msg> send-message-check-error ;
+
+GENERIC: delete-unsafe ( collection selector -- )
+M: assoc delete-unsafe
+ [ check-collection ] dip
+ <mdb-delete-msg> send-message ;
+
+: load-index-list ( -- index-list )
+ index-collection
+ H{ } clone <mdb-query-msg> find nip ;
+
+: ensure-collection ( name -- )
+ check-collection drop ;
+
+: drop-collection ( name -- )
+ [ cmd-collection ] dip
+ "drop" H{ } clone [ set-at ] keep
+ <mdb-query-msg> find-one drop ;
+
+
diff --git a/extra/mongodb/driver/summary.txt b/extra/mongodb/driver/summary.txt
new file mode 100644
index 0000000000..2ac1f95c9c
--- /dev/null
+++ b/extra/mongodb/driver/summary.txt
@@ -0,0 +1 @@
+A driver for the MongoDB document-oriented database (http://www.mongodb.org)
diff --git a/extra/mongodb/driver/tags.txt b/extra/mongodb/driver/tags.txt
new file mode 100644
index 0000000000..aa0d57e895
--- /dev/null
+++ b/extra/mongodb/driver/tags.txt
@@ -0,0 +1 @@
+database
diff --git a/extra/mongodb/mmm/authors.txt b/extra/mongodb/mmm/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/mmm/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/mmm/mmm.factor b/extra/mongodb/mmm/mmm.factor
new file mode 100644
index 0000000000..25c4c88203
--- /dev/null
+++ b/extra/mongodb/mmm/mmm.factor
@@ -0,0 +1,102 @@
+USING: accessors fry io io.encodings.binary io.servers.connection
+io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting
+namespaces prettyprint tools.walker calendar calendar.format bson.writer.private
+json.writer mongodb.operations.private mongodb.operations ;
+
+IN: mongodb.mmm
+
+SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ;
+
+GENERIC: dump-message ( message -- )
+
+: check-options ( -- )
+ mmm-port get [ 27040 mmm-port set ] unless
+ mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless
+ mmm-server-port get [ 27017 mmm-server-port set ] unless
+ mmm-server-ip get mmm-server-port get <inet> mmm-server set ;
+
+: read-msg-binary ( -- )
+ read-int32
+ [ write-int32 ] keep
+ 4 - read write ;
+
+: read-request-header ( -- msg-stub )
+ mdb-msg new
+ read-int32 MSG-HEADER-SIZE - >>length
+ read-int32 >>req-id
+ read-int32 >>resp-id
+ read-int32 >>opcode ;
+
+: read-request ( -- msg-stub binary )
+ binary [ read-msg-binary ] with-byte-writer
+ [ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary
+
+: dump-request ( msg-stub binary -- )
+ [ mmm-dump-output get ] 2dip
+ '[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
+
+: read-reply ( -- binary )
+ binary [ read-msg-binary ] with-byte-writer ;
+
+: forward-request-read-reply ( msg-stub binary -- binary )
+ [ mmm-server get binary ] 2dip
+ '[ _ opcode>> _ write flush
+ OP_Query =
+ [ read-reply ]
+ [ f ] if ] with-client ;
+
+: dump-reply ( binary -- )
+ [ mmm-dump-output get ] dip
+ '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
+
+: message-prefix ( message -- prefix message )
+ [ now timestamp>http-string ] dip
+ [ class name>> ] keep
+ [ "%s: %s" sprintf ] dip ; inline
+
+M: mdb-query-msg dump-message ( message -- )
+ message-prefix
+ [ collection>> ] keep
+ query>> >json
+ "%s -> %s: %s \n" printf ;
+
+M: mdb-insert-msg dump-message ( message -- )
+ message-prefix
+ [ collection>> ] keep
+ objects>> >json
+ "%s -> %s : %s \n" printf ;
+
+M: mdb-reply-msg dump-message ( message -- )
+ message-prefix
+ [ cursor>> ] keep
+ [ start#>> ] keep
+ [ returned#>> ] keep
+ objects>> >json
+ "%s -> cursor: %d, start: %d, returned#: %d, -> %s \n" printf ;
+
+M: mdb-msg dump-message ( message -- )
+ message-prefix drop "%s \n" printf ;
+
+: forward-reply ( binary -- )
+ write flush ;
+
+: handle-mmm-connection ( -- )
+ read-request
+ [ dump-request ] 2keep
+ forward-request-read-reply
+ [ dump-reply ] keep
+ forward-reply ;
+
+: start-mmm-server ( -- )
+ output-stream get mmm-dump-output set
+ <threaded-server> [ mmm-t-srv set ] keep
+ "127.0.0.1" mmm-port get <inet4> >>insecure
+ binary >>encoding
+ [ handle-mmm-connection ] >>handler
+ start-server* ;
+
+: run-mmm ( -- )
+ check-options
+ start-mmm-server ;
+
+MAIN: run-mmm
\ No newline at end of file
diff --git a/extra/mongodb/mmm/summary.txt b/extra/mongodb/mmm/summary.txt
new file mode 100644
index 0000000000..0670873053
--- /dev/null
+++ b/extra/mongodb/mmm/summary.txt
@@ -0,0 +1 @@
+mongo-message-monitor - a small proxy to introspect messages send to MongoDB
diff --git a/extra/mongodb/mongodb-docs.factor b/extra/mongodb/mongodb-docs.factor
new file mode 100644
index 0000000000..afdb2777fd
--- /dev/null
+++ b/extra/mongodb/mongodb-docs.factor
@@ -0,0 +1,27 @@
+USING: assocs help.markup help.syntax kernel quotations ;
+IN: mongodb
+
+ARTICLE: "mongodb" "MongoDB factor integration"
+"The " { $vocab-link "mongodb" } " vocabulary provides two different interfaces to the MongoDB document-oriented database"
+{ $heading "Low-level driver" }
+"The " { $vocab-link "mongodb.driver" } " vocabulary provides a low-level interface to MongoDB."
+{ $unchecked-example
+ "USING: mongodb.driver ;"
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "[ \"mycollection\" [ H{ { \"name\" \"Alfred\" } { \"age\" 57 } } save ] "
+ " [ ageIdx [ \"age\" asc ] key-spec <index-spec> ensure-index ]"
+ " [ H{ { \"age\" H{ { \"$gt\" 50 } } } } <query> find-one ] tri ] with-db "
+ "" }
+{ $heading "Highlevel tuple integration" }
+"The " { $vocab-link "mongodb.tuple" } " vocabulary lets you define persistent tuples that can be stored to and retrieved from a MongoDB database"
+{ $unchecked-example
+ "USING: mongodb.driver mongodb.tuple fry literals ;"
+ "MDBTUPLE: person name age ; "
+ "person \"persons\" { } { $[ \"ageIdx\" [ \"age\" asc ] key-spec <tuple-index> ] } define-persistent "
+ "\"db\" \"127.0.0.1\" 27017 <mdb>"
+ "person new \"Alfred\" >>name 57 >>age"
+ "'[ _ save-tuple person new 57 >>age select-tuple ] with-db"
+ "" }
+;
+
+ABOUT: "mongodb"
\ No newline at end of file
diff --git a/extra/mongodb/mongodb.factor b/extra/mongodb/mongodb.factor
new file mode 100644
index 0000000000..c5417cc3ac
--- /dev/null
+++ b/extra/mongodb/mongodb.factor
@@ -0,0 +1,8 @@
+USING: vocabs.loader ;
+
+IN: mongodb
+
+"mongodb.connection" require
+"mongodb.driver" require
+"mongodb.tuple" require
+
diff --git a/extra/mongodb/msg/authors.txt b/extra/mongodb/msg/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/msg/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/msg/msg.factor b/extra/mongodb/msg/msg.factor
new file mode 100644
index 0000000000..dd8bae8438
--- /dev/null
+++ b/extra/mongodb/msg/msg.factor
@@ -0,0 +1,105 @@
+USING: accessors assocs hashtables constructors kernel linked-assocs math
+sequences strings ;
+
+IN: mongodb.msg
+
+CONSTANT: OP_Reply 1
+CONSTANT: OP_Message 1000
+CONSTANT: OP_Update 2001
+CONSTANT: OP_Insert 2002
+CONSTANT: OP_Query 2004
+CONSTANT: OP_GetMore 2005
+CONSTANT: OP_Delete 2006
+CONSTANT: OP_KillCursors 2007
+
+CONSTANT: ResultFlag_CursorNotFound 1 ! /* returned, with zero results, when getMore is called but the cursor id is not valid at the server. */
+CONSTANT: ResultFlag_ErrSet 2 ! /* { $err : ... } is being returned */
+CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */
+
+TUPLE: mdb-msg
+{ opcode integer }
+{ req-id integer initial: 0 }
+{ resp-id integer initial: 0 }
+{ length integer initial: 0 }
+{ flags integer initial: 0 } ;
+
+TUPLE: mdb-query-msg < mdb-msg
+{ collection string }
+{ skip# integer initial: 0 }
+{ return# integer initial: 0 }
+{ query assoc }
+{ returnfields assoc }
+{ orderby sequence }
+explain hint ;
+
+TUPLE: mdb-insert-msg < mdb-msg
+{ collection string }
+{ objects sequence } ;
+
+TUPLE: mdb-update-msg < mdb-msg
+{ collection string }
+{ upsert? integer initial: 0 }
+{ selector assoc }
+{ object assoc } ;
+
+TUPLE: mdb-delete-msg < mdb-msg
+{ collection string }
+{ selector assoc } ;
+
+TUPLE: mdb-getmore-msg < mdb-msg
+{ collection string }
+{ return# integer initial: 0 }
+{ cursor integer initial: 0 }
+{ query mdb-query-msg } ;
+
+TUPLE: mdb-killcursors-msg < mdb-msg
+{ cursors# integer initial: 0 }
+{ cursors sequence } ;
+
+TUPLE: mdb-reply-msg < mdb-msg
+{ collection string }
+{ cursor integer initial: 0 }
+{ start# integer initial: 0 }
+{ requested# integer initial: 0 }
+{ returned# integer initial: 0 }
+{ objects sequence } ;
+
+
+CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )
+ OP_GetMore >>opcode ; inline
+
+CONSTRUCTOR: mdb-delete-msg ( collection selector -- mdb-delete-msg )
+ OP_Delete >>opcode ; inline
+
+CONSTRUCTOR: mdb-query-msg ( collection query -- mdb-query-msg )
+ OP_Query >>opcode ; inline
+
+GENERIC: <mdb-killcursors-msg> ( object -- mdb-killcursors-msg )
+
+M: sequence <mdb-killcursors-msg> ( sequences -- mdb-killcursors-msg )
+ [ mdb-killcursors-msg new ] dip
+ [ length >>cursors# ] keep
+ >>cursors OP_KillCursors >>opcode ; inline
+
+M: integer <mdb-killcursors-msg> ( integer -- mdb-killcursors-msg )
+ V{ } clone [ push ] keep <mdb-killcursors-msg> ;
+
+GENERIC: <mdb-insert-msg> ( collection objects -- mdb-insert-msg )
+
+M: sequence <mdb-insert-msg> ( collection sequence -- mdb-insert-msg )
+ [ mdb-insert-msg new ] 2dip
+ [ >>collection ] dip
+ >>objects OP_Insert >>opcode ;
+
+M: assoc <mdb-insert-msg> ( collection assoc -- mdb-insert-msg )
+ [ mdb-insert-msg new ] 2dip
+ [ >>collection ] dip
+ V{ } clone tuck push
+ >>objects OP_Insert >>opcode ;
+
+
+CONSTRUCTOR: mdb-update-msg ( collection selector object -- mdb-update-msg )
+ OP_Update >>opcode ; inline
+
+CONSTRUCTOR: mdb-reply-msg ( -- mdb-reply-msg ) ; inline
+
diff --git a/extra/mongodb/msg/summary.txt b/extra/mongodb/msg/summary.txt
new file mode 100644
index 0000000000..daff8c279b
--- /dev/null
+++ b/extra/mongodb/msg/summary.txt
@@ -0,0 +1 @@
+message primitives for the communication with MongoDB
diff --git a/extra/mongodb/operations/authors.txt b/extra/mongodb/operations/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/operations/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/operations/operations.factor b/extra/mongodb/operations/operations.factor
new file mode 100644
index 0000000000..001e8443e4
--- /dev/null
+++ b/extra/mongodb/operations/operations.factor
@@ -0,0 +1,222 @@
+USING: accessors assocs bson.reader bson.writer byte-arrays
+byte-vectors combinators formatting fry io io.binary io.encodings.private
+io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files
+kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ;
+
+IN: alien.c-types
+
+M: byte-vector byte-length length ;
+
+IN: mongodb.operations
+
+<PRIVATE
+
+PREDICATE: mdb-reply-op < integer OP_Reply = ;
+PREDICATE: mdb-query-op < integer OP_Query = ;
+PREDICATE: mdb-insert-op < integer OP_Insert = ;
+PREDICATE: mdb-update-op < integer OP_Update = ;
+PREDICATE: mdb-delete-op < integer OP_Delete = ;
+PREDICATE: mdb-getmore-op < integer OP_GetMore = ;
+PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;
+
+PRIVATE>
+
+GENERIC: write-message ( message -- )
+
+<PRIVATE
+
+CONSTANT: MSG-HEADER-SIZE 16
+
+SYMBOL: msg-bytes-read
+
+: bytes-read> ( -- integer )
+ msg-bytes-read get ; inline
+
+: >bytes-read ( integer -- )
+ msg-bytes-read set ; inline
+
+: change-bytes-read ( integer -- )
+ bytes-read> [ 0 ] unless* + >bytes-read ; inline
+
+: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline
+: read-longlong ( -- longlong ) 8 [ read le> ] [ change-bytes-read ] bi ; inline
+: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline
+: read-byte ( -- byte ) read-byte-raw first ; inline
+
+: (read-cstring) ( acc -- )
+ [ read-byte ] dip ! b acc
+ 2dup push ! b acc
+ [ 0 = ] dip ! bool acc
+ '[ _ (read-cstring) ] unless ; inline recursive
+
+: read-cstring ( -- string )
+ BV{ } clone
+ [ (read-cstring) ] keep
+ [ zero? ] trim-tail
+ >byte-array utf8 decode ; inline
+
+GENERIC: (read-message) ( message opcode -- message )
+
+: copy-header ( message msg-stub -- message )
+ [ length>> ] keep [ >>length ] dip
+ [ req-id>> ] keep [ >>req-id ] dip
+ [ resp-id>> ] keep [ >>resp-id ] dip
+ [ opcode>> ] keep [ >>opcode ] dip
+ flags>> >>flags ;
+
+M: mdb-query-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-query-msg new ] dip copy-header
+ read-cstring >>collection
+ read-int32 >>skip#
+ read-int32 >>return#
+ H{ } stream>assoc change-bytes-read >>query
+ dup length>> bytes-read> >
+ [ H{ } stream>assoc change-bytes-read >>returnfields ] when ;
+
+M: mdb-insert-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-insert-msg new ] dip copy-header
+ read-cstring >>collection
+ V{ } clone >>objects
+ [ '[ _ length>> bytes-read> > ] ] keep tuck
+ '[ H{ } stream>assoc change-bytes-read _ objects>> push ]
+ while ;
+
+M: mdb-delete-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-delete-msg new ] dip copy-header
+ read-cstring >>collection
+ H{ } stream>assoc change-bytes-read >>selector ;
+
+M: mdb-getmore-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-getmore-msg new ] dip copy-header
+ read-cstring >>collection
+ read-int32 >>return#
+ read-longlong >>cursor ;
+
+M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-killcursors-msg new ] dip copy-header
+ read-int32 >>cursors#
+ V{ } clone >>cursors
+ [ [ cursors#>> ] keep
+ '[ read-longlong _ cursors>> push ] times ] keep ;
+
+M: mdb-update-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ mdb-update-msg new ] dip copy-header
+ read-cstring >>collection
+ read-int32 >>upsert?
+ H{ } stream>assoc change-bytes-read >>selector
+ H{ } stream>assoc change-bytes-read >>object ;
+
+M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
+ drop
+ [ <mdb-reply-msg> ] dip copy-header
+ read-longlong >>cursor
+ read-int32 >>start#
+ read-int32 [ >>returned# ] keep
+ [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ;
+
+: read-header ( message -- message )
+ read-int32 >>length
+ read-int32 >>req-id
+ read-int32 >>resp-id
+ read-int32 >>opcode
+ read-int32 >>flags ; inline
+
+: write-header ( message -- )
+ [ req-id>> write-int32 ] keep
+ [ resp-id>> write-int32 ] keep
+ opcode>> write-int32 ; inline
+
+PRIVATE>
+
+: read-message ( -- message )
+ mdb-msg new
+ 0 >bytes-read
+ read-header
+ [ ] [ opcode>> ] bi (read-message) ;
+
+<PRIVATE
+
+USE: tools.walker
+
+: dump-to-file ( array -- )
+ [ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip
+ '[ _ write ] with-file-writer ;
+
+: (write-message) ( message quot -- )
+ '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
+ ! [ dump-to-file ] keep
+ write flush ; inline
+
+: build-query-object ( query -- selector )
+ [let | selector [ H{ } clone ] |
+ { [ orderby>> [ "orderby" selector set-at ] when* ]
+ [ explain>> [ "$explain" selector set-at ] when* ]
+ [ hint>> [ "$hint" selector set-at ] when* ]
+ [ query>> "query" selector set-at ]
+ } cleave
+ selector
+ ] ;
+
+PRIVATE>
+
+M: mdb-query-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ [ skip#>> write-int32 ] keep
+ [ return#>> write-int32 ] keep
+ [ build-query-object assoc>stream ] keep
+ returnfields>> [ assoc>stream ] when*
+ ] (write-message) ;
+
+M: mdb-insert-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ objects>> [ assoc>stream ] each
+ ] (write-message) ;
+
+M: mdb-update-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ [ upsert?>> write-int32 ] keep
+ [ selector>> assoc>stream ] keep
+ object>> assoc>stream
+ ] (write-message) ;
+
+M: mdb-delete-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ 0 write-int32
+ selector>> assoc>stream
+ ] (write-message) ;
+
+M: mdb-getmore-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ collection>> write-cstring ] keep
+ [ return#>> write-int32 ] keep
+ cursor>> write-longlong
+ ] (write-message) ;
+
+M: mdb-killcursors-msg write-message ( message -- )
+ dup
+ '[ _
+ [ flags>> write-int32 ] keep
+ [ cursors#>> write-int32 ] keep
+ cursors>> [ write-longlong ] each
+ ] (write-message) ;
+
diff --git a/extra/mongodb/operations/summary.txt b/extra/mongodb/operations/summary.txt
new file mode 100644
index 0000000000..ab9f94e04f
--- /dev/null
+++ b/extra/mongodb/operations/summary.txt
@@ -0,0 +1 @@
+low-level message reading and writing
diff --git a/extra/mongodb/summary.txt b/extra/mongodb/summary.txt
new file mode 100644
index 0000000000..87c5b2d527
--- /dev/null
+++ b/extra/mongodb/summary.txt
@@ -0,0 +1 @@
+MongoDB Factor integration
diff --git a/extra/mongodb/tags.txt b/extra/mongodb/tags.txt
new file mode 100644
index 0000000000..aa0d57e895
--- /dev/null
+++ b/extra/mongodb/tags.txt
@@ -0,0 +1 @@
+database
diff --git a/extra/mongodb/tuple/authors.txt b/extra/mongodb/tuple/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/tuple/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/tuple/collection/authors.txt b/extra/mongodb/tuple/collection/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/tuple/collection/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor
new file mode 100644
index 0000000000..1bd2d94e69
--- /dev/null
+++ b/extra/mongodb/tuple/collection/collection.factor
@@ -0,0 +1,178 @@
+
+USING: accessors arrays assocs bson.constants classes classes.tuple
+combinators continuations fry kernel mongodb.driver sequences strings
+vectors words combinators.smart literals memoize slots constructors ;
+
+IN: mongodb.tuple
+
+SINGLETONS: +transient+ +load+ +user-defined-key+ ;
+
+: <tuple-index> ( name key -- index-spec )
+ index-spec new swap >>key swap >>name ;
+
+IN: mongodb.tuple.collection
+
+TUPLE: toid key value ;
+
+CONSTRUCTOR: toid ( value key -- toid ) ;
+
+FROM: mongodb.tuple => +transient+ +load+ <tuple-index> ;
+
+MIXIN: mdb-persistent
+
+SLOT: id
+SLOT: _id
+SLOT: _mfd
+
+<PRIVATE
+
+CONSTANT: MDB_COLLECTION "mongodb_collection"
+CONSTANT: MDB_SLOTDEF_MAP "mongodb_slot_map"
+CONSTANT: MDB_INDEX_MAP "mongodb_index_map"
+CONSTANT: MDB_USER_KEY "mongodb_user_key"
+CONSTANT: MDB_COLLECTION_MAP "mongodb_collection_map"
+
+MEMO: id-slot ( class -- slot )
+ MDB_USER_KEY word-prop
+ dup [ drop "_id" ] unless ;
+
+PRIVATE>
+
+: >toid ( object -- toid )
+ [ id>> ] [ class id-slot ] bi <toid> ;
+
+M: mdb-persistent id>> ( object -- id )
+ dup class id-slot reader-word execute( object -- id ) ;
+
+M: mdb-persistent (>>id) ( object value -- )
+ over class id-slot writer-word execute( object value -- ) ;
+
+
+
+TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
+
+GENERIC: tuple-collection ( object -- mdb-collection )
+
+GENERIC: mdb-slot-map ( tuple -- assoc )
+
+GENERIC: mdb-index-map ( tuple -- sequence )
+
+<PRIVATE
+
+
+: (mdb-collection) ( class -- mdb-collection )
+ dup MDB_COLLECTION word-prop
+ [ nip ]
+ [ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
+
+: (mdb-slot-map) ( class -- slot-map )
+ superclasses [ MDB_SLOTDEF_MAP word-prop ] map assoc-combine ; inline
+
+: (mdb-index-map) ( class -- index-map )
+ superclasses [ MDB_INDEX_MAP word-prop ] map assoc-combine ; inline
+
+: split-optl ( seq -- key options )
+ [ first ] [ rest ] bi ; inline
+
+: optl>map ( seq -- map )
+ [ H{ } clone ] dip over
+ '[ split-optl swap _ set-at ] each ; inline
+
+: index-list>map ( seq -- map )
+ [ H{ } clone ] dip over
+ '[ dup name>> _ set-at ] each ; inline
+
+: user-defined-key ( map -- key value ? )
+ [ nip [ +user-defined-key+ ] dip member? ] assoc-find ; inline
+
+: user-defined-key-index ( class -- assoc )
+ mdb-slot-map user-defined-key
+ [ drop [ "user-defined-key-index" 1 ] dip
+ H{ } clone [ set-at ] keep <tuple-index> unique-index
+ [ ] [ name>> ] bi H{ } clone [ set-at ] keep
+ ] [ 2drop H{ } clone ] if ;
+
+PRIVATE>
+
+: MDB_ADDON_SLOTS ( -- slots )
+ { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
+
+: link-class ( collection class -- )
+ over classes>>
+ [ 2dup member? [ 2drop ] [ push ] if ]
+ [ 1vector >>classes ] if* drop ; inline
+
+: link-collection ( class collection -- )
+ [ swap link-class ]
+ [ MDB_COLLECTION set-word-prop ] 2bi ; inline
+
+: mdb-check-slots ( superclass slots -- superclass slots )
+ over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member?
+ [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline
+
+: set-slot-map ( class option-list -- )
+ optl>map [ MDB_SLOTDEF_MAP set-word-prop ] 2keep
+ user-defined-key
+ [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline
+
+: set-index-map ( class index-list -- )
+ [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence
+ assoc-combine MDB_INDEX_MAP set-word-prop ; inline
+
+M: tuple-class tuple-collection ( tuple -- mdb-collection )
+ (mdb-collection) ;
+
+M: mdb-persistent tuple-collection ( tuple -- mdb-collection )
+ class (mdb-collection) ;
+
+M: mdb-persistent mdb-slot-map ( tuple -- string )
+ class (mdb-slot-map) ;
+
+M: tuple-class mdb-slot-map ( class -- assoc )
+ (mdb-slot-map) ;
+
+M: mdb-collection mdb-slot-map ( collection -- assoc )
+ classes>> [ mdb-slot-map ] map assoc-combine ;
+
+M: mdb-persistent mdb-index-map
+ class (mdb-index-map) ;
+M: tuple-class mdb-index-map
+ (mdb-index-map) ;
+M: mdb-collection mdb-index-map
+ classes>> [ mdb-index-map ] map assoc-combine ;
+
+<PRIVATE
+
+: collection-map ( -- assoc )
+ mdb-persistent MDB_COLLECTION_MAP word-prop
+ [ mdb-persistent MDB_COLLECTION_MAP H{ } clone
+ [ set-word-prop ] keep ] unless* ; inline
+
+: slot-option? ( tuple slot option -- ? )
+ [ swap mdb-slot-map at ] dip
+ '[ _ swap memq? ] [ f ] if* ;
+
+PRIVATE>
+
+GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
+M: string <mdb-tuple-collection>
+ collection-map [ ] [ key? ] 2bi
+ [ at ] [ [ mdb-tuple-collection new dup ] 2dip
+ [ [ >>name ] keep ] dip set-at ] if ; inline
+M: mdb-tuple-collection <mdb-tuple-collection> ;
+M: mdb-collection <mdb-tuple-collection>
+ [ name>> <mdb-tuple-collection> ] keep
+ {
+ [ capped>> >>capped ]
+ [ size>> >>size ]
+ [ max>> >>max ]
+ } cleave ;
+
+: user-defined-key? ( tuple slot -- ? )
+ +user-defined-key+ slot-option? ;
+
+: transient-slot? ( tuple slot -- ? )
+ +transient+ slot-option? ;
+
+: load-slot? ( tuple slot -- ? )
+ +load+ slot-option? ;
diff --git a/extra/mongodb/tuple/collection/summary.txt b/extra/mongodb/tuple/collection/summary.txt
new file mode 100644
index 0000000000..e568b51c48
--- /dev/null
+++ b/extra/mongodb/tuple/collection/summary.txt
@@ -0,0 +1 @@
+tuple class MongoDB collection handling
diff --git a/extra/mongodb/tuple/persistent/authors.txt b/extra/mongodb/tuple/persistent/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/tuple/persistent/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/tuple/persistent/persistent.factor b/extra/mongodb/tuple/persistent/persistent.factor
new file mode 100644
index 0000000000..fc521eca3e
--- /dev/null
+++ b/extra/mongodb/tuple/persistent/persistent.factor
@@ -0,0 +1,113 @@
+USING: accessors assocs bson.constants combinators.short-circuit
+constructors continuations fry kernel mirrors mongodb.tuple.collection
+mongodb.tuple.state namespaces sequences words bson.writer combinators
+hashtables linked-assocs ;
+
+IN: mongodb.tuple.persistent
+
+SYMBOLS: object-map ;
+
+GENERIC: tuple>assoc ( tuple -- assoc )
+
+GENERIC: tuple>selector ( tuple -- selector )
+
+DEFER: assoc>tuple
+
+<PRIVATE
+
+: mdbinfo>tuple-class ( tuple-info -- class )
+ [ first ] keep second lookup ; inline
+
+: tuple-instance ( tuple-info -- instance )
+ mdbinfo>tuple-class new ; inline
+
+: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
+ [ tuple-info tuple-instance dup
+ <mirror> [ keys ] keep ] keep swap ; inline
+
+: make-tuple ( assoc -- tuple )
+ prepare-assoc>tuple
+ '[ dup _ at assoc>tuple swap _ set-at ] each ; inline recursive
+
+: at+ ( value key assoc -- value )
+ 2dup key?
+ [ at nip ] [ [ dup ] 2dip set-at ] if ; inline
+
+: data-tuple? ( tuple -- ? )
+ dup tuple?
+ [ assoc? not ] [ drop f ] if ; inline
+
+: add-storable ( assoc ns toid -- )
+ [ [ H{ } clone ] dip object-map get at+ ] dip
+ swap set-at ; inline
+
+: write-field? ( tuple key value -- ? )
+ pick mdb-persistent? [
+ { [ [ 2drop ] dip not ]
+ [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
+
+TUPLE: cond-value value quot ;
+
+CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
+
+: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' )
+ over [ call( tuple -- assoc ) ] dip
+ [ [ tuple-collection name>> ] [ >toid ] bi ] keep
+ [ add-storable ] dip
+ [ tuple-collection name>> ] [ id>> ] bi <objref> ; inline
+
+: write-field ( value quot: ( tuple -- assoc ) -- value' )
+ <cond-value> {
+ { [ dup value>> mdb-special-value? ] [ value>> ] }
+ { [ dup value>> mdb-persistent? ]
+ [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
+ { [ dup value>> data-tuple? ]
+ [ [ value>> ] [ quot>> ] bi (( tuple -- assoc )) call-effect ] }
+ { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
+ [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
+ [ value>> ]
+ } cond ; inline recursive
+
+: write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
+ swap ! m t q q a
+ '[ _ 2over write-field?
+ [ _ write-field swap _ set-at ]
+ [ 2drop ] if
+ ] assoc-each ;
+
+: prepare-assoc ( tuple -- assoc mirror tuple assoc )
+ H{ } clone swap [ <mirror> ] keep pick ; inline
+
+: ensure-mdb-info ( tuple -- tuple )
+ dup id>> [ <objid> >>id ] unless ; inline
+
+: with-object-map ( quot: ( -- ) -- store-assoc )
+ [ H{ } clone dup object-map ] dip with-variable ; inline
+
+: (tuple>assoc) ( tuple -- assoc )
+ [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
+ over set-tuple-info ; inline
+
+PRIVATE>
+
+GENERIC: tuple>storable ( tuple -- storable )
+
+M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
+ '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; inline
+
+M: mdb-persistent tuple>assoc ( tuple -- assoc )
+ ensure-mdb-info (tuple>assoc) ;
+
+M: tuple tuple>assoc ( tuple -- assoc )
+ (tuple>assoc) ;
+
+M: tuple tuple>selector ( tuple -- assoc )
+ prepare-assoc [ tuple>selector ] write-tuple-fields ;
+
+: assoc>tuple ( assoc -- tuple )
+ dup assoc?
+ [ [ dup tuple-info?
+ [ make-tuple ]
+ [ ] if ] [ drop ] recover
+ ] [ ] if ; inline recursive
+
diff --git a/extra/mongodb/tuple/persistent/summary.txt b/extra/mongodb/tuple/persistent/summary.txt
new file mode 100644
index 0000000000..46f32e4caf
--- /dev/null
+++ b/extra/mongodb/tuple/persistent/summary.txt
@@ -0,0 +1 @@
+tuple to MongoDB storable conversion (and back)
diff --git a/extra/mongodb/tuple/state/authors.txt b/extra/mongodb/tuple/state/authors.txt
new file mode 100644
index 0000000000..5df962bfe0
--- /dev/null
+++ b/extra/mongodb/tuple/state/authors.txt
@@ -0,0 +1 @@
+Sascha Matzke
diff --git a/extra/mongodb/tuple/state/state.factor b/extra/mongodb/tuple/state/state.factor
new file mode 100644
index 0000000000..ec1b8865ab
--- /dev/null
+++ b/extra/mongodb/tuple/state/state.factor
@@ -0,0 +1,25 @@
+USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection
+words classes.tuple slots generic ;
+
+IN: mongodb.tuple.state
+
+<PRIVATE
+
+CONSTANT: MDB_TUPLE_INFO "_mfd_t_info"
+
+PRIVATE>
+
+: <tuple-info> ( tuple -- tuple-info )
+ class V{ } clone tuck
+ [ [ name>> ] dip push ]
+ [ [ vocabulary>> ] dip push ] 2bi ; inline
+
+: tuple-info ( assoc -- tuple-info )
+ [ MDB_TUPLE_INFO ] dip at ; inline
+
+: set-tuple-info ( tuple assoc -- )
+ [ <tuple-info> MDB_TUPLE_INFO ] dip set-at ; inline
+
+: tuple-info? ( assoc -- ? )
+ [ MDB_TUPLE_INFO ] dip key? ;
+
diff --git a/extra/mongodb/tuple/state/summary.txt b/extra/mongodb/tuple/state/summary.txt
new file mode 100644
index 0000000000..f879133465
--- /dev/null
+++ b/extra/mongodb/tuple/state/summary.txt
@@ -0,0 +1 @@
+client-side persistent tuple state handling
diff --git a/extra/mongodb/tuple/summary.txt b/extra/mongodb/tuple/summary.txt
new file mode 100644
index 0000000000..6c79de23d6
--- /dev/null
+++ b/extra/mongodb/tuple/summary.txt
@@ -0,0 +1 @@
+persist tuple instances into MongoDB
diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor
new file mode 100644
index 0000000000..9173957979
--- /dev/null
+++ b/extra/mongodb/tuple/tuple.factor
@@ -0,0 +1,83 @@
+USING: accessors assocs classes.mixin classes.tuple
+classes.tuple.parser compiler.units fry kernel sequences mongodb.driver
+mongodb.msg mongodb.tuple.collection
+mongodb.tuple.persistent mongodb.tuple.state strings ;
+
+IN: mongodb.tuple
+
+SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ +unique+ ;
+
+SYNTAX: MDBTUPLE:
+ parse-tuple-definition
+ mdb-check-slots
+ define-tuple-class ;
+
+: define-persistent ( class collection slot-options index -- )
+ [ [ <mdb-tuple-collection> dupd link-collection ] when* ] 2dip
+ [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] 2dip
+ [ drop set-slot-map ]
+ [ nip set-index-map ] 3bi ; inline
+
+: ensure-table ( class -- )
+ tuple-collection
+ [ create-collection ]
+ [ [ mdb-index-map values ] keep
+ '[ _ name>> >>ns ensure-index ] each
+ ] bi ;
+
+: ensure-tables ( classes -- )
+ [ ensure-table ] each ;
+
+: drop-table ( class -- )
+ tuple-collection
+ [ [ mdb-index-map values ] keep
+ '[ _ name>> swap name>> drop-index ] each ]
+ [ name>> drop-collection ] bi ;
+
+: recreate-table ( class -- )
+ [ drop-table ]
+ [ ensure-table ] bi ;
+
+<PRIVATE
+
+GENERIC: id-selector ( object -- selector )
+
+M: toid id-selector
+ [ value>> ] [ key>> ] bi H{ } clone [ set-at ] keep ; inline
+
+M: mdb-persistent id-selector
+ >toid id-selector ;
+
+: (save-tuples) ( collection assoc -- )
+ swap '[ [ _ ] 2dip
+ [ id-selector ] dip
+ <update> >upsert update ] assoc-each ; inline
+PRIVATE>
+
+: save-tuple ( tuple -- )
+ tuple>storable [ (save-tuples) ] assoc-each ;
+
+: update-tuple ( tuple -- )
+ save-tuple ;
+
+: insert-tuple ( tuple -- )
+ save-tuple ;
+
+: delete-tuple ( tuple -- )
+ [ tuple-collection name>> ] keep
+ id-selector delete ;
+
+: tuple>query ( tuple -- query )
+ [ tuple-collection name>> ] keep
+ tuple>selector <query> ;
+
+: select-tuple ( tuple/query -- tuple/f )
+ dup mdb-query-msg? [ tuple>query ] unless
+ find-one [ assoc>tuple ] [ f ] if* ;
+
+: select-tuples ( tuple/query -- cursor tuples/f )
+ dup mdb-query-msg? [ tuple>query ] unless
+ find [ assoc>tuple ] map ;
+
+: count-tuples ( tuple/query -- n )
+ dup mdb-query-msg? [ tuple>query ] unless count ;
diff --git a/extra/morse/authors.txt b/extra/morse/authors.txt
new file mode 100644
index 0000000000..409f0443a6
--- /dev/null
+++ b/extra/morse/authors.txt
@@ -0,0 +1,2 @@
+Alex Chapman
+Diego Martinelli
diff --git a/unmaintained/morse/morse-docs.factor b/extra/morse/morse-docs.factor
similarity index 70%
rename from unmaintained/morse/morse-docs.factor
rename to extra/morse/morse-docs.factor
index e35967d3e9..e2fab1528b 100644
--- a/unmaintained/morse/morse-docs.factor
+++ b/extra/morse/morse-docs.factor
@@ -5,22 +5,22 @@ IN: morse
HELP: ch>morse
{ $values
- { "ch" "A character that has a morse code translation" } { "str" "A string consisting of zero or more dots and dashes" } }
-{ $description "If the given character has a morse code translation, then return that translation, otherwise return an empty string." } ;
+ { "ch" "A character that has a morse code translation" } { "morse" "A string consisting of zero or more dots and dashes" } }
+{ $description "If the given character has a morse code translation, then return that translation, otherwise return a ? character." } ;
HELP: morse>ch
{ $values
{ "str" "A string of dots and dashes that represents a single character in morse code" } { "ch" "The translated character" } }
-{ $description "If the given string represents a morse code character, then return that character, otherwise return f" } ;
+{ $description "If the given string represents a morse code character, then return that character, otherwise return a space character." } ;
HELP: >morse
{ $values
- { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "A string in morse code" } }
+ { "str" "A string of ASCII characters which can be translated into morse code" } { "newstr" "A string in morse code" } }
{ $description "Translates ASCII text into morse code, represented by a series of dots, dashes, and slashes." }
{ $see-also morse> ch>morse } ;
HELP: morse>
-{ $values { "str" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "str" "The ASCII translation of the given string" } }
+{ $values { "morse" "A string of morse code, in which the character '.' represents dots, '-' dashes, ' ' spaces between letters, and ' / ' spaces between words." } { "plain" "The ASCII translation of the given string" } }
{ $description "Translates morse code into ASCII text" }
{ $see-also >morse morse>ch } ;
diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor
new file mode 100644
index 0000000000..f1da7ce139
--- /dev/null
+++ b/extra/morse/morse-tests.factor
@@ -0,0 +1,44 @@
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays morse strings tools.test ;
+IN: morse.tests
+
+[ "?" ] [ CHAR: \\ ch>morse ] unit-test
+[ "..." ] [ CHAR: s ch>morse ] unit-test
+[ CHAR: s ] [ "..." morse>ch ] unit-test
+[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
+[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
+[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
+[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
+[ ".- -... -.-." ] [ "abc" >morse ] unit-test
+
+[ "abc" ] [ ".- -... -.-." morse> ] unit-test
+
+[ "morse code" ] [
+ [MORSE
+ -- --- .-. ... . /
+ -.-. --- -.. .
+ MORSE] >morse morse> ] unit-test
+
+[ "morse code 123" ] [
+ [MORSE
+ __ ___ ._. ... . /
+ _._. ___ _.. . /
+ .____ ..___ ...__
+ MORSE] ] unit-test
+
+[ [MORSE
+ -- --- .-. ... . /
+ -.-. --- -.. .
+ MORSE] ] [
+ "morse code" >morse morse>
+] unit-test
+
+[ "factor rocks!" ] [
+ [MORSE
+ ..-. .- -.-. - --- .-. /
+ .-. --- -.-. -.- ... -.-.--
+ MORSE] ] unit-test
+! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
+! [ ] [ "Factor rocks!" play-as-morse ] unit-test
+! [ ] [ "\n" play-as-morse ] unit-test
diff --git a/unmaintained/morse/morse.factor b/extra/morse/morse.factor
similarity index 66%
rename from unmaintained/morse/morse.factor
rename to extra/morse/morse.factor
index 2951c96077..ddfd3c2042 100644
--- a/unmaintained/morse/morse.factor
+++ b/extra/morse/morse.factor
@@ -1,13 +1,22 @@
-! Copyright (C) 2007, 2008 Alex Chapman
+! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lists math
-namespaces make openal parser-combinators promises sequences
-strings symbols synth synth.buffers unicode.case ;
+USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
IN: morse
+ERROR: no-morse-ch ch ;
+
<PRIVATE
-: morse-codes ( -- array )
- {
+
+CONSTANT: dot-char CHAR: .
+CONSTANT: dash-char CHAR: -
+CONSTANT: char-gap-char CHAR: \s
+CONSTANT: word-gap-char CHAR: /
+CONSTANT: unknown-char CHAR: ?
+
+PRIVATE>
+
+CONSTANT: morse-code-table $[
+ H{
{ CHAR: a ".-" }
{ CHAR: b "-..." }
{ CHAR: c "-.-." }
@@ -63,68 +72,47 @@ IN: morse
{ CHAR: $ "...-..-" }
{ CHAR: @ ".--.-." }
{ CHAR: \s "/" }
- } ;
+ } >biassoc
+]
-: ch>morse-assoc ( -- assoc )
- morse-codes >hashtable ;
-
-: morse>ch-assoc ( -- assoc )
- morse-codes [ reverse ] map >hashtable ;
-
-PRIVATE>
-
-: ch>morse ( ch -- str )
- ch>lower ch>morse-assoc at* swap "" ? ;
+: ch>morse ( ch -- morse )
+ ch>lower morse-code-table at unknown-char 1string or ;
: morse>ch ( str -- ch )
- morse>ch-assoc at* swap f ? ;
-
-: >morse ( str -- str )
- [
- [ CHAR: \s , ] [ ch>morse % ] interleave
- ] "" make ;
-
+ morse-code-table value-at char-gap-char or ;
+
<PRIVATE
+
+: word>morse ( str -- morse )
+ [ ch>morse ] { } map-as " " join ;
-: dot-char ( -- ch ) CHAR: . ;
-: dash-char ( -- ch ) CHAR: - ;
-: char-gap-char ( -- ch ) CHAR: \s ;
-: word-gap-char ( -- ch ) CHAR: / ;
+: sentence>morse ( str -- morse )
+ " " split [ word>morse ] map " / " join ;
+
+: trim-blanks ( str -- newstr )
+ [ blank? ] trim ; inline
-: =parser ( obj -- parser )
- [ = ] curry satisfy ;
+: morse>word ( morse -- str )
+ " " split [ morse>ch ] "" map-as ;
-LAZY: 'dot' ( -- parser )
- dot-char =parser ;
+: morse>sentence ( morse -- sentence )
+ "/" split [ trim-blanks morse>word ] map " " join ;
-LAZY: 'dash' ( -- parser )
- dash-char =parser ;
-
-LAZY: 'char-gap' ( -- parser )
- char-gap-char =parser ;
-
-LAZY: 'word-gap' ( -- parser )
- word-gap-char =parser ;
-
-LAZY: 'morse-char' ( -- parser )
- 'dot' 'dash' <|> <+> ;
-
-LAZY: 'morse-word' ( -- parser )
- 'morse-char' 'char-gap' list-of ;
-
-LAZY: 'morse-words' ( -- parser )
- 'morse-word' 'word-gap' list-of ;
+: replace-underscores ( str -- str' )
+ [ dup CHAR: _ = [ drop CHAR: - ] when ] map ;
PRIVATE>
+
+: >morse ( str -- newstr )
+ trim-blanks sentence>morse ;
+
+: morse> ( morse -- plain )
+ replace-underscores morse>sentence ;
-: morse> ( str -- str )
- 'morse-words' parse car parsed>> [
- [
- >string morse>ch
- ] map >string
- ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
-
+SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ;
+
<PRIVATE
+
SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
: queue ( symbol -- )
@@ -135,7 +123,7 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
: letter-gap ( -- ) letter-gap-buffer queue ;
-: beep-freq 880 ;
+CONSTANT: beep-freq 880
: <morse-buffer> ( -- buffer )
half-sample-freq <8bit-mono-buffer> ;
@@ -160,14 +148,16 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
init-openal 1 gen-sources first source set make-buffers
call
source get source-play
- ] with-scope ;
+ ] with-scope ; inline
-: play-char ( ch -- )
+: play-char ( string -- )
[ intra-char-gap ] [
{
{ dot-char [ dot ] }
{ dash-char [ dash ] }
{ word-gap-char [ intra-char-gap ] }
+ { unknown-char [ intra-char-gap ] }
+ [ no-morse-ch ]
} case
] interleave ;
@@ -176,7 +166,7 @@ PRIVATE>
: play-as-morse* ( str unit-length -- )
[
[ letter-gap ] [ ch>morse play-char ] interleave
- ] swap playing-morse ;
+ ] swap playing-morse ; inline
: play-as-morse ( str -- )
- 0.05 play-as-morse* ;
+ 0.05 play-as-morse* ; inline
diff --git a/unmaintained/morse/summary.txt b/extra/morse/summary.txt
similarity index 100%
rename from unmaintained/morse/summary.txt
rename to extra/morse/summary.txt
diff --git a/unmaintained/morse/tags.txt b/extra/morse/tags.txt
similarity index 100%
rename from unmaintained/morse/tags.txt
rename to extra/morse/tags.txt
diff --git a/extra/multi-methods/authors.txt b/extra/multi-methods/authors.txt
deleted file mode 100755
index 1901f27a24..0000000000
--- a/extra/multi-methods/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/unmaintained/openal/authors.txt b/extra/openal/authors.txt
similarity index 100%
rename from unmaintained/openal/authors.txt
rename to extra/openal/authors.txt
diff --git a/unmaintained/openal/backend/authors.txt b/extra/openal/backend/authors.txt
similarity index 100%
rename from unmaintained/openal/backend/authors.txt
rename to extra/openal/backend/authors.txt
diff --git a/unmaintained/openal/backend/backend.factor b/extra/openal/backend/backend.factor
similarity index 100%
rename from unmaintained/openal/backend/backend.factor
rename to extra/openal/backend/backend.factor
diff --git a/unmaintained/openal/example/authors.txt b/extra/openal/example/authors.txt
similarity index 100%
rename from unmaintained/openal/example/authors.txt
rename to extra/openal/example/authors.txt
diff --git a/extra/openal/example/example.factor b/extra/openal/example/example.factor
new file mode 100644
index 0000000000..4d979a8fa7
--- /dev/null
+++ b/extra/openal/example/example.factor
@@ -0,0 +1,33 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar kernel openal sequences threads ;
+IN: openal.example
+
+: play-hello ( -- )
+ init-openal
+ 1 gen-sources
+ first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param
+ source-play
+ 1000 milliseconds sleep ;
+
+: (play-file) ( source -- )
+ 100 milliseconds sleep
+ dup source-playing? [ (play-file) ] [ drop ] if ;
+
+: play-file ( filename -- )
+ init-openal
+ create-buffer-from-file
+ 1 gen-sources
+ first dup [ AL_BUFFER rot set-source-param ] dip
+ dup source-play
+ check-error
+ (play-file) ;
+
+: play-wav ( filename -- )
+ init-openal
+ create-buffer-from-wav
+ 1 gen-sources
+ first dup [ AL_BUFFER rot set-source-param ] dip
+ dup source-play
+ check-error
+ (play-file) ;
diff --git a/unmaintained/openal/macosx/authors.txt b/extra/openal/macosx/authors.txt
similarity index 100%
rename from unmaintained/openal/macosx/authors.txt
rename to extra/openal/macosx/authors.txt
diff --git a/unmaintained/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor
similarity index 84%
rename from unmaintained/openal/macosx/macosx.factor
rename to extra/openal/macosx/macosx.factor
index abc0d65fb9..81d360eca1 100644
--- a/unmaintained/openal/macosx/macosx.factor
+++ b/extra/openal/macosx/macosx.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel alien alien.syntax shuffle
-combinators.lib openal.backend namespaces system ;
+openal.backend namespaces system generalizations ;
IN: openal.macosx
LIBRARY: alut
@@ -10,5 +10,5 @@ FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data,
M: macosx load-wav-file ( path -- format data size frequency )
0 <int> f <void*> 0 <int> 0 <int>
- [ alutLoadWAVFile ] 4keep
+ [ alutLoadWAVFile ] 4 nkeep
[ [ [ *int ] dip *void* ] dip *int ] dip *int ;
diff --git a/extra/openal/macosx/tags.txt b/extra/openal/macosx/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/extra/openal/macosx/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/unmaintained/openal/openal.factor b/extra/openal/openal.factor
similarity index 96%
rename from unmaintained/openal/openal.factor
rename to extra/openal/openal.factor
index 8533308f26..6e9721b0fe 100644
--- a/unmaintained/openal/openal.factor
+++ b/extra/openal/openal.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays alien system combinators alien.syntax namespaces
+USING: kernel accessors arrays alien system combinators alien.syntax namespaces
alien.c-types sequences vocabs.loader shuffle
- openal.backend specialized-arrays.uint ;
+ openal.backend specialized-arrays.uint alien.libraries generalizations ;
IN: openal
<< "alut" {
@@ -245,13 +245,11 @@ SYMBOL: init
f init set-global
] unless ;
-: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
-
: gen-sources ( size -- seq )
- dup <uint-array> 2dup underlying>> alGenSources swap ;
+ dup <uint-array> [ alGenSources ] keep ;
: gen-buffers ( size -- seq )
- dup <uint-array> 2dup underlying>> alGenBuffers swap ;
+ dup <uint-array> [ alGenBuffers ] keep ;
: gen-buffer ( -- buffer ) 1 gen-buffers first ;
@@ -264,10 +262,10 @@ os macosx? "openal.macosx" "openal.other" ? require
: create-buffer-from-wav ( filename -- buffer )
gen-buffer dup rot load-wav-file
- [ alBufferData ] 4keep alutUnloadWAV ;
+ [ alBufferData ] 4 nkeep alutUnloadWAV ;
: queue-buffers ( source buffers -- )
- [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ;
+ [ length ] [ >uint-array ] bi alSourceQueueBuffers ;
: queue-buffer ( source buffer -- )
1array queue-buffers ;
diff --git a/unmaintained/openal/other/authors.txt b/extra/openal/other/authors.txt
similarity index 100%
rename from unmaintained/openal/other/authors.txt
rename to extra/openal/other/authors.txt
diff --git a/unmaintained/openal/other/other.factor b/extra/openal/other/other.factor
similarity index 60%
rename from unmaintained/openal/other/other.factor
rename to extra/openal/other/other.factor
index d0429fb3c3..0936c94150 100644
--- a/unmaintained/openal/other/other.factor
+++ b/extra/openal/other/other.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: openal.backend alien.c-types kernel alien alien.syntax
-shuffle combinators.lib ;
+USING: alien.c-types alien.syntax combinators generalizations
+kernel openal.backend ;
IN: openal.other
LIBRARY: alut
@@ -9,6 +9,6 @@ LIBRARY: alut
FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency, ALboolean* looping ) ;
M: object load-wav-file ( filename -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ 0 <char> alutLoadWAVFile ] 4keep
- >r >r >r *int r> *void* r> *int r> *int ;
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ 0 <char> alutLoadWAVFile ] 4 nkeep
+ { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
diff --git a/unmaintained/openal/summary.txt b/extra/openal/summary.txt
similarity index 100%
rename from unmaintained/openal/summary.txt
rename to extra/openal/summary.txt
diff --git a/unmaintained/openal/tags.txt b/extra/openal/tags.txt
similarity index 100%
rename from unmaintained/openal/tags.txt
rename to extra/openal/tags.txt
diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor
index 5973766c8e..35c64d4ad1 100755
--- a/extra/opengl/demo-support/demo-support.factor
+++ b/extra/opengl/demo-support/demo-support.factor
@@ -1,6 +1,6 @@
USING: arrays kernel math math.functions math.order math.vectors
namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
-ui.render accessors combinators ;
+ui.gadgets.worlds ui.render accessors combinators ;
IN: opengl.demo-support
: FOV ( -- x ) 2.0 sqrt 1+ ; inline
@@ -9,62 +9,62 @@ CONSTANT: KEY-ROTATE-STEP 10.0
SYMBOL: last-drag-loc
-TUPLE: demo-gadget < gadget yaw pitch distance ;
+TUPLE: demo-world < world yaw pitch distance ;
-: new-demo-gadget ( yaw pitch distance class -- gadget )
- new
- swap >>distance
- swap >>pitch
- swap >>yaw ; inline
+: set-demo-orientation ( world yaw pitch distance -- world )
+ [ >>yaw ] [ >>pitch ] [ >>distance ] tri* ;
GENERIC: far-plane ( gadget -- z )
GENERIC: near-plane ( gadget -- z )
GENERIC: distance-step ( gadget -- dz )
-M: demo-gadget far-plane ( gadget -- z )
+M: demo-world far-plane ( gadget -- z )
drop 4.0 ;
-M: demo-gadget near-plane ( gadget -- z )
+M: demo-world near-plane ( gadget -- z )
drop 1.0 64.0 / ;
-M: demo-gadget distance-step ( gadget -- dz )
+M: demo-world distance-step ( gadget -- dz )
drop 1.0 64.0 / ;
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
-: yaw-demo-gadget ( yaw gadget -- )
+: yaw-demo-world ( yaw gadget -- )
[ + ] with change-yaw relayout-1 ;
-: pitch-demo-gadget ( pitch gadget -- )
+: pitch-demo-world ( pitch gadget -- )
[ + ] with change-pitch relayout-1 ;
-: zoom-demo-gadget ( distance gadget -- )
+: zoom-demo-world ( distance gadget -- )
[ + ] with change-distance relayout-1 ;
-M: demo-gadget pref-dim* ( gadget -- dim )
+M: demo-world focusable-child* ( world -- gadget )
+ drop t ;
+
+M: demo-world pref-dim* ( gadget -- dim )
drop { 640 480 } ;
: -+ ( x -- -x x )
[ neg ] keep ;
-: demo-gadget-frustum ( gadget -- -x x -y y near far )
+: demo-world-frustum ( world -- -x x -y y near far )
[ near-plane ] [ far-plane ] [ fov-ratio ] tri [
nip swap FOV / v*n
first2 [ -+ ] bi@
] 3keep drop ;
-: demo-gadget-set-matrices ( gadget -- )
+M: demo-world resize-world
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ [ [ 0 0 ] dip dim>> first2 glViewport ]
+ [ demo-world-frustum glFrustum ] bi ;
+
+: demo-world-set-matrix ( gadget -- )
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- [
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- demo-gadget-frustum glFrustum
- ] [
- GL_MODELVIEW glMatrixMode
- glLoadIdentity
- [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
- [ pitch>> 1.0 0.0 0.0 glRotatef ]
- [ yaw>> 0.0 1.0 0.0 glRotatef ]
- tri
- ] bi ;
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
+ [ pitch>> 1.0 0.0 0.0 glRotatef ]
+ [ yaw>> 0.0 1.0 0.0 glRotatef ]
+ tri ;
: reset-last-drag-rel ( -- )
{ 0 0 } last-drag-loc set-global ;
@@ -94,16 +94,16 @@ M: demo-gadget pref-dim* ( gadget -- dim )
swap first swap second glVertex2d
] do-state ;
-demo-gadget H{
- { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
- { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-gadget ] }
- { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
- { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-gadget ] }
- { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-gadget ] }
- { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-gadget ] }
+demo-world H{
+ { T{ key-down f f "LEFT" } [ KEY-ROTATE-STEP neg swap yaw-demo-world ] }
+ { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP swap yaw-demo-world ] }
+ { T{ key-down f f "DOWN" } [ KEY-ROTATE-STEP neg swap pitch-demo-world ] }
+ { T{ key-down f f "UP" } [ KEY-ROTATE-STEP swap pitch-demo-world ] }
+ { T{ key-down f f "=" } [ dup distance-step neg swap zoom-demo-world ] }
+ { T{ key-down f f "-" } [ dup distance-step swap zoom-demo-world ] }
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
- { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
- { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
+ { T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] }
+ { mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-world ] }
} set-gestures
diff --git a/extra/opengl/glu/authors.txt b/extra/opengl/glu/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/opengl/glu/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/basis/opengl/glu/glu.factor b/extra/opengl/glu/glu.factor
similarity index 97%
rename from basis/opengl/glu/glu.factor
rename to extra/opengl/glu/glu.factor
index d603724a55..fe060e3553 100644
--- a/basis/opengl/glu/glu.factor
+++ b/extra/opengl/glu/glu.factor
@@ -1,8 +1,17 @@
! Copyright (C) 2005 Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel sequences words ;
+USING: alien alien.libraries alien.syntax kernel sequences words system
+combinators ;
IN: opengl.glu
+os {
+ { [ dup macosx? ] [ drop ] }
+ { [ dup windows? ] [ drop ] }
+ { [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
+} cond
+
+LIBRARY: glu
+
! These are defined as structs in glu.h, but we only ever use pointers to them
TYPEDEF: void* GLUnurbs*
TYPEDEF: void* GLUquadric*
@@ -253,3 +262,6 @@ FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdo
! FUNCTION: GLint gluBuild3DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, void* data ) ;
! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
+
+: gl-look-at ( eye focus up -- )
+ [ first3 ] tri@ gluLookAt ;
\ No newline at end of file
diff --git a/basis/opengl/glu/summary.txt b/extra/opengl/glu/summary.txt
similarity index 100%
rename from basis/opengl/glu/summary.txt
rename to extra/opengl/glu/summary.txt
diff --git a/basis/opengl/glu/tags.txt b/extra/opengl/glu/tags.txt
similarity index 100%
rename from basis/opengl/glu/tags.txt
rename to extra/opengl/glu/tags.txt
diff --git a/extra/otug-talk/otug-talk.factor b/extra/otug-talk/otug-talk.factor
index b7256246fe..35a83a63de 100644
--- a/extra/otug-talk/otug-talk.factor
+++ b/extra/otug-talk/otug-talk.factor
@@ -1,12 +1,12 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: slides help.markup math arrays hashtables namespaces sequences
-kernel sequences parser memoize io.encodings.binary locals
-kernel.private help.vocabs assocs quotations tools.vocabs
+USING: slides help.markup math arrays hashtables namespaces
+sequences kernel sequences parser memoize io.encodings.binary
+locals kernel.private help.vocabs assocs quotations
tools.annotations tools.crossref help.topics math.functions
-compiler.tree.optimizer compiler.cfg.optimizer fry ui.gadgets.panes
-tetris tetris.game combinators generalizations multiline
-sequences.private ;
+compiler.tree.optimizer compiler.cfg.optimizer fry
+ui.gadgets.panes tetris tetris.game combinators generalizations
+multiline sequences.private ;
IN: otug-talk
: $tetris ( element -- )
diff --git a/extra/pair-methods/authors.txt b/extra/pair-methods/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/pair-methods/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/pair-methods/pair-methods-tests.factor b/extra/pair-methods/pair-methods-tests.factor
new file mode 100644
index 0000000000..f88ca966aa
--- /dev/null
+++ b/extra/pair-methods/pair-methods-tests.factor
@@ -0,0 +1,43 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors pair-methods classes kernel sequences tools.test ;
+IN: pair-methods.tests
+
+TUPLE: thang ;
+
+TUPLE: foom < thang ;
+TUPLE: barm < foom ;
+
+TUPLE: zim < thang ;
+TUPLE: zang < zim ;
+
+: class-names ( a b prefix -- string )
+ [ [ class name>> ] bi@ "-" glue ] dip prepend ;
+
+PAIR-GENERIC: blibble ( a b -- c )
+
+PAIR-M: thang thang blibble
+ "vanilla " class-names ;
+
+PAIR-M: foom thang blibble
+ "chocolate " class-names ;
+
+PAIR-M: barm thang blibble
+ "strawberry " class-names ;
+
+PAIR-M: barm zim blibble
+ "coconut " class-names ;
+
+[ "vanilla zang-zim" ] [ zim new zang new blibble ] unit-test
+
+! args automatically swap to match most specific method
+[ "chocolate foom-zim" ] [ foom new zim new blibble ] unit-test
+[ "chocolate foom-zim" ] [ zim new foom new blibble ] unit-test
+
+[ "strawberry barm-barm" ] [ barm new barm new blibble ] unit-test
+[ "strawberry barm-foom" ] [ barm new foom new blibble ] unit-test
+[ "strawberry barm-foom" ] [ foom new barm new blibble ] unit-test
+
+[ "coconut barm-zang" ] [ zang new barm new blibble ] unit-test
+[ "coconut barm-zim" ] [ barm new zim new blibble ] unit-test
+
+[ 1 2 blibble ] [ no-pair-method? ] must-fail-with
diff --git a/extra/pair-methods/pair-methods.factor b/extra/pair-methods/pair-methods.factor
new file mode 100644
index 0000000000..d44d5bce78
--- /dev/null
+++ b/extra/pair-methods/pair-methods.factor
@@ -0,0 +1,57 @@
+! (c)2009 Joe Groff bsd license
+USING: arrays assocs classes classes.tuple.private combinators
+effects.parser generic.parser kernel math math.order parser
+quotations sequences sorting words ;
+IN: pair-methods
+
+ERROR: no-pair-method a b generic ;
+
+: ?swap ( a b ? -- a/b b/a )
+ [ swap ] when ;
+
+: method-sort-key ( pair -- key )
+ first2 [ tuple-layout third ] bi@ + ;
+
+: pair-match-condition ( pair -- quot )
+ first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence
+ [ 2dup ] [ bi* and ] surround ;
+
+: pair-method-cond ( pair quot -- array )
+ [ pair-match-condition ] [ ] bi* 2array ;
+
+: sorted-pair-methods ( word -- alist )
+ "pair-generic-methods" word-prop >alist
+ [ [ first method-sort-key ] bi@ >=< ] sort ;
+
+: pair-generic-definition ( word -- def )
+ [ sorted-pair-methods [ first2 pair-method-cond ] map ]
+ [ [ no-pair-method ] curry suffix ] bi 1quotation
+ [ 2dup [ class ] bi@ <=> +gt+ eq? ?swap ] [ cond ] surround ;
+
+: make-pair-generic ( word -- )
+ dup pair-generic-definition define ;
+
+: define-pair-generic ( word effect -- )
+ [ swap set-stack-effect ]
+ [ drop H{ } clone "pair-generic-methods" set-word-prop ]
+ [ drop make-pair-generic ] 2tri ;
+
+: (PAIR-GENERIC:) ( -- )
+ CREATE-GENERIC complete-effect define-pair-generic ;
+
+SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ;
+
+: define-pair-method ( a b pair-generic definition -- )
+ [ 2array ] 2dip swap
+ [ "pair-generic-methods" word-prop [ swap ] dip set-at ]
+ [ make-pair-generic ] bi ;
+
+: ?prefix-swap ( quot ? -- quot' )
+ [ \ swap prefix ] when ;
+
+: (PAIR-M:) ( -- )
+ scan-word scan-word 2dup <=> +gt+ eq? [
+ ?swap scan-word parse-definition
+ ] keep ?prefix-swap define-pair-method ;
+
+SYNTAX: PAIR-M: (PAIR-M:) ;
diff --git a/extra/pair-methods/summary.txt b/extra/pair-methods/summary.txt
new file mode 100644
index 0000000000..823bc712f6
--- /dev/null
+++ b/extra/pair-methods/summary.txt
@@ -0,0 +1 @@
+Order-insensitive double dispatch generics
diff --git a/extra/pair-rocket/authors.txt b/extra/pair-rocket/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/pair-rocket/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/pair-rocket/pair-rocket-docs.factor b/extra/pair-rocket/pair-rocket-docs.factor
new file mode 100644
index 0000000000..d66df62347
--- /dev/null
+++ b/extra/pair-rocket/pair-rocket-docs.factor
@@ -0,0 +1,15 @@
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax multiline ;
+IN: pair-rocket
+
+HELP: =>
+{ $syntax "a => b" }
+{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." }
+{ $examples
+{ $unchecked-example <" USING: pair-rocket prettyprint ;
+
+H{ "foo" => 1 "bar" => 2 } .
+"> <" H{ { "foo" 1 } { "bar" 2 } } "> }
+}
+;
+
diff --git a/extra/pair-rocket/pair-rocket-tests.factor b/extra/pair-rocket/pair-rocket-tests.factor
new file mode 100644
index 0000000000..695e50ea7e
--- /dev/null
+++ b/extra/pair-rocket/pair-rocket-tests.factor
@@ -0,0 +1,10 @@
+! (c)2009 Joe Groff bsd license
+USING: kernel pair-rocket tools.test ;
+IN: pair-rocket.tests
+
+[ { "a" 1 } ] [ "a" => 1 ] unit-test
+[ { { "a" } { 1 } } ] [ { "a" } => { 1 } ] unit-test
+[ { drop 1 } ] [ drop => 1 ] unit-test
+
+[ H{ { "zippity" 5 } { "doo" 2 } { "dah" 7 } } ]
+[ H{ "zippity" => 5 "doo" => 2 "dah" => 7 } ] unit-test
diff --git a/extra/pair-rocket/pair-rocket.factor b/extra/pair-rocket/pair-rocket.factor
new file mode 100644
index 0000000000..3bd8a098f6
--- /dev/null
+++ b/extra/pair-rocket/pair-rocket.factor
@@ -0,0 +1,6 @@
+! (c)2009 Joe Groff bsd license
+USING: arrays kernel parser sequences ;
+IN: pair-rocket
+
+SYNTAX: => dup pop scan-object 2array parsed ;
+
diff --git a/extra/pair-rocket/summary.txt b/extra/pair-rocket/summary.txt
new file mode 100644
index 0000000000..79c8d60149
--- /dev/null
+++ b/extra/pair-rocket/summary.txt
@@ -0,0 +1 @@
+H{ "foo" => 1 "bar" => 2 } style literal syntax
diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor
index 99e8099f38..030d0a2a73 100755
--- a/extra/parser-combinators/parser-combinators.factor
+++ b/extra/parser-combinators/parser-combinators.factor
@@ -76,7 +76,7 @@ M: satisfy-parser parse ( input parser -- list )
over empty? [
2drop nil
] [
- quot>> [ unclip-slice dup ] dip call
+ quot>> [ unclip-slice dup ] dip call( char -- ? )
[ swap <parse-results> ] [ 2drop nil ] if
] if ;
diff --git a/extra/partial-continuations/partial-continuations-tests.factor b/extra/partial-continuations/partial-continuations-tests.factor
index 7e876b0934..d6fdefd1aa 100644
--- a/extra/partial-continuations/partial-continuations-tests.factor
+++ b/extra/partial-continuations/partial-continuations-tests.factor
@@ -7,7 +7,7 @@ SYMBOL: sum
: range ( r from to -- n )
over - 1 + rot [
-rot [ over + pick call drop ] each 2drop f
- ] bshift 2nip ;
+ ] bshift 2nip ; inline
[ 55 ] [
0 sum set
diff --git a/extra/partial-continuations/partial-continuations.factor b/extra/partial-continuations/partial-continuations.factor
index 7ec294ca2e..829679570e 100755
--- a/extra/partial-continuations/partial-continuations.factor
+++ b/extra/partial-continuations/partial-continuations.factor
@@ -4,7 +4,7 @@ IN: partial-continuations
USING: kernel continuations arrays sequences quotations ;
: breset ( quot -- )
- [ 1array swap keep first continue-with ] callcc1 nip ;
+ [ 1array swap keep first continue-with ] callcc1 nip ; inline
: (bshift) ( v r k -- obj )
[ dup first -rot ] dip
diff --git a/extra/peg-lexer/peg-lexer.factor b/extra/peg-lexer/peg-lexer.factor
index 90d2e0e34c..eff0043ac3 100644
--- a/extra/peg-lexer/peg-lexer.factor
+++ b/extra/peg-lexer/peg-lexer.factor
@@ -1,5 +1,6 @@
USING: hashtables assocs sequences locals math accessors multiline delegate strings
-delegate.protocols kernel peg peg.ebnf lexer namespaces combinators parser words ;
+delegate.protocols kernel peg peg.ebnf peg.private lexer namespaces combinators parser
+words ;
IN: peg-lexer
TUPLE: lex-hash hash ;
@@ -44,11 +45,11 @@ M: lex-hash at*
: parse* ( parser -- ast )
compile
[ execute [ error-stack get first throw ] unless* ] with-global-lexer
- ast>> ;
+ ast>> ; inline
: create-bnf ( name parser -- )
- reset-tokenizer [ lexer get skip-blank parse* parsed ] curry
- define-syntax ;
+ reset-tokenizer [ lexer get skip-blank parse* dup ignore? [ drop ] [ parsed ] if ] curry
+ define-syntax word make-inline ;
SYNTAX: ON-BNF:
CREATE-WORD reset-tokenizer ";ON-BNF" parse-multiline-string parse-ebnf
diff --git a/extra/peg-lexer/tags.txt b/extra/peg-lexer/tags.txt
index 47619a17f8..44385cf3b7 100644
--- a/extra/peg-lexer/tags.txt
+++ b/extra/peg-lexer/tags.txt
@@ -1 +1,2 @@
-reflection
\ No newline at end of file
+extensions
+reflection
diff --git a/extra/peg/javascript/javascript-tests.factor b/extra/peg/javascript/javascript-tests.factor
index 0d6899714d..69223a418d 100644
--- a/extra/peg/javascript/javascript-tests.factor
+++ b/extra/peg/javascript/javascript-tests.factor
@@ -4,8 +4,6 @@
USING: kernel tools.test peg.javascript peg.javascript.ast accessors ;
IN: peg.javascript.tests
-\ parse-javascript must-infer
-
{ T{ ast-begin f V{ T{ ast-number f 123 } } } } [
"123;" parse-javascript
] unit-test
\ No newline at end of file
diff --git a/extra/peg/javascript/parser/parser-tests.factor b/extra/peg/javascript/parser/parser-tests.factor
index a2c50952be..a521202b1c 100644
--- a/extra/peg/javascript/parser/parser-tests.factor
+++ b/extra/peg/javascript/parser/parser-tests.factor
@@ -5,8 +5,6 @@ USING: kernel tools.test peg peg.javascript.ast peg.javascript.parser
accessors multiline sequences math peg.ebnf ;
IN: peg.javascript.parser.tests
-\ javascript must-infer
-
{
T{
ast-begin
diff --git a/extra/peg/javascript/tokenizer/tokenizer-tests.factor b/extra/peg/javascript/tokenizer/tokenizer-tests.factor
index f0080a31b2..0fbd55ccfd 100644
--- a/extra/peg/javascript/tokenizer/tokenizer-tests.factor
+++ b/extra/peg/javascript/tokenizer/tokenizer-tests.factor
@@ -4,8 +4,6 @@
USING: kernel tools.test peg peg.javascript.ast peg.javascript.tokenizer accessors ;
IN: peg.javascript.tokenizer.tests
-\ tokenize-javascript must-infer
-
{
V{
T{ ast-number f 123 }
diff --git a/extra/poker/arrays/arrays.factor b/extra/poker/arrays/arrays.factor
new file mode 100644
index 0000000000..bf758f166a
--- /dev/null
+++ b/extra/poker/arrays/arrays.factor
@@ -0,0 +1,1018 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+IN: poker.arrays
+
+! This is a lookup table for all flush hands. A zero means that specific
+! combination is not possible with this type of hand.
+CONSTANT: flushes-table
+{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 9 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 1599 0 0 0 0 0 0 0 1598 0 0 0 1597 0 1596 8 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 1595 0 0 0 0 0 0 0 1594 0 0 0 1593 0 1592 1591 0 0 0 0 0 0 0 0 1590
+0 0 0 1589 0 1588 1587 0 0 0 0 1586 0 1585 1584 0 0 1583 1582 0 7 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 1581 0 0 0 0 0 0 0 1580 0 0 0 1579 0 1578 1577 0 0 0 0 0
+0 0 0 1576 0 0 0 1575 0 1574 1573 0 0 0 0 1572 0 1571 1570 0 0 1569 1568 0 1567
+0 0 0 0 0 0 0 0 0 0 1566 0 0 0 1565 0 1564 1563 0 0 0 0 1562 0 1561 1560 0 0
+1559 1558 0 1557 0 0 0 0 0 0 1556 0 1555 1554 0 0 1553 1552 0 1551 0 0 0 0 1550
+1549 0 1548 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1547 0 0 0 0 0
+0 0 1546 0 0 0 1545 0 1544 1543 0 0 0 0 0 0 0 0 1542 0 0 0 1541 0 1540 1539 0 0
+0 0 1538 0 1537 1536 0 0 1535 1534 0 1533 0 0 0 0 0 0 0 0 0 0 1532 0 0 0 1531 0
+1530 1529 0 0 0 0 1528 0 1527 1526 0 0 1525 1524 0 1523 0 0 0 0 0 0 1522 0 1521
+1520 0 0 1519 1518 0 1517 0 0 0 0 1516 1515 0 1514 0 0 0 1513 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 1512 0 0 0 1511 0 1510 1509 0 0 0 0 1508 0 1507 1506 0 0 1505 1504 0
+1503 0 0 0 0 0 0 1502 0 1501 1500 0 0 1499 1498 0 1497 0 0 0 0 1496 1495 0 1494
+0 0 0 1493 0 0 0 0 0 0 0 0 0 0 1492 0 1491 1490 0 0 1489 1488 0 1487 0 0 0 0
+1486 1485 0 1484 0 0 0 1483 0 0 0 0 0 0 0 0 1482 1481 0 1480 0 0 0 1479 0 0 0 0
+0 0 0 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1478 0 0 0
+0 0 0 0 1477 0 0 0 1476 0 1475 1474 0 0 0 0 0 0 0 0 1473 0 0 0 1472 0 1471 1470
+0 0 0 0 1469 0 1468 1467 0 0 1466 1465 0 1464 0 0 0 0 0 0 0 0 0 0 1463 0 0 0
+1462 0 1461 1460 0 0 0 0 1459 0 1458 1457 0 0 1456 1455 0 1454 0 0 0 0 0 0 1453
+0 1452 1451 0 0 1450 1449 0 1448 0 0 0 0 1447 1446 0 1445 0 0 0 1444 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 1443 0 0 0 1442 0 1441 1440 0 0 0 0 1439 0 1438 1437 0 0 1436
+1435 0 1434 0 0 0 0 0 0 1433 0 1432 1431 0 0 1430 1429 0 1428 0 0 0 0 1427 1426
+0 1425 0 0 0 1424 0 0 0 0 0 0 0 0 0 0 1423 0 1422 1421 0 0 1420 1419 0 1418 0 0
+0 0 1417 1416 0 1415 0 0 0 1414 0 0 0 0 0 0 0 0 1413 1412 0 1411 0 0 0 1410 0 0
+0 0 0 0 0 1409 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1408 0 0 0 1407 0
+1406 1405 0 0 0 0 1404 0 1403 1402 0 0 1401 1400 0 1399 0 0 0 0 0 0 1398 0 1397
+1396 0 0 1395 1394 0 1393 0 0 0 0 1392 1391 0 1390 0 0 0 1389 0 0 0 0 0 0 0 0 0
+0 1388 0 1387 1386 0 0 1385 1384 0 1383 0 0 0 0 1382 1381 0 1380 0 0 0 1379 0 0
+0 0 0 0 0 0 1378 1377 0 1376 0 0 0 1375 0 0 0 0 0 0 0 1374 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 1373 0 1372 1371 0 0 1370 1369 0 1368 0 0 0 0 1367 1366 0 1365
+0 0 0 1364 0 0 0 0 0 0 0 0 1363 1362 0 1361 0 0 0 1360 0 0 0 0 0 0 0 1359 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 1358 1357 0 1356 0 0 0 1355 0 0 0 0 0 0 0 1354 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1353 0 0 0 0 0 0 0 1352 0 0 0 1351 0 1350
+1349 0 0 0 0 0 0 0 0 1348 0 0 0 1347 0 1346 1345 0 0 0 0 1344 0 1343 1342 0 0
+1341 1340 0 1339 0 0 0 0 0 0 0 0 0 0 1338 0 0 0 1337 0 1336 1335 0 0 0 0 1334 0
+1333 1332 0 0 1331 1330 0 1329 0 0 0 0 0 0 1328 0 1327 1326 0 0 1325 1324 0
+1323 0 0 0 0 1322 1321 0 1320 0 0 0 1319 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1318 0 0 0
+1317 0 1316 1315 0 0 0 0 1314 0 1313 1312 0 0 1311 1310 0 1309 0 0 0 0 0 0 1308
+0 1307 1306 0 0 1305 1304 0 1303 0 0 0 0 1302 1301 0 1300 0 0 0 1299 0 0 0 0 0
+0 0 0 0 0 1298 0 1297 1296 0 0 1295 1294 0 1293 0 0 0 0 1292 1291 0 1290 0 0 0
+1289 0 0 0 0 0 0 0 0 1288 1287 0 1286 0 0 0 1285 0 0 0 0 0 0 0 1284 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1283 0 0 0 1282 0 1281 1280 0 0 0 0 1279 0 1278
+1277 0 0 1276 1275 0 1274 0 0 0 0 0 0 1273 0 1272 1271 0 0 1270 1269 0 1268 0 0
+0 0 1267 1266 0 1265 0 0 0 1264 0 0 0 0 0 0 0 0 0 0 1263 0 1262 1261 0 0 1260
+1259 0 1258 0 0 0 0 1257 1256 0 1255 0 0 0 1254 0 0 0 0 0 0 0 0 1253 1252 0
+1251 0 0 0 1250 0 0 0 0 0 0 0 1249 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1248 0
+1247 1246 0 0 1245 1244 0 1243 0 0 0 0 1242 1241 0 1240 0 0 0 1239 0 0 0 0 0 0
+0 0 1238 1237 0 1236 0 0 0 1235 0 0 0 0 0 0 0 1234 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 1233 1232 0 1231 0 0 0 1230 0 0 0 0 0 0 0 1229 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 1228 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 1227 0 0 0 1226 0 1225 1224 0 0 0 0 1223 0 1222 1221 0 0 1220 1219 0 1218 0
+0 0 0 0 0 1217 0 1216 1215 0 0 1214 1213 0 1212 0 0 0 0 1211 1210 0 1209 0 0 0
+1208 0 0 0 0 0 0 0 0 0 0 1207 0 1206 1205 0 0 1204 1203 0 1202 0 0 0 0 1201
+1200 0 1199 0 0 0 1198 0 0 0 0 0 0 0 0 1197 1196 0 1195 0 0 0 1194 0 0 0 0 0 0
+0 1193 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1192 0 1191 1190 0 0 1189 1188 0
+1187 0 0 0 0 1186 1185 0 1184 0 0 0 1183 0 0 0 0 0 0 0 0 1182 1181 0 1180 0 0 0
+1179 0 0 0 0 0 0 0 1178 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1177 1176 0 1175 0 0 0
+1174 0 0 0 0 0 0 0 1173 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1172 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1171 0 1170 1169 0 0 1168 1167
+0 1166 0 0 0 0 1165 1164 0 1163 0 0 0 1162 0 0 0 0 0 0 0 0 1161 1160 0 1159 0 0
+0 1158 0 0 0 0 0 0 0 1157 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1156 1155 0 1154 0 0
+0 1153 0 0 0 0 0 0 0 1152 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1151 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1150 1149 0 1148 0 0 0 1147 0 0 0
+0 0 0 0 1146 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1145 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 1144 0 0 0 0 0 0 0 1143 0 0 0 1142 0 1141 1140 0 0
+0 0 0 0 0 0 1139 0 0 0 1138 0 1137 1136 0 0 0 0 1135 0 1134 1133 0 0 1132 1131
+0 1130 0 0 0 0 0 0 0 0 0 0 1129 0 0 0 1128 0 1127 1126 0 0 0 0 1125 0 1124 1123
+0 0 1122 1121 0 1120 0 0 0 0 0 0 1119 0 1118 1117 0 0 1116 1115 0 1114 0 0 0 0
+1113 1112 0 1111 0 0 0 1110 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1109 0 0 0 1108 0 1107
+1106 0 0 0 0 1105 0 1104 1103 0 0 1102 1101 0 1100 0 0 0 0 0 0 1099 0 1098 1097
+0 0 1096 1095 0 1094 0 0 0 0 1093 1092 0 1091 0 0 0 1090 0 0 0 0 0 0 0 0 0 0
+1089 0 1088 1087 0 0 1086 1085 0 1084 0 0 0 0 1083 1082 0 1081 0 0 0 1080 0 0 0
+0 0 0 0 0 1079 1078 0 1077 0 0 0 1076 0 0 0 0 0 0 0 1075 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 1074 0 0 0 1073 0 1072 1071 0 0 0 0 1070 0 1069 1068 0 0
+1067 1066 0 1065 0 0 0 0 0 0 1064 0 1063 1062 0 0 1061 1060 0 1059 0 0 0 0 1058
+1057 0 1056 0 0 0 1055 0 0 0 0 0 0 0 0 0 0 1054 0 1053 1052 0 0 1051 1050 0
+1049 0 0 0 0 1048 1047 0 1046 0 0 0 1045 0 0 0 0 0 0 0 0 1044 1043 0 1042 0 0 0
+1041 0 0 0 0 0 0 0 1040 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1039 0 1038 1037 0
+0 1036 1035 0 1034 0 0 0 0 1033 1032 0 1031 0 0 0 1030 0 0 0 0 0 0 0 0 1029
+1028 0 1027 0 0 0 1026 0 0 0 0 0 0 0 1025 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1024
+1023 0 1022 0 0 0 1021 0 0 0 0 0 0 0 1020 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1019 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1018
+0 0 0 1017 0 1016 1015 0 0 0 0 1014 0 1013 1012 0 0 1011 1010 0 1009 0 0 0 0 0
+0 1008 0 1007 1006 0 0 1005 1004 0 1003 0 0 0 0 1002 1001 0 1000 0 0 0 999 0 0
+0 0 0 0 0 0 0 0 998 0 997 996 0 0 995 994 0 993 0 0 0 0 992 991 0 990 0 0 0 989
+0 0 0 0 0 0 0 0 988 987 0 986 0 0 0 985 0 0 0 0 0 0 0 984 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 983 0 982 981 0 0 980 979 0 978 0 0 0 0 977 976 0 975 0 0 0 974 0
+0 0 0 0 0 0 0 973 972 0 971 0 0 0 970 0 0 0 0 0 0 0 969 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 968 967 0 966 0 0 0 965 0 0 0 0 0 0 0 964 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+963 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 962 0
+961 960 0 0 959 958 0 957 0 0 0 0 956 955 0 954 0 0 0 953 0 0 0 0 0 0 0 0 952
+951 0 950 0 0 0 949 0 0 0 0 0 0 0 948 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 947 946 0
+945 0 0 0 944 0 0 0 0 0 0 0 943 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 942 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 941 940 0 939 0 0 0 938 0 0 0
+0 0 0 0 937 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 936 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 935 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 934 0 0 0 933 0 932 931 0 0 0 0 930 0 929 928 0 0 927 926 0 925 0 0
+0 0 0 0 924 0 923 922 0 0 921 920 0 919 0 0 0 0 918 917 0 916 0 0 0 915 0 0 0 0
+0 0 0 0 0 0 914 0 913 912 0 0 911 910 0 909 0 0 0 0 908 907 0 906 0 0 0 905 0 0
+0 0 0 0 0 0 904 903 0 902 0 0 0 901 0 0 0 0 0 0 0 900 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 899 0 898 897 0 0 896 895 0 894 0 0 0 0 893 892 0 891 0 0 0 890 0 0 0
+0 0 0 0 0 889 888 0 887 0 0 0 886 0 0 0 0 0 0 0 885 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 884 883 0 882 0 0 0 881 0 0 0 0 0 0 0 880 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 879
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 878 0 877
+876 0 0 875 874 0 873 0 0 0 0 872 871 0 870 0 0 0 869 0 0 0 0 0 0 0 0 868 867 0
+866 0 0 0 865 0 0 0 0 0 0 0 864 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 863 862 0 861 0
+0 0 860 0 0 0 0 0 0 0 859 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 858 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 857 856 0 855 0 0 0 854 0 0 0 0 0 0
+0 853 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 852 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 851 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+850 0 849 848 0 0 847 846 0 845 0 0 0 0 844 843 0 842 0 0 0 841 0 0 0 0 0 0 0 0
+840 839 0 838 0 0 0 837 0 0 0 0 0 0 0 836 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 835
+834 0 833 0 0 0 832 0 0 0 0 0 0 0 831 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 830 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 829 828 0 827 0 0 0 826
+0 0 0 0 0 0 0 825 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 824 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 823 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 822 821 0 820 0 0 0 819 0 0 0 0 0 0 0 818 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+817 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 816 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 10 0 0 0 0 0 0 0 815 0 0 0 814 0 813 812 0 0 0 0 0 0 0 0 811 0 0 0 810 0 809
+808 0 0 0 0 807 0 806 805 0 0 804 803 0 802 0 0 0 0 0 0 0 0 0 0 801 0 0 0 800 0
+799 798 0 0 0 0 797 0 796 795 0 0 794 793 0 792 0 0 0 0 0 0 791 0 790 789 0 0
+788 787 0 786 0 0 0 0 785 784 0 783 0 0 0 782 0 0 0 0 0 0 0 0 0 0 0 0 0 0 781 0
+0 0 780 0 779 778 0 0 0 0 777 0 776 775 0 0 774 773 0 772 0 0 0 0 0 0 771 0 770
+769 0 0 768 767 0 766 0 0 0 0 765 764 0 763 0 0 0 762 0 0 0 0 0 0 0 0 0 0 761 0
+760 759 0 0 758 757 0 756 0 0 0 0 755 754 0 753 0 0 0 752 0 0 0 0 0 0 0 0 751
+750 0 749 0 0 0 748 0 0 0 0 0 0 0 747 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 746 0 0 0 745 0 744 743 0 0 0 0 742 0 741 740 0 0 739 738 0 737 0 0 0 0 0 0
+736 0 735 734 0 0 733 732 0 731 0 0 0 0 730 729 0 728 0 0 0 727 0 0 0 0 0 0 0 0
+0 0 726 0 725 724 0 0 723 722 0 721 0 0 0 0 720 719 0 718 0 0 0 717 0 0 0 0 0 0
+0 0 716 715 0 714 0 0 0 713 0 0 0 0 0 0 0 712 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 711 0 710 709 0 0 708 707 0 706 0 0 0 0 705 704 0 703 0 0 0 702 0 0 0 0 0 0 0
+0 701 700 0 699 0 0 0 698 0 0 0 0 0 0 0 697 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 696
+695 0 694 0 0 0 693 0 0 0 0 0 0 0 692 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 691 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 690 0 0 0
+689 0 688 687 0 0 0 0 686 0 685 684 0 0 683 682 0 681 0 0 0 0 0 0 680 0 679 678
+0 0 677 676 0 675 0 0 0 0 674 673 0 672 0 0 0 671 0 0 0 0 0 0 0 0 0 0 670 0 669
+668 0 0 667 666 0 665 0 0 0 0 664 663 0 662 0 0 0 661 0 0 0 0 0 0 0 0 660 659 0
+658 0 0 0 657 0 0 0 0 0 0 0 656 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 655 0 654
+653 0 0 652 651 0 650 0 0 0 0 649 648 0 647 0 0 0 646 0 0 0 0 0 0 0 0 645 644 0
+643 0 0 0 642 0 0 0 0 0 0 0 641 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 640 639 0 638 0
+0 0 637 0 0 0 0 0 0 0 636 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 635 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 634 0 633 632 0 0 631 630 0 629
+0 0 0 0 628 627 0 626 0 0 0 625 0 0 0 0 0 0 0 0 624 623 0 622 0 0 0 621 0 0 0 0
+0 0 0 620 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 619 618 0 617 0 0 0 616 0 0 0 0 0 0 0
+615 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 614 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 613 612 0 611 0 0 0 610 0 0 0 0 0 0 0 609 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 608 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+607 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 606 0 0 0 605 0
+604 603 0 0 0 0 602 0 601 600 0 0 599 598 0 597 0 0 0 0 0 0 596 0 595 594 0 0
+593 592 0 591 0 0 0 0 590 589 0 588 0 0 0 587 0 0 0 0 0 0 0 0 0 0 586 0 585 584
+0 0 583 582 0 581 0 0 0 0 580 579 0 578 0 0 0 577 0 0 0 0 0 0 0 0 576 575 0 574
+0 0 0 573 0 0 0 0 0 0 0 572 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 571 0 570 569 0
+0 568 567 0 566 0 0 0 0 565 564 0 563 0 0 0 562 0 0 0 0 0 0 0 0 561 560 0 559 0
+0 0 558 0 0 0 0 0 0 0 557 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 556 555 0 554 0 0 0
+553 0 0 0 0 0 0 0 552 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 551 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 550 0 549 548 0 0 547 546 0 545 0 0
+0 0 544 543 0 542 0 0 0 541 0 0 0 0 0 0 0 0 540 539 0 538 0 0 0 537 0 0 0 0 0 0
+0 536 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 535 534 0 533 0 0 0 532 0 0 0 0 0 0 0 531
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 530 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 529 528 0 527 0 0 0 526 0 0 0 0 0 0 0 525 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 524 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 523
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 522 0 521 520 0 0 519 518 0
+517 0 0 0 0 516 515 0 514 0 0 0 513 0 0 0 0 0 0 0 0 512 511 0 510 0 0 0 509 0 0
+0 0 0 0 0 508 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 507 506 0 505 0 0 0 504 0 0 0 0 0
+0 0 503 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 502 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 501 500 0 499 0 0 0 498 0 0 0 0 0 0 0 497 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 496 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 495 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 494 493 0 492 0 0 0 491
+0 0 0 0 0 0 0 490 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 489 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 488 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 487 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 486 0 0 0 485 0 484 483 0 0 0 0 482 0 481
+480 0 0 479 478 0 477 0 0 0 0 0 0 476 0 475 474 0 0 473 472 0 471 0 0 0 0 470
+469 0 468 0 0 0 467 0 0 0 0 0 0 0 0 0 0 466 0 465 464 0 0 463 462 0 461 0 0 0 0
+460 459 0 458 0 0 0 457 0 0 0 0 0 0 0 0 456 455 0 454 0 0 0 453 0 0 0 0 0 0 0
+452 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 451 0 450 449 0 0 448 447 0 446 0 0 0 0
+445 444 0 443 0 0 0 442 0 0 0 0 0 0 0 0 441 440 0 439 0 0 0 438 0 0 0 0 0 0 0
+437 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 436 435 0 434 0 0 0 433 0 0 0 0 0 0 0 432 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 431 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 430 0 429 428 0 0 427 426 0 425 0 0 0 0 424 423 0 422 0 0 0
+421 0 0 0 0 0 0 0 0 420 419 0 418 0 0 0 417 0 0 0 0 0 0 0 416 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 415 414 0 413 0 0 0 412 0 0 0 0 0 0 0 411 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 410 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 409
+408 0 407 0 0 0 406 0 0 0 0 0 0 0 405 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 404 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 403 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 402 0 401 400 0 0 399 398 0 397 0 0 0 0 396 395 0
+394 0 0 0 393 0 0 0 0 0 0 0 0 392 391 0 390 0 0 0 389 0 0 0 0 0 0 0 388 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 387 386 0 385 0 0 0 384 0 0 0 0 0 0 0 383 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 382 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 381 380 0 379 0 0 0 378 0 0 0 0 0 0 0 377 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 376
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 375 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 374 373 0 372 0 0 0 371 0 0 0 0 0 0 0 370 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 369 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 368 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 367 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 366 0 365 364 0 0 363 362 0 361 0 0 0 0 360 359 0 358 0 0 0 357 0 0 0 0 0
+0 0 0 356 355 0 354 0 0 0 353 0 0 0 0 0 0 0 352 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+351 350 0 349 0 0 0 348 0 0 0 0 0 0 0 347 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 346 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 345 344 0 343 0 0 0
+342 0 0 0 0 0 0 0 341 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 340 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 339 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 338 337 0 336 0 0 0 335 0 0 0 0 0 0 0 334 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 333 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 332 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 331 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 330 329 0 328 0 0 0
+327 0 0 0 0 0 0 0 326 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 325 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 324 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 323 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 1 }
+
+! This is a lookup table for all non-flush hands consisting of five unique
+! ranks (i.e. either Straights or High Card hands). A zero means that specific
+! combination is not possible with this type of hand.
+CONSTANT: unique5-table
+{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1608 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 7462 0 0 0 0 0 0 0 7461 0 0 0 7460 0 7459 1607 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 7458 0 0 0 0 0 0 0 7457 0 0 0 7456 0 7455 7454 0 0 0 0 0 0
+0 0 7453 0 0 0 7452 0 7451 7450 0 0 0 0 7449 0 7448 7447 0 0 7446 7445 0 1606 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7444 0 0 0 0 0 0 0 7443 0 0 0 7442 0 7441
+7440 0 0 0 0 0 0 0 0 7439 0 0 0 7438 0 7437 7436 0 0 0 0 7435 0 7434 7433 0 0
+7432 7431 0 7430 0 0 0 0 0 0 0 0 0 0 7429 0 0 0 7428 0 7427 7426 0 0 0 0 7425 0
+7424 7423 0 0 7422 7421 0 7420 0 0 0 0 0 0 7419 0 7418 7417 0 0 7416 7415 0
+7414 0 0 0 0 7413 7412 0 7411 0 0 0 1605 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 7410 0 0 0 0 0 0 0 7409 0 0 0 7408 0 7407 7406 0 0 0 0 0 0 0 0 7405 0 0 0
+7404 0 7403 7402 0 0 0 0 7401 0 7400 7399 0 0 7398 7397 0 7396 0 0 0 0 0 0 0 0
+0 0 7395 0 0 0 7394 0 7393 7392 0 0 0 0 7391 0 7390 7389 0 0 7388 7387 0 7386 0
+0 0 0 0 0 7385 0 7384 7383 0 0 7382 7381 0 7380 0 0 0 0 7379 7378 0 7377 0 0 0
+7376 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7375 0 0 0 7374 0 7373 7372 0 0 0 0 7371 0
+7370 7369 0 0 7368 7367 0 7366 0 0 0 0 0 0 7365 0 7364 7363 0 0 7362 7361 0
+7360 0 0 0 0 7359 7358 0 7357 0 0 0 7356 0 0 0 0 0 0 0 0 0 0 7355 0 7354 7353 0
+0 7352 7351 0 7350 0 0 0 0 7349 7348 0 7347 0 0 0 7346 0 0 0 0 0 0 0 0 7345
+7344 0 7343 0 0 0 7342 0 0 0 0 0 0 0 1604 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 7341 0 0 0 0 0 0 0 7340 0 0 0 7339 0 7338 7337 0 0 0 0 0
+0 0 0 7336 0 0 0 7335 0 7334 7333 0 0 0 0 7332 0 7331 7330 0 0 7329 7328 0 7327
+0 0 0 0 0 0 0 0 0 0 7326 0 0 0 7325 0 7324 7323 0 0 0 0 7322 0 7321 7320 0 0
+7319 7318 0 7317 0 0 0 0 0 0 7316 0 7315 7314 0 0 7313 7312 0 7311 0 0 0 0 7310
+7309 0 7308 0 0 0 7307 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7306 0 0 0 7305 0 7304 7303
+0 0 0 0 7302 0 7301 7300 0 0 7299 7298 0 7297 0 0 0 0 0 0 7296 0 7295 7294 0 0
+7293 7292 0 7291 0 0 0 0 7290 7289 0 7288 0 0 0 7287 0 0 0 0 0 0 0 0 0 0 7286 0
+7285 7284 0 0 7283 7282 0 7281 0 0 0 0 7280 7279 0 7278 0 0 0 7277 0 0 0 0 0 0
+0 0 7276 7275 0 7274 0 0 0 7273 0 0 0 0 0 0 0 7272 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 7271 0 0 0 7270 0 7269 7268 0 0 0 0 7267 0 7266 7265 0 0 7264
+7263 0 7262 0 0 0 0 0 0 7261 0 7260 7259 0 0 7258 7257 0 7256 0 0 0 0 7255 7254
+0 7253 0 0 0 7252 0 0 0 0 0 0 0 0 0 0 7251 0 7250 7249 0 0 7248 7247 0 7246 0 0
+0 0 7245 7244 0 7243 0 0 0 7242 0 0 0 0 0 0 0 0 7241 7240 0 7239 0 0 0 7238 0 0
+0 0 0 0 0 7237 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7236 0 7235 7234 0 0 7233
+7232 0 7231 0 0 0 0 7230 7229 0 7228 0 0 0 7227 0 0 0 0 0 0 0 0 7226 7225 0
+7224 0 0 0 7223 0 0 0 0 0 0 0 7222 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7221 7220 0
+7219 0 0 0 7218 0 0 0 0 0 0 0 7217 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1603 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 7216 0 0 0 0 0 0 0 7215 0 0 0 7214 0 7213 7212 0 0 0 0 0 0 0 0 7211 0 0 0
+7210 0 7209 7208 0 0 0 0 7207 0 7206 7205 0 0 7204 7203 0 7202 0 0 0 0 0 0 0 0
+0 0 7201 0 0 0 7200 0 7199 7198 0 0 0 0 7197 0 7196 7195 0 0 7194 7193 0 7192 0
+0 0 0 0 0 7191 0 7190 7189 0 0 7188 7187 0 7186 0 0 0 0 7185 7184 0 7183 0 0 0
+7182 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7181 0 0 0 7180 0 7179 7178 0 0 0 0 7177 0
+7176 7175 0 0 7174 7173 0 7172 0 0 0 0 0 0 7171 0 7170 7169 0 0 7168 7167 0
+7166 0 0 0 0 7165 7164 0 7163 0 0 0 7162 0 0 0 0 0 0 0 0 0 0 7161 0 7160 7159 0
+0 7158 7157 0 7156 0 0 0 0 7155 7154 0 7153 0 0 0 7152 0 0 0 0 0 0 0 0 7151
+7150 0 7149 0 0 0 7148 0 0 0 0 0 0 0 7147 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 7146 0 0 0 7145 0 7144 7143 0 0 0 0 7142 0 7141 7140 0 0 7139 7138 0 7137
+0 0 0 0 0 0 7136 0 7135 7134 0 0 7133 7132 0 7131 0 0 0 0 7130 7129 0 7128 0 0
+0 7127 0 0 0 0 0 0 0 0 0 0 7126 0 7125 7124 0 0 7123 7122 0 7121 0 0 0 0 7120
+7119 0 7118 0 0 0 7117 0 0 0 0 0 0 0 0 7116 7115 0 7114 0 0 0 7113 0 0 0 0 0 0
+0 7112 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7111 0 7110 7109 0 0 7108 7107 0
+7106 0 0 0 0 7105 7104 0 7103 0 0 0 7102 0 0 0 0 0 0 0 0 7101 7100 0 7099 0 0 0
+7098 0 0 0 0 0 0 0 7097 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7096 7095 0 7094 0 0 0
+7093 0 0 0 0 0 0 0 7092 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7091 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7090 0 0 0 7089 0 7088
+7087 0 0 0 0 7086 0 7085 7084 0 0 7083 7082 0 7081 0 0 0 0 0 0 7080 0 7079 7078
+0 0 7077 7076 0 7075 0 0 0 0 7074 7073 0 7072 0 0 0 7071 0 0 0 0 0 0 0 0 0 0
+7070 0 7069 7068 0 0 7067 7066 0 7065 0 0 0 0 7064 7063 0 7062 0 0 0 7061 0 0 0
+0 0 0 0 0 7060 7059 0 7058 0 0 0 7057 0 0 0 0 0 0 0 7056 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 7055 0 7054 7053 0 0 7052 7051 0 7050 0 0 0 0 7049 7048 0 7047 0
+0 0 7046 0 0 0 0 0 0 0 0 7045 7044 0 7043 0 0 0 7042 0 0 0 0 0 0 0 7041 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 7040 7039 0 7038 0 0 0 7037 0 0 0 0 0 0 0 7036 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 7035 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 7034 0 7033 7032 0 0 7031 7030 0 7029 0 0 0 0 7028 7027 0 7026
+0 0 0 7025 0 0 0 0 0 0 0 0 7024 7023 0 7022 0 0 0 7021 0 0 0 0 0 0 0 7020 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 7019 7018 0 7017 0 0 0 7016 0 0 0 0 0 0 0 7015 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 7014 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 7013 7012 0 7011 0 0 0 7010 0 0 0 0 0 0 0 7009 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 7008 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+1602 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 7007 0 0 0 0 0 0 0 7006 0 0 0 7005 0 7004 7003 0 0 0 0 0 0 0 0 7002 0 0 0
+7001 0 7000 6999 0 0 0 0 6998 0 6997 6996 0 0 6995 6994 0 6993 0 0 0 0 0 0 0 0
+0 0 6992 0 0 0 6991 0 6990 6989 0 0 0 0 6988 0 6987 6986 0 0 6985 6984 0 6983 0
+0 0 0 0 0 6982 0 6981 6980 0 0 6979 6978 0 6977 0 0 0 0 6976 6975 0 6974 0 0 0
+6973 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6972 0 0 0 6971 0 6970 6969 0 0 0 0 6968 0
+6967 6966 0 0 6965 6964 0 6963 0 0 0 0 0 0 6962 0 6961 6960 0 0 6959 6958 0
+6957 0 0 0 0 6956 6955 0 6954 0 0 0 6953 0 0 0 0 0 0 0 0 0 0 6952 0 6951 6950 0
+0 6949 6948 0 6947 0 0 0 0 6946 6945 0 6944 0 0 0 6943 0 0 0 0 0 0 0 0 6942
+6941 0 6940 0 0 0 6939 0 0 0 0 0 0 0 6938 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 6937 0 0 0 6936 0 6935 6934 0 0 0 0 6933 0 6932 6931 0 0 6930 6929 0 6928
+0 0 0 0 0 0 6927 0 6926 6925 0 0 6924 6923 0 6922 0 0 0 0 6921 6920 0 6919 0 0
+0 6918 0 0 0 0 0 0 0 0 0 0 6917 0 6916 6915 0 0 6914 6913 0 6912 0 0 0 0 6911
+6910 0 6909 0 0 0 6908 0 0 0 0 0 0 0 0 6907 6906 0 6905 0 0 0 6904 0 0 0 0 0 0
+0 6903 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6902 0 6901 6900 0 0 6899 6898 0
+6897 0 0 0 0 6896 6895 0 6894 0 0 0 6893 0 0 0 0 0 0 0 0 6892 6891 0 6890 0 0 0
+6889 0 0 0 0 0 0 0 6888 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6887 6886 0 6885 0 0 0
+6884 0 0 0 0 0 0 0 6883 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6882 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6881 0 0 0 6880 0 6879
+6878 0 0 0 0 6877 0 6876 6875 0 0 6874 6873 0 6872 0 0 0 0 0 0 6871 0 6870 6869
+0 0 6868 6867 0 6866 0 0 0 0 6865 6864 0 6863 0 0 0 6862 0 0 0 0 0 0 0 0 0 0
+6861 0 6860 6859 0 0 6858 6857 0 6856 0 0 0 0 6855 6854 0 6853 0 0 0 6852 0 0 0
+0 0 0 0 0 6851 6850 0 6849 0 0 0 6848 0 0 0 0 0 0 0 6847 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 6846 0 6845 6844 0 0 6843 6842 0 6841 0 0 0 0 6840 6839 0 6838 0
+0 0 6837 0 0 0 0 0 0 0 0 6836 6835 0 6834 0 0 0 6833 0 0 0 0 0 0 0 6832 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6831 6830 0 6829 0 0 0 6828 0 0 0 0 0 0 0 6827 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 6826 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 6825 0 6824 6823 0 0 6822 6821 0 6820 0 0 0 0 6819 6818 0 6817
+0 0 0 6816 0 0 0 0 0 0 0 0 6815 6814 0 6813 0 0 0 6812 0 0 0 0 0 0 0 6811 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 6810 6809 0 6808 0 0 0 6807 0 0 0 0 0 0 0 6806 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6805 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 6804 6803 0 6802 0 0 0 6801 0 0 0 0 0 0 0 6800 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 6799 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6798 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6797 0 0 0
+6796 0 6795 6794 0 0 0 0 6793 0 6792 6791 0 0 6790 6789 0 6788 0 0 0 0 0 0 6787
+0 6786 6785 0 0 6784 6783 0 6782 0 0 0 0 6781 6780 0 6779 0 0 0 6778 0 0 0 0 0
+0 0 0 0 0 6777 0 6776 6775 0 0 6774 6773 0 6772 0 0 0 0 6771 6770 0 6769 0 0 0
+6768 0 0 0 0 0 0 0 0 6767 6766 0 6765 0 0 0 6764 0 0 0 0 0 0 0 6763 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6762 0 6761 6760 0 0 6759 6758 0 6757 0 0 0 0 6756 6755
+0 6754 0 0 0 6753 0 0 0 0 0 0 0 0 6752 6751 0 6750 0 0 0 6749 0 0 0 0 0 0 0
+6748 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6747 6746 0 6745 0 0 0 6744 0 0 0 0 0 0 0
+6743 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6742 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 6741 0 6740 6739 0 0 6738 6737 0 6736 0 0 0 0 6735
+6734 0 6733 0 0 0 6732 0 0 0 0 0 0 0 0 6731 6730 0 6729 0 0 0 6728 0 0 0 0 0 0
+0 6727 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6726 6725 0 6724 0 0 0 6723 0 0 0 0 0 0
+0 6722 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6721 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 6720 6719 0 6718 0 0 0 6717 0 0 0 0 0 0 0 6716 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6715 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 6714 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6713 0
+6712 6711 0 0 6710 6709 0 6708 0 0 0 0 6707 6706 0 6705 0 0 0 6704 0 0 0 0 0 0
+0 0 6703 6702 0 6701 0 0 0 6700 0 0 0 0 0 0 0 6699 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6698 6697 0 6696 0 0 0 6695 0 0 0 0 0 0 0 6694 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 6693 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6692
+6691 0 6690 0 0 0 6689 0 0 0 0 0 0 0 6688 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6687 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6686 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6685 6684 0 6683 0 0 0 6682 0 0 0 0 0 0 0
+6681 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6680 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 6679 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1601
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1609 0 0 0 0 0 0 0 6678 0 0 0 6677
+0 6676 6675 0 0 0 0 0 0 0 0 6674 0 0 0 6673 0 6672 6671 0 0 0 0 6670 0 6669
+6668 0 0 6667 6666 0 6665 0 0 0 0 0 0 0 0 0 0 6664 0 0 0 6663 0 6662 6661 0 0 0
+0 6660 0 6659 6658 0 0 6657 6656 0 6655 0 0 0 0 0 0 6654 0 6653 6652 0 0 6651
+6650 0 6649 0 0 0 0 6648 6647 0 6646 0 0 0 6645 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6644 0 0 0 6643 0 6642 6641 0 0 0 0 6640 0 6639 6638 0 0 6637 6636 0 6635 0 0 0
+0 0 0 6634 0 6633 6632 0 0 6631 6630 0 6629 0 0 0 0 6628 6627 0 6626 0 0 0 6625
+0 0 0 0 0 0 0 0 0 0 6624 0 6623 6622 0 0 6621 6620 0 6619 0 0 0 0 6618 6617 0
+6616 0 0 0 6615 0 0 0 0 0 0 0 0 6614 6613 0 6612 0 0 0 6611 0 0 0 0 0 0 0 6610
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6609 0 0 0 6608 0 6607 6606 0 0 0 0
+6605 0 6604 6603 0 0 6602 6601 0 6600 0 0 0 0 0 0 6599 0 6598 6597 0 0 6596
+6595 0 6594 0 0 0 0 6593 6592 0 6591 0 0 0 6590 0 0 0 0 0 0 0 0 0 0 6589 0 6588
+6587 0 0 6586 6585 0 6584 0 0 0 0 6583 6582 0 6581 0 0 0 6580 0 0 0 0 0 0 0 0
+6579 6578 0 6577 0 0 0 6576 0 0 0 0 0 0 0 6575 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6574 0 6573 6572 0 0 6571 6570 0 6569 0 0 0 0 6568 6567 0 6566 0 0 0 6565 0
+0 0 0 0 0 0 0 6564 6563 0 6562 0 0 0 6561 0 0 0 0 0 0 0 6560 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 6559 6558 0 6557 0 0 0 6556 0 0 0 0 0 0 0 6555 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 6554 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 6553 0 0 0 6552 0 6551 6550 0 0 0 0 6549 0 6548 6547 0 0 6546
+6545 0 6544 0 0 0 0 0 0 6543 0 6542 6541 0 0 6540 6539 0 6538 0 0 0 0 6537 6536
+0 6535 0 0 0 6534 0 0 0 0 0 0 0 0 0 0 6533 0 6532 6531 0 0 6530 6529 0 6528 0 0
+0 0 6527 6526 0 6525 0 0 0 6524 0 0 0 0 0 0 0 0 6523 6522 0 6521 0 0 0 6520 0 0
+0 0 0 0 0 6519 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6518 0 6517 6516 0 0 6515
+6514 0 6513 0 0 0 0 6512 6511 0 6510 0 0 0 6509 0 0 0 0 0 0 0 0 6508 6507 0
+6506 0 0 0 6505 0 0 0 0 0 0 0 6504 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6503 6502 0
+6501 0 0 0 6500 0 0 0 0 0 0 0 6499 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6498 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6497 0 6496 6495 0 0
+6494 6493 0 6492 0 0 0 0 6491 6490 0 6489 0 0 0 6488 0 0 0 0 0 0 0 0 6487 6486
+0 6485 0 0 0 6484 0 0 0 0 0 0 0 6483 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6482 6481
+0 6480 0 0 0 6479 0 0 0 0 0 0 0 6478 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6477 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6476 6475 0 6474 0 0 0
+6473 0 0 0 0 0 0 0 6472 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6471 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6470 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 6469 0 0 0 6468 0 6467 6466 0 0 0 0 6465 0 6464
+6463 0 0 6462 6461 0 6460 0 0 0 0 0 0 6459 0 6458 6457 0 0 6456 6455 0 6454 0 0
+0 0 6453 6452 0 6451 0 0 0 6450 0 0 0 0 0 0 0 0 0 0 6449 0 6448 6447 0 0 6446
+6445 0 6444 0 0 0 0 6443 6442 0 6441 0 0 0 6440 0 0 0 0 0 0 0 0 6439 6438 0
+6437 0 0 0 6436 0 0 0 0 0 0 0 6435 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6434 0
+6433 6432 0 0 6431 6430 0 6429 0 0 0 0 6428 6427 0 6426 0 0 0 6425 0 0 0 0 0 0
+0 0 6424 6423 0 6422 0 0 0 6421 0 0 0 0 0 0 0 6420 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6419 6418 0 6417 0 0 0 6416 0 0 0 0 0 0 0 6415 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 6414 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6413
+0 6412 6411 0 0 6410 6409 0 6408 0 0 0 0 6407 6406 0 6405 0 0 0 6404 0 0 0 0 0
+0 0 0 6403 6402 0 6401 0 0 0 6400 0 0 0 0 0 0 0 6399 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 6398 6397 0 6396 0 0 0 6395 0 0 0 0 0 0 0 6394 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6393 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6392
+6391 0 6390 0 0 0 6389 0 0 0 0 0 0 0 6388 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6387 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6386 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6385 0 6384 6383 0 0 6382 6381 0 6380 0 0
+0 0 6379 6378 0 6377 0 0 0 6376 0 0 0 0 0 0 0 0 6375 6374 0 6373 0 0 0 6372 0 0
+0 0 0 0 0 6371 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6370 6369 0 6368 0 0 0 6367 0 0
+0 0 0 0 0 6366 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6365 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6364 6363 0 6362 0 0 0 6361 0 0 0 0 0 0 0
+6360 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6359 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 6358 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6357 6356 0 6355 0 0 0 6354 0 0 0 0 0 0 0 6353 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6352 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6351 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6350 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6349 0
+0 0 6348 0 6347 6346 0 0 0 0 6345 0 6344 6343 0 0 6342 6341 0 6340 0 0 0 0 0 0
+6339 0 6338 6337 0 0 6336 6335 0 6334 0 0 0 0 6333 6332 0 6331 0 0 0 6330 0 0 0
+0 0 0 0 0 0 0 6329 0 6328 6327 0 0 6326 6325 0 6324 0 0 0 0 6323 6322 0 6321 0
+0 0 6320 0 0 0 0 0 0 0 0 6319 6318 0 6317 0 0 0 6316 0 0 0 0 0 0 0 6315 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 6314 0 6313 6312 0 0 6311 6310 0 6309 0 0 0 0 6308
+6307 0 6306 0 0 0 6305 0 0 0 0 0 0 0 0 6304 6303 0 6302 0 0 0 6301 0 0 0 0 0 0
+0 6300 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6299 6298 0 6297 0 0 0 6296 0 0 0 0 0 0
+0 6295 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6294 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6293 0 6292 6291 0 0 6290 6289 0 6288 0 0 0 0
+6287 6286 0 6285 0 0 0 6284 0 0 0 0 0 0 0 0 6283 6282 0 6281 0 0 0 6280 0 0 0 0
+0 0 0 6279 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6278 6277 0 6276 0 0 0 6275 0 0 0 0
+0 0 0 6274 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6273 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6272 6271 0 6270 0 0 0 6269 0 0 0 0 0 0 0 6268 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 6267 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 6266 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6265
+0 6264 6263 0 0 6262 6261 0 6260 0 0 0 0 6259 6258 0 6257 0 0 0 6256 0 0 0 0 0
+0 0 0 6255 6254 0 6253 0 0 0 6252 0 0 0 0 0 0 0 6251 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 6250 6249 0 6248 0 0 0 6247 0 0 0 0 0 0 0 6246 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 6245 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6244
+6243 0 6242 0 0 0 6241 0 0 0 0 0 0 0 6240 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6239 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6238 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6237 6236 0 6235 0 0 0 6234 0 0 0 0 0 0 0
+6233 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6232 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 6231 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6230
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 6229 0 6228 6227 0 0 6226 6225 0 6224 0 0 0 0 6223 6222 0
+6221 0 0 0 6220 0 0 0 0 0 0 0 0 6219 6218 0 6217 0 0 0 6216 0 0 0 0 0 0 0 6215
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6214 6213 0 6212 0 0 0 6211 0 0 0 0 0 0 0 6210
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6209 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 6208 6207 0 6206 0 0 0 6205 0 0 0 0 0 0 0 6204 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 6203 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 6202 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6201 6200 0 6199 0
+0 0 6198 0 0 0 0 0 0 0 6197 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6196 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6195 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 6194 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6193 6192 0 6191 0 0 0 6190 0 0 0 0 0 0
+0 6189 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6188 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 6187 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+6186 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+0 0 0 0 0 0 0 0 0 0 1600 }
+
+! This is a lookup table for the perfect hash adjustment values.
+CONSTANT: adjustments-table
+{ 0 5628 7017 1298 2918 2442 8070 6383 6383 7425 2442 5628 8044 7425 3155 6383
+2918 7452 1533 6849 5586 7452 7452 1533 2209 6029 2794 3509 7992 7733 7452 131
+6029 4491 1814 7452 6110 3155 7077 6675 532 1334 7555 5325 3056 1403 1403 3969
+4491 1403 7592 522 8070 1403 0 1905 3584 2918 922 3304 6675 0 7622 7017 3210
+2139 1403 5225 0 3969 7992 5743 5499 5499 5345 7452 522 305 3056 7017 7017 2139
+1338 3056 7452 1403 6799 3204 3290 4099 1814 2191 4099 5743 1570 1334 7363 1905
+0 6799 4400 1480 6029 1905 0 7525 2028 2794 131 7646 3155 4986 1858 2442 7992
+1607 3584 4986 706 6029 5345 7622 6322 5196 1905 6847 218 1785 0 4099 2981 6849
+4751 3950 7733 3056 5499 4055 6849 1533 131 5196 2918 3879 5325 2794 6029 0 0
+322 7452 6178 2918 2320 6675 3056 6675 1533 6029 1428 2280 2171 6788 7452 3325
+107 4262 311 5562 7857 6110 2139 4942 4600 1905 0 3083 5345 7452 6675 0 6112
+4099 7017 1338 6799 2918 1232 3584 522 6029 5325 1403 6759 6849 508 6675 2987
+7745 6870 896 7452 1232 4400 12 2981 3850 4491 6849 0 6675 747 4491 7525 6675
+7452 7992 6921 7323 6849 3056 1199 2139 6029 6029 190 4351 7891 4400 7134 1533
+1194 3950 6675 5345 6383 7622 131 1905 2883 6383 1533 5345 2794 4303 1403 0
+1338 2794 992 4871 6383 4099 2794 3889 6184 3304 1905 6383 3950 3056 522 1810
+3975 7622 7452 522 6799 5866 7084 7622 6528 2798 7452 1810 7907 642 5345 1905
+6849 6675 7745 2918 4751 3229 2139 6029 5207 6601 2139 7452 5890 1428 5628 7622
+2139 3146 2400 578 941 7672 1814 3210 1533 4491 12 2918 1900 7425 2794 2987
+3465 1377 3822 3969 3210 859 5499 6878 1377 3056 4027 8065 8065 5207 4400 4303
+3210 3210 0 6675 357 5628 5512 1905 3452 1403 7646 859 6788 3210 2139 378 5663
+7733 870 0 4491 4813 2110 578 2139 3056 4099 1905 1298 4672 2191 3950 5499 3969
+4974 6323 6029 7414 6383 0 4974 3210 795 4099 131 5345 5345 6576 1810 1621 4400
+2918 1905 2442 2679 6322 7452 2110 1403 6383 2653 5132 6856 7841 2794 6110 2028
+6675 7425 6999 7441 6029 183 6675 4400 859 1403 2794 5985 5345 1533 322 4400
+1227 5890 4474 4491 3574 8166 6849 7086 5345 5345 5459 3584 6675 3969 7579 8044
+2295 2577 1480 5743 3304 5499 330 4303 6863 3822 4600 4751 5628 3822 2918 6675
+2400 6663 1403 6849 6029 3145 6110 3210 747 3229 3056 2918 7733 330 4055 7322
+5628 2987 3056 1905 2903 669 5325 2845 4099 5225 6283 4099 5000 642 4055 5345
+8034 2918 1041 5769 7051 1538 2918 3366 608 4303 3921 0 2918 1905 218 6687 5963
+859 3083 2987 896 5056 1905 2918 4415 7966 7646 2883 5628 7017 8029 6528 4474
+6322 5562 6669 4610 7006 }
+
+! This is a lookup table for the perfect hash final hand values.
+CONSTANT: values-table
+{ 148 2934 166 5107 4628 166 166 166 166 3033 166 4692 166 5571 2225 166 5340
+3423 166 3191 1752 166 5212 166 166 3520 166 166 166 1867 166 3313 166 3461 166
+166 3174 1737 5010 5008 166 4344 2868 3877 166 4089 166 5041 4748 4073 4066
+5298 3502 1812 166 5309 166 233 3493 166 166 3728 5236 4252 4010 2149 166 164
+4580 3039 4804 3874 166 6170 2812 166 4334 166 166 166 166 166 166 1862 224
+2131 6081 166 2710 166 166 166 4765 166 1964 5060 166 1897 166 3987 166 166
+5566 2021 166 45 166 166 3283 3932 166 166 3519 166 166 291 166 166 5132 2800
+166 166 166 5531 4054 166 3509 166 166 4908 3028 1756 1910 4671 2729 5224 166
+121 3327 3317 166 181 2371 5541 166 1787 2666 5134 5698 166 5480 3870 166 3823
+166 3165 5343 5123 5089 166 2422 3724 166 2735 1953 5724 4444 4871 166 166 5001
+5512 3133 5171 166 2216 166 4877 4542 166 166 166 5270 166 166 166 1922 69 3547
+166 166 166 166 166 231 4547 5155 3357 3464 166 72 3332 166 4392 5971 3896 4451
+3173 2569 166 4466 2518 1698 2850 5349 166 166 4457 5062 166 2202 1650 2191 166
+1950 2583 166 5293 2032 5893 166 3994 5392 3878 96 166 166 3195 166 4001 1900
+2513 6027 166 166 166 166 5407 166 166 2332 5125 5891 3096 3172 166 166 3065
+166 166 4535 166 166 166 4553 3131 3693 166 2255 2613 166 166 166 166 2866 166
+166 166 2940 5333 3199 166 2628 4312 166 166 1794 4681 2058 3606 166 166 3542
+2166 4696 2520 166 4739 166 2563 166 166 3681 166 166 166 4127 1967 2972 166
+5227 166 166 5551 4255 56 166 5553 3219 4367 166 3218 4749 2886 3695 3711 2228
+166 166 166 2268 5054 3749 4825 166 4933 4992 4530 166 4892 3400 166 197 166
+6078 166 166 3971 166 166 5357 1852 3377 166 5196 3740 5320 166 166 3099 166
+4562 6061 3294 166 166 166 166 3266 3627 2567 166 228 2773 166 166 53 1833 2401
+124 166 4272 3922 5959 2903 3923 166 6155 166 166 166 166 216 166 5247 166 5591
+166 166 82 87 4526 166 166 5439 166 4935 166 3187 1869 166 1764 5500 6023 3356
+166 3350 2457 2455 166 1637 166 3342 166 166 3355 5154 166 276 166 166 166 3371
+5969 166 1665 166 166 166 166 166 166 166 4092 1712 3122 5086 166 166 4906 166
+2591 166 166 166 1894 2997 166 4476 4384 166 4747 4109 2655 166 5978 1636 4898
+166 166 166 166 166 166 166 5207 166 166 3712 3876 91 5876 3786 5998 166 166
+166 4391 166 166 2832 2220 4435 166 166 5796 3156 6112 166 1643 1821 3129 166
+4200 166 5857 166 166 2351 5902 1855 5043 166 3167 5191 3996 5718 4876 3071
+2965 5735 5930 6149 2345 3297 3822 166 166 307 6019 1859 2981 4914 3320 6165
+2328 140 2372 308 166 2280 5081 166 3275 166 159 2399 2327 5489 4690 6059 4492
+4269 6058 166 19 166 3323 5708 128 4812 2949 166 166 2890 2630 5237 166 256
+3673 4621 5380 166 3353 166 1651 2573 1635 4011 3429 3370 3720 166 166 6108
+3848 5104 2851 1998 166 166 5106 20 166 2633 166 166 166 166 5662 125 3651 1731
+4702 166 3197 166 2947 3046 4196 2185 6100 166 2602 2908 2487 166 5232 166 4028
+5919 166 2680 3608 3252 166 4899 166 166 166 166 2529 166 166 166 166 166 2534
+166 2299 4076 166 3643 166 3921 166 166 166 1939 2124 1829 2436 3892 166 3481
+271 5307 1697 166 166 5098 2906 5545 166 5980 3203 166 1903 4626 4674 6118 6097
+5926 4136 1677 3232 4720 166 166 166 229 2012 3620 166 3798 166 166 2609 3489
+3809 166 166 166 166 166 166 166 5826 166 166 166 4903 166 166 166 166 6168 166
+5052 5044 5644 2375 2677 4012 3062 5831 4752 166 4125 2610 2062 3238 292 2533
+5872 51 166 1947 4225 166 2288 4845 166 5788 166 5717 166 166 5549 5619 166
+4165 166 2721 2311 5501 4416 4383 166 166 3068 5499 5936 166 4204 4766 4688
+1870 5220 166 166 166 166 237 2523 6039 3061 2793 3998 166 2545 2309 3144 3679
+3969 166 166 166 4379 3574 205 2808 5822 166 166 2188 4823 4990 5561 5711 166
+5627 6034 5253 3783 5047 4405 166 59 1755 3178 318 166 4710 2933 3409 6062 2821
+166 6099 166 4178 166 166 4122 36 4779 166 166 4323 3073 5410 2101 166 166 44
+5690 166 3265 166 5222 5909 1838 166 4755 2215 166 4082 166 166 3210 5140 3124
+5238 166 5913 2321 166 2416 5976 3918 5078 4218 5703 4897 6011 5685 2214 166
+166 6180 5175 1715 166 166 3760 4497 1808 4826 166 2540 166 166 5513 4971 5915
+166 166 2525 166 4480 42 232 2412 2797 3229 5263 2852 5543 2126 3562 166 2872
+4695 5985 5136 2714 4262 5473 166 4160 4347 166 166 166 166 5271 166 166 5108
+166 166 166 166 5437 4875 3963 4362 5820 5559 4890 4728 166 166 2692 166 4870
+3591 5472 166 2690 166 5854 3817 166 280 166 166 113 4128 3396 166 4264 5058
+2283 166 2281 4916 5671 166 2708 166 166 4589 166 166 4689 166 1686 166 166 166
+166 166 1774 166 166 166 5651 3777 2234 166 3864 18 3589 4592 4777 166 166 5254
+4245 166 166 166 4368 5172 3522 166 4306 153 5230 166 5598 5420 311 2414 4159
+2985 5137 166 2179 1801 166 4595 2083 2020 166 3602 2170 4259 3048 166 166 4193
+2350 166 166 2702 166 4521 166 166 2496 166 4593 2006 166 166 2292 4135 166
+6069 4623 166 166 4827 3995 4291 3243 166 166 166 5622 166 3539 166 166 4915
+4373 2479 3775 6008 5838 4321 1612 5530 166 3773 4267 4086 3081 2261 166 166
+4785 4641 5292 166 4820 5612 5556 166 166 166 4396 6084 3414 166 3331 2380 5921
+4315 2340 166 5511 166 4713 3754 2912 2553 166 3468 5388 166 1932 3540 5834 166
+166 3186 5258 166 4107 166 166 166 166 166 166 166 166 2108 12 2368 2789 166
+166 4148 1878 166 166 2324 4179 2945 2531 166 166 166 4485 3765 2308 166 2754
+166 6102 166 1921 260 2241 166 2592 166 166 166 4964 166 3055 5261 4943 2916
+166 201 5728 166 5759 4314 4730 6024 166 4926 4762 1834 2055 166 40 166 5416
+166 3722 2360 1928 166 4889 4590 5550 3498 166 6003 2029 4106 4346 3758 166
+2753 103 1891 5067 166 3398 2079 5784 3074 3787 166 166 3936 166 5766 166 4847
+3928 5119 166 5181 4602 2605 5712 4523 166 166 4717 166 2227 2181 166 4678 166
+166 4901 166 4980 166 166 166 166 5806 2894 5631 4995 2608 166 166 166 3917 166
+3417 166 2795 1655 3189 3364 166 4839 3510 4212 5641 6091 138 166 166 3343 4620
+2722 4566 166 3518 3424 166 166 1653 166 5057 166 5375 4833 166 4273 4348 166
+166 166 4912 166 3662 166 4281 166 5169 166 5883 2737 2572 4685 4068 166 4214
+166 166 2409 166 166 4571 166 5624 5722 5949 166 3675 166 166 5109 3428 166 166
+5446 166 3290 166 3309 166 166 4776 166 166 166 166 166 166 5617 2860 166 166
+166 166 3629 1741 166 166 183 4973 3047 2854 75 2035 3652 2159 166 4150 6037
+3225 4519 1902 2678 2413 1961 166 166 166 166 4972 1847 166 5636 4017 166 3345
+166 4520 166 2861 166 3092 6060 157 2542 2298 4496 166 2607 6110 5707 2314 166
+166 273 166 5952 166 4957 322 6065 2272 6140 2438 3458 3287 166 166 166 166
+2684 288 3354 166 166 3983 1702 166 166 166 2393 2435 4202 3308 5805 5085 166
+166 1938 166 166 2171 5892 2337 166 4648 3116 2486 4363 3567 166 166 2822 2041
+166 4703 3956 5192 166 3975 5720 3647 2134 5932 166 166 5160 263 166 166 166
+4549 166 166 1701 3086 166 166 4737 166 2252 166 170 166 166 166 2301 5478 166
+166 5979 3007 166 166 166 4104 166 2469 2700 166 4998 3376 166 1840 166 166
+4470 166 5235 3930 166 166 166 6031 166 166 166 3827 4700 166 166 166 166 166
+166 4103 3976 166 166 166 166 5027 4322 5130 166 4741 2132 4118 3080 4137 166
+6179 166 166 166 166 166 6120 4188 166 2251 166 3253 166 4887 166 4293 5241 166
+166 166 166 166 166 5076 166 166 4177 166 221 166 2757 5377 166 43 166 166 3180
+5540 166 213 4541 166 166 166 166 166 1641 166 4578 4639 166 166 1683 2139 1689
+5249 5773 5226 166 2820 166 5516 5045 166 4896 5657 5189 166 5770 2725 5148 166
+166 166 2929 166 3479 166 166 4564 3752 4305 4232 166 5906 1779 166 2709 4941
+4342 166 4882 166 4277 2322 166 4879 1610 3038 166 3762 2054 5652 166 4524 3820
+4806 166 166 104 3416 4869 4243 4854 166 4114 166 2121 166 3463 3556 166 4795
+166 2118 3920 166 166 4667 5046 166 166 2088 4360 5787 2198 4233 5552 3970 3523
+2037 5791 166 166 4299 2336 166 166 166 4173 4588 3626 5187 166 3363 4611 294
+4962 5243 2719 6022 4976 3559 166 2662 5779 6151 166 3527 166 5404 6132 1839
+166 3090 166 2253 166 5441 5518 6049 166 166 6136 3026 3474 5960 166 3937 4105
+166 2348 2039 4738 166 5233 3882 3840 166 278 190 166 5751 4313 166 3855 166
+166 6171 166 166 5381 3941 166 166 166 166 3334 166 2038 6088 166 1918 5037
+2325 2378 4894 3514 3715 5168 166 166 4083 2873 166 166 166 2693 166 3543 166
+2577 3013 166 166 4594 2622 166 166 166 3401 166 166 5447 5328 5547 6133 2335
+3739 166 166 166 166 5614 3492 3610 3466 166 5336 4354 166 4662 166 166 4283
+166 166 303 5904 166 2717 166 166 2276 5564 2386 5661 2040 166 1630 4652 166
+4840 166 110 5329 3979 5734 2550 166 166 6007 5999 2978 4771 5360 166 4023 166
+166 5920 4065 166 3880 166 5422 1813 166 6166 73 166 166 3669 5762 5077 166
+2953 85 166 3517 166 116 166 2738 3710 166 1634 166 166 166 2290 3001 166 166
+3037 2400 3410 166 1791 4231 166 3546 5009 5299 2807 166 166 1675 1619 2374
+3093 5302 3278 2330 5301 2343 2307 3274 5017 2265 3700 2465 166 139 4292 166
+5056 3952 166 4528 2388 1886 166 166 3016 3698 5881 166 2379 3223 166 166 3847
+2407 5493 3183 3307 166 265 166 2421 6161 2057 5363 3863 2474 166 166 5427 166
+2140 2955 166 3070 4237 5018 5988 5570 275 4862 2357 166 195 166 2593 6047 166
+2878 166 166 2781 3004 4180 166 5593 166 5973 2544 5064 166 4324 4701 166 3084
+166 166 5372 4725 166 5650 166 166 2786 166 3781 3583 3682 1850 4420 3296 5173
+4461 166 166 166 2984 166 93 166 166 4336 5943 2922 3300 166 4843 166 166 166
+166 2094 166 2939 166 4656 166 5146 166 166 166 166 2104 3977 4660 5312 166
+1865 166 5487 5558 3380 166 1957 3162 3281 166 3588 3268 2099 166 166 2319 4913
+4187 5503 5782 150 166 52 5450 166 166 166 2941 5877 166 4031 5393 166 3931
+4166 3135 3445 166 5053 5430 4836 166 5315 3389 4636 166 166 3441 166 166 3767
+2961 166 4761 4604 3179 166 166 4751 2148 2015 166 123 5013 166 2936 166 2063
+166 5823 166 5096 166 166 4198 166 166 166 3845 166 166 238 166 2703 3541 166
+4813 166 4477 2349 4197 5996 3324 4789 3063 166 166 5504 5273 2805 13 166 5601
+5402 4119 5206 166 166 4251 3704 4176 1963 2882 166 202 3125 3318 112 166 3362
+4835 3420 3974 5099 166 4433 166 166 166 1766 2663 166 166 4683 166 166 5485 47
+5101 5341 5765 3390 1648 4341 3945 6045 1645 166 5578 2594 166 166 3772 166 166
+3196 3603 166 5399 166 5075 166 5911 4632 4781 5313 270 166 2346 166 166 166
+1986 166 166 4958 166 166 166 4048 166 3076 166 166 4891 166 166 57 166 220 166
+166 166 4117 166 166 166 166 5194 2658 166 166 2942 6071 4182 166 2976 5816 166
+166 166 166 3985 4211 2514 166 166 166 2504 3446 1711 166 166 2107 5190 166 34
+166 3912 5382 3003 166 166 166 2999 2404 4734 4455 2087 166 2405 156 166 2830
+3303 296 3295 2067 4268 166 166 5642 166 166 1901 166 5133 166 166 166 166 3176
+2973 4677 166 166 6164 3000 2396 2734 5697 5989 166 2823 5265 5852 166 166 2623
+2625 2287 4844 1758 166 166 166 166 166 6073 166 5379 2389 5279 2444 5515 166
+4038 166 4948 5640 166 166 3572 4258 166 166 166 5204 166 4603 5797 166 166 166
+1725 4600 166 166 5498 166 4152 166 172 4758 166 2598 2489 2076 4366 2568 166
+4352 3782 166 166 3059 3946 5138 5727 4484 5694 166 3796 166 166 166 166 5334
+1778 2245 166 4517 4419 2250 182 5856 166 2835 4495 1858 2033 6014 6086 3211
+166 166 154 2145 166 129 3661 2661 5860 6143 2640 3890 6160 166 166 2747 166
+166 2291 282 2476 166 166 3825 166 1925 166 4489 166 166 166 4034 166 166 166
+166 166 166 122 4708 4919 2373 2453 5419 5954 297 5290 166 1978 166 4932 3501
+166 3085 3386 166 5405 4512 166 3209 5740 4020 5495 5815 314 166 3190 4824 166
+166 3448 207 1623 6096 5878 166 1836 166 166 2728 166 5278 3419 3012 5618 5266
+3078 166 166 2244 166 4569 6068 166 3336 166 5677 6052 5079 166 5453 5245 5799
+166 1982 166 5958 4619 5821 166 5285 284 1631 5710 6070 5365 2189 3242 166 2752
+5483 5297 6150 5522 166 1815 166 166 166 5801 166 166 5398 166 166 166 2967
+2515 3169 166 166 2562 166 1617 2069 166 166 6154 166 3721 166 5327 166 166 166
+5592 166 166 2286 1716 3903 166 2395 286 3587 6146 3286 4186 5882 5894 5737
+6032 5879 2761 4829 3788 166 166 3233 5356 5693 166 2429 2449 141 3444 5186 166
+166 3477 4080 4584 166 166 3670 1851 3824 4337 3886 2792 166 5867 166 166 3557
+3147 166 166 2200 166 2505 166 4310 4865 5656 5992 5672 166 5199 135 3023 2994
+4472 166 166 166 2019 4319 3472 166 166 166 29 206 3944 3027 5804 4731 5449 166
+2825 3310 166 6172 5202 166 2516 3644 4557 166 166 166 166 2671 4427 3432 3276
+5584 5536 4645 3202 166 2612 166 4249 2425 3259 4622 166 2411 4303 4206 166 166
+166 3734 6063 118 166 166 3641 166 166 166 4937 1871 3421 2208 166 166 166 166
+4881 166 166 166 166 3298 166 61 166 166 166 3293 6145 71 3619 166 166 3383
+1624 320 2187 4113 166 166 166 166 166 5080 2344 5625 2358 1621 4230 5579 5359
+295 4248 5267 3883 6124 187 5112 2122 166 166 166 5142 6004 166 5322 6175 3639
+3182 4425 166 175 166 166 166 5778 3939 3484 166 166 5832 5248 5935 4467 5858
+166 5038 166 166 3102 166 4880 166 166 166 166 3418 1666 5338 3680 5291 4441
+3385 166 5733 4503 2774 166 2631 4153 166 2000 166 166 5345 166 166 4298 1804
+4707 166 1613 1952 2111 166 166 166 166 166 2897 166 166 4044 166 166 166 166
+2863 5475 166 166 166 1704 166 3609 2782 2018 166 5361 166 3694 3733 166 2785
+1969 166 166 2834 1868 3779 1877 60 166 4143 3902 166 4361 3188 2498 6009 166
+115 166 3138 166 4575 6080 133 2030 166 166 166 2306 2136 3043 3447 2142 166
+3799 1646 5269 3640 166 2674 5502 166 5467 166 5069 166 166 4654 4581 5274 5036
+4364 166 3115 166 2128 4544 5433 2086 2584 4413 166 166 5385 166 234 166 1625
+166 166 166 5139 2511 4974 2766 166 166 166 2095 3990 217 166 2988 4061 166 209
+4883 166 166 166 166 166 4326 166 5465 2859 166 2887 166 2231 166 1658 166 2246
+166 1844 166 166 3087 2871 3872 1660 48 166 166 3622 166 1709 166 166 6177 6173
+166 3569 166 166 166 241 3660 3631 166 166 5319 5141 174 166 166 4412 166 5145
+166 1919 166 5276 166 2385 166 1618 166 166 2501 166 166 1734 5966 3145 166
+1690 4025 1664 4559 2433 2392 3552 4006 1896 166 166 2546 4450 5396 4221 4046
+166 166 2642 166 4448 166 2784 3480 4807 166 166 3534 166 166 5272 166 166 2831
+4263 166 166 166 166 4414 5628 3486 166 3748 166 4598 3719 3598 3611 166 4792
+5059 4110 166 2656 166 166 84 5429 166 166 166 281 1955 166 166 166 3616 4997
+166 166 166 166 3230 166 166 166 166 166 166 77 166 166 166 1800 166 4236 166
+166 166 166 166 5757 2530 1662 166 4607 1659 166 1685 3341 166 1699 4058 3407
+1854 4417 3034 166 166 166 166 5568 166 3206 166 5529 166 166 166 2116 3487 144
+166 166 166 5523 5373 5321 166 6064 2921 166 1696 2473 166 166 3716 5689 166
+4608 3879 166 166 166 2156 166 4358 2446 166 3958 166 5520 4340 4848 166 3285
+166 2665 166 3459 1905 5115 68 5730 166 3127 5029 4370 166 3753 166 3674 6025
+4490 166 4183 166 94 166 166 4051 3766 3140 4907 3857 166 166 4596 166 3888
+3040 2507 5643 166 166 4311 2618 5582 166 166 3678 166 1988 166 166 4464 166
+166 166 166 4278 3677 2173 5256 166 166 5162 166 5178 1644 5094 166 2557 5506
+166 166 166 4927 5348 1797 166 166 39 166 3866 3655 236 5403 2175 3361 166 1976
+5993 226 166 4643 166 5339 4098 2653 4969 166 3346 4984 4635 166 166 166 166
+4981 188 166 166 28 4088 166 166 166 25 3663 2696 166 4679 5114 5802 166 166
+166 166 166 3810 5749 166 1673 4276 166 3756 4184 166 5630 166 166 166 4531 212
+5663 166 166 2746 166 5386 3618 3594 1887 166 166 5443 166 1726 4094 5065 4756
+166 166 5308 5225 2081 166 166 3064 166 166 1981 3637 4355 1626 166 166 4686
+166 5793 180 5066 2938 3819 4904 3601 166 166 2495 5025 5768 2621 4650 3041 166
+5897 3633 166 166 4375 166 5714 1667 3273 3950 1668 166 5855 166 2364 166 1881
+166 2646 5460 166 2770 4951 5414 166 4442 2113 5726 298 5934 2053 166 166 4053
+166 166 4514 4697 166 166 5198 2707 166 5605 166 166 5218 2596 166 2110 166
+1806 2160 166 166 2212 166 3636 166 166 4377 4021 3707 4502 166 4195 166 166
+166 4108 3725 3676 166 2084 166 166 166 166 4216 166 166 6156 166 2896 166 166
+166 166 166 166 3826 2870 3793 166 166 5927 166 2759 166 4613 2297 5638 166
+2842 5031 4793 5184 166 166 2008 166 257 2881 117 6051 3044 4079 2833 166 6117
+166 3236 5469 166 166 2874 6076 166 1799 80 41 166 1864 166 5709 1611 5026 5176
+168 3269 4081 166 166 1970 4550 166 4250 4101 4565 5950 5845 97 4064 166 5394
+4374 4343 166 166 4658 3248 166 208 1735 4047 2843 166 166 166 166 2794 166 166
+5844 166 166 3094 2177 5436 3646 166 3564 4682 166 5948 5835 162 2059 5151 2034
+1926 5941 5903 5177 166 166 166 4801 3439 1780 166 166 3280 3434 166 166 4498
+5565 4043 166 4432 4722 3959 166 3746 166 166 177 166 166 2748 166 4483 166 166
+4144 166 166 166 166 2066 2915 166 2049 2130 4684 166 49 3506 5391 166 2590
+6103 1714 2410 3053 3837 4301 166 3255 2644 166 166 4014 166 2475 4788 2876 166
+166 166 166 166 166 4140 166 166 321 166 1966 166 166 2855 3111 3800 166 4446
+2551 166 166 166 2824 166 166 166 2164 3010 2226 166 4857 166 2582 5118 4582
+5917 166 166 3338 3482 3328 166 4817 166 5371 3830 166 3009 1633 3329 4052 166
+3701 4983 4500 4487 4878 166 166 5482 3544 166 3057 2026 4398 2847 3532 3262
+3399 166 166 166 4478 4167 166 3411 2599 5362 166 2711 166 166 166 166 3452
+2522 5586 5548 3279 2538 166 166 166 4161 166 2123 166 166 2660 166 166 1706
+166 15 3537 5051 5869 166 3025 166 4447 3744 120 166 166 166 204 2810 166 5124
+2376 5306 166 166 4493 166 166 166 5289 6046 166 2762 2541 1857 2467 5163 166
+166 166 166 5830 166 2172 3359 166 2928 166 166 166 6129 166 5445 166 166 5924
+6144 166 102 166 166 1678 166 4491 5705 166 1753 166 3873 5725 4145 1909 166
+2155 166 166 1848 3315 1874 166 4945 2524 166 3263 2362 1785 166 166 166 152
+2102 5723 5131 5754 4032 4029 166 4295 3391 166 166 166 5282 1747 3159 2235
+5583 1786 3630 6111 2974 4797 3623 166 2071 4929 166 2603 3964 3378 166 166
+2654 151 3940 4527 4518 166 2430 1884 3812 166 2867 166 166 166 2756 5418 166
+2354 4606 166 2153 166 4855 166 166 1720 166 3213 3926 166 5158 4349 166 4828
+166 166 2031 166 2300 166 166 166 2211 4954 3121 4754 2485 166 166 166 3593 166
+2718 5317 2765 5120 166 2527 166 1994 5947 166 166 166 6085 2302 100 79 2982
+3705 2180 2043 166 1872 1671 166 3729 166 4944 3665 2217 2119 166 5615 166 1620
+166 166 166 166 35 3913 2760 166 3688 3672 4042 166 166 5117 4227 166 4445 2458
+3803 4554 4988 166 166 3141 3491 166 166 166 166 5095 4668 5567 166 166 2885
+1790 2996 166 166 166 166 3737 166 2470 166 166 4339 166 166 166 4920 166 166
+3697 5471 166 166 3538 4558 3467 5262 5609 3858 166 166 5007 2780 2791 2236
+5668 3134 166 166 5776 3470 3291 166 2532 166 166 166 3805 264 166 3227 166 166
+166 2334 166 5087 101 166 3634 58 2813 166 166 166 3222 4704 4488 4508 5459
+2117 5873 166 1828 166 166 166 166 166 2105 166 5613 5761 2920 3098 166 166
+3277 166 166 166 166 83 166 166 166 3967 166 5574 166 4985 30 3426 166 179 3014
+4015 246 2556 4449 3723 5611 3436 166 4240 3642 166 4536 2048 5810 166 1971 166
+5557 5323 5022 191 5492 166 4837 4426 2537 2271 3177 5674 166 2796 1995 166
+3906 166 4403 3862 4716 2406 3948 4670 4309 166 2575 5358 2951 166 3666 3612
+5577 4579 4743 166 6072 6036 4563 2586 166 5836 166 166 5752 166 3563 166 2909
+3251 92 166 4711 4149 166 166 3052 5122 2904 2635 1990 166 166 166 166 166 166
+166 166 4213 166 3103 3142 2683 6105 2209 3175 4215 166 166 166 166 166 166 166
+5303 4075 5374 166 4174 4154 1895 4538 2764 166 5817 6113 4033 166 6090 166
+2990 166 3164 166 166 166 247 166 6083 3412 166 5738 166 3599 166 1904 2162
+2547 3960 166 166 3154 55 166 5991 4921 2879 166 166 5347 166 166 166 2712 4787
+166 1908 166 166 166 3184 166 166 166 4572 3846 3657 166 166 5481 166 166 3397
+1856 4978 166 3900 3570 3802 166 166 2075 4408 166 6079 2313 166 166 5756 166
+166 2070 166 166 3137 166 166 3686 166 166 166 166 67 5019 166 1742 166 5354
+166 5149 166 2931 4946 6006 166 166 2865 4902 3029 1722 3449 166 1987 166 62
+5626 166 166 166 2670 1657 5599 3056 166 3791 5020 166 1979 4437 1899 166 166
+196 2636 166 143 3475 4317 2512 2415 5033 5024 2112 2864 3551 166 1688 33 4585
+3648 4399 166 166 166 166 166 1824 166 166 166 166 166 166 4513 166 2478 4407
+166 166 2492 4130 4318 2980 5746 166 2606 4063 4123 166 255 166 166 4680 166
+3586 5975 3935 166 5528 166 3158 166 166 2614 5035 166 3488 3214 166 166 166
+5413 3713 166 5875 4329 5250 166 166 3741 166 54 1885 3839 166 4924 166 166 166
+4158 166 166 2152 1661 166 166 4327 166 3933 166 5666 166 166 2580 166 3404
+4111 2862 4438 166 166 4072 166 166 3938 2958 4302 166 3851 166 268 166 166
+1975 222 3204 3438 4616 166 4275 3101 2648 3989 5215 166 4229 166 5440 166 5093
+2639 166 166 4439 166 2316 4239 166 166 166 166 166 1817 4486 166 3272 166 166
+4085 2078 2902 166 166 166 4381 1853 3054 166 166 5005 2669 166 2856 2706 166
+166 166 4185 166 1748 166 166 166 5771 166 166 3915 166 166 2205 6122 166 166
+1632 5400 166 2477 4740 166 166 166 1802 166 2472 3953 166 1849 2604 3780 2560
+4786 2566 3576 166 4768 166 1951 251 5068 166 166 166 2619 166 166 166 5432 166
+166 5260 5758 3908 166 4141 166 5777 166 166 166 166 166 3961 5143 166 3889
+3747 3743 166 2818 166 166 166 3867 166 166 3742 4763 2948 5533 166 3966 3555
+3843 3503 6005 166 4687 2790 4479 5828 3769 5688 166 166 166 166 3109 166 166
+166 166 4574 81 166 166 4576 3369 166 166 166 4207 166 5072 2210 166 184 166
+4673 166 166 166 166 166 166 1628 3590 1916 4784 4970 166 1832 166 166 3584
+3384 166 166 2880 1783 166 166 166 166 6115 6121 2157 5428 5859 4861 5635 4331
+5839 4223 313 166 166 6152 2168 166 4112 6089 6012 166 5294 3207 166 166 4884
+166 4655 166 166 166 1743 166 4077 166 4631 166 166 2957 1945 4936 166 166 5389
+166 166 5955 166 166 1639 2207 4129 166 3582 5560 6147 3088 166 166 4529 5259
+3118 166 3106 2853 166 1845 5660 166 3325 3973 2461 2163 166 3083 4190 166 166
+5505 166 166 3226 5507 109 6141 3991 166 4939 166 166 5889 3986 166 3664 4353
+2056 166 5071 166 166 4376 166 1958 2028 166 166 1793 166 5252 3536 166 166
+3525 3580 166 166 166 1782 5174 2011 1826 3352 3231 166 166 4986 2068 2801 166
+2500 166 5061 166 2263 2632 1993 166 2715 4424 166 166 6042 4661 166 5074 5479
+4822 166 166 166 166 5600 5853 166 1907 166 166 166 3808 166 5997 5032 4605 166
+1732 166 166 166 3015 5454 166 166 166 3806 5444 2238 1946 166 166 3221 4922
+166 6092 166 166 4007 166 3425 4282 2571 166 1749 166 166 38 4744 4900 4257 214
+5687 166 2490 2979 2924 166 4714 219 5344 3836 3302 78 1984 2986 2960 166 2869
+3507 3335 4967 2892 2723 4849 5070 166 166 4629 3815 166 4453 4760 166 3224 130
+166 166 166 166 166 3408 2494 2691 166 4325 2932 5165 5573 166 4769 166 5411
+5637 2050 166 166 2305 166 166 4834 24 4693 3554 2491 1738 166 166 166 23 2758
+3072 2564 4800 5537 3545 4133 166 166 166 5982 166 203 166 166 290 185 166 3774
+1929 3379 166 166 166 166 3002 166 3738 166 166 3344 4942 5353 2777 2839 4712
+1830 2664 166 5884 3516 166 5494 4169 2391 3319 166 166 5918 2597 166 4821 2787
+5719 166 166 166 1687 6148 3257 254 166 5180 6153 5964 306 166 6123 166 5208
+166 3163 5938 1736 166 2502 4910 166 166 2549 166 2900 3632 3270 166 2082 5953
+166 107 5750 166 166 166 5527 1751 4168 2950 166 2659 166 4189 1943 2595 166
+4191 166 166 166 166 2998 2296 5221 3617 166 5435 2451 2009 3005 2242 3768 3658
+166 166 166 166 166 2481 2256 166 166 4074 166 3120 166 4409 1759 166 166 1679
+3659 3499 5219 4501 3082 2047 166 166 166 4560 2768 5251 166 166 166 2437 3993
+3215 2447 166 166 166 2993 4963 166 3045 166 166 166 166 166 166 166 5521 166
+166 4868 166 3895 166 6131 3949 3306 3785 166 166 4895 4831 166 1772 166 166
+5928 166 2137 4805 2462 310 2667 3561 166 166 2312 4931 5255 166 166 166 5670
+166 2285 166 4672 5310 166 2103 2174 166 166 166 166 5417 166 4726 4203 166 166
+166 5581 166 5665 166 166 5747 166 166 2509 1973 2749 5463 166 166 4567 5014
+166 3322 3051 166 4090 166 3709 3887 3478 166 166 166 166 3565 3934 166 32 166
+166 166 2239 166 3947 3849 166 2022 166 2169 166 4691 98 166 3804 4155 1640
+4002 166 2138 1739 3730 5970 2274 4873 3119 166 4925 3577 3699 4049 3982 166
+5161 1744 166 166 166 5704 4979 2686 5383 5744 2289 166 166 166 3927 2539 166
+166 166 2585 166 4723 3755 4509 166 4961 2194 2535 166 176 166 4494 166 4171
+166 266 166 3454 5369 166 166 5899 5284 166 3607 3566 5514 166 1843 166 3997
+4599 2743 166 2857 2497 2751 166 166 166 3511 5742 166 166 166 4504 166 166 166
+5082 4401 166 166 5431 166 166 1949 4539 166 166 4852 166 166 3457 166 3433
+4669 166 1692 2454 3258 6159 166 166 166 166 166 2788 4350 3249 3816 4893 166
+4846 166 4993 1708 4138 166 2895 2891 166 1860 166 2480 1927 3853 166 166 166
+5100 166 3143 5159 166 4286 5182 5246 4975 166 2905 166 4917 5102 2044 6016
+5673 2005 5090 166 4634 3333 166 5702 3413 1762 6094 4284 4431 2641 166 4463
+5691 166 166 3442 3473 4192 2046 166 3838 166 3217 3349 166 2243 166 3490 166
+166 166 5922 166 166 166 4885 1798 2884 2750 5004 2741 166 166 5649 166 4410
+166 166 3382 166 166 1913 1703 5532 3770 166 5116 2645 2634 4357 5901 166 166
+5538 166 166 166 6028 166 166 5840 4102 2704 2091 5287 166 4757 2282 166 2650
+3528 64 253 3732 166 166 166 166 166 3465 166 166 166 5848 3110 111 166 166
+3403 2926 6030 3366 1948 4430 5509 3250 3972 2587 3579 166 6048 250 5275 4242
+2615 3112 3558 166 166 2342 166 5157 1917 2733 5647 1934 5675 166 3981 2923
+5213 5326 37 166 5288 3069 166 1923 5755 166 166 166 1888 166 6041 5895 5376
+3727 3901 166 5589 166 166 4609 166 166 166 4706 166 4482 1622 166 171 166 166
+4646 4151 2755 4614 166 2072 5409 4469 1647 4434 4633 1915 166 3615 4808 166
+3388 166 5280 2731 166 166 2417 166 14 166 4533 5126 166 2778 3022 166 166 166
+4830 4764 166 166 166 4982 166 4265 166 2466 5678 147 1883 166 166 166 114 4000
+2427 3597 166 4853 5981 166 2023 2519 166 1937 2221 4676 166 4522 5716 166 2432
+5731 166 6020 6163 4351 2442 4380 166 4390 1882 6139 4246 262 166 1676 5781
+2352 1956 200 166 166 5800 6184 166 2355 149 5962 5524 4238 166 5150 166 5888
+2423 166 5739 3192 4142 166 166 166 3201 161 4460 2459 158 166 166 166 166 2689
+166 166 166 166 1889 166 166 3374 166 70 166 2772 166 2995 166 2384 4989 166
+3299 166 166 166 166 3614 3645 3415 3160 1727 3735 5201 1693 3531 166 166 1776
+3871 166 166 166 166 86 3553 166 166 166 3392 166 166 2232 166 4977 2333 3394
+2875 2027 5736 166 1719 166 4952 2061 2150 5526 166 4637 166 4333 166 166 4733
+4809 3911 166 3460 166 5355 3126 4181 4436 300 166 3841 166 4770 126 5654 166
+166 166 1730 166 166 166 5610 166 6002 2197 3807 6109 166 166 166 166 166 5395
+4004 166 46 166 166 2570 4736 5318 4247 166 166 166 2293 3031 4591 166 245 166
+5510 1616 3117 4163 166 166 4759 3462 4819 4947 166 3128 5946 2278 2969 166 166
+5183 166 166 1729 173 2448 166 230 2971 166 166 5397 166 4093 3348 1866 4280
+166 6067 3794 166 166 166 4729 166 3456 166 2394 166 4953 166 166 2258 4863 166
+166 4060 166 5468 305 166 6134 166 166 2326 166 3453 2167 2845 166 166 166 5597
+166 166 166 166 5462 2809 5994 2899 166 166 166 5153 166 166 1638 166 166 4938
+3795 166 3842 166 166 166 2769 3194 166 4745 5508 5604 3910 166 166 4147 3239
+166 166 3548 3859 2092 166 2705 166 166 3625 4131 166 3513 166 166 2987 4555
+3107 166 166 166 166 5713 4698 3079 166 5342 166 166 2673 2517 2745 1795 166
+166 166 166 166 166 2463 166 166 2445 5425 6138 166 2687 3254 5871 166 2387
+4300 166 166 3529 1996 166 2369 3818 6126 1615 2643 65 4297 166 5324 3311 3852
+166 3868 4199 3978 166 166 166 5466 166 166 244 166 5929 6157 2390 5639 2267
+2073 4610 5774 2521 4556 166 4545 4307 2426 2450 166 5783 4968 6176 4156 166
+166 4126 3549 166 3581 5701 3234 166 4013 1879 166 6104 5874 166 166 3485 4279
+2528 5576 166 3992 166 3980 4934 166 2176 4228 5164 3784 1933 4120 5055 166 166
+5015 166 166 166 2310 1754 166 6087 166 166 4548 5268 2930 166 3656 166 3042
+5229 166 4016 2195 166 166 166 199 1745 3717 166 166 74 2668 252 4124 4657 5223
+166 2186 3628 166 166 166 4222 3114 2841 5103 3171 5135 166 166 2273 166 3899
+5332 5842 3575 2579 2431 2464 2229 3604 4561 2977 2815 166 3916 166 5825 166
+1694 166 4030 166 5841 166 3881 1831 166 5525 3011 166 5535 5217 316 4116 166
+166 2204 166 3136 3650 166 5813 1875 4511 4475 166 1999 166 2277 166 3024 5484
+5546 166 3988 5676 166 2213 2264 5214 166 4940 5974 166 4750 6077 166 1652 3148
+166 166 166 166 2554 166 6167 5257 5300 166 166 166 166 5408 166 166 3402 2141
+166 4663 5633 3312 166 2814 4930 1959 166 166 166 3861 166 166 302 2624 166 166
+166 1629 1724 166 3909 5281 166 2001 4395 5352 4428 2694 4850 166 166 5242 5910
+166 166 166 166 166 3212 166 2045 166 166 166 166 166 166 3017 4960 4456 166
+5616 6093 2151 166 166 166 315 3381 166 166 166 4330 166 6158 4721 6075 166 166
+166 4543 2303 166 166 3301 166 5000 3929 2543 3437 166 166 166 3422 166 5987
+5729 2428 166 4035 5588 3714 3834 5264 5743 166 3305 4886 6107 5156 166 166 166
+166 166 1672 5849 5827 5049 6101 2178 2420 3289 166 166 4274 6017 2257 166 4172
+3451 2367 2382 166 2964 4918 3241 2347 6082 99 2383 166 4454 163 2460 165 304
+1818 5580 166 312 5790 293 5794 5519 5083 3360 5748 166 3750 5034 166 166 166
+1863 3168 166 166 166 5111 166 166 166 166 2183 4510 166 166 3495 4382 4235
+4462 166 4056 5885 17 5028 1614 6038 166 2488 5632 3089 166 1940 66 4039 3999
+235 166 166 3829 3954 166 2365 269 166 166 166 166 166 166 4418 1796 4709 2004
+166 3596 5786 166 2819 4624 3152 2968 2838 166 5575 1767 5603 166 4386 5890 166
+1768 4201 3560 166 166 166 2184 2262 2966 2716 1765 2611 2983 166 4164 4084 142
+5314 166 166 4071 166 2578 2849 3600 166 166 166 166 5401 4814 3431 166 5088
+5084 198 166 3578 3764 166 2097 166 166 5390 4443 166 3166 166 4816 166 166 166
+166 3130 5963 1788 2129 1837 4100 6128 166 4586 5945 4772 166 5741 3151 3247
+5645 4507 5833 3904 6013 2506 3050 4175 1705 3019 166 5942 166 2418 3430 2230
+5745 166 2093 166 166 166 166 4666 3246 192 2010 4003 3533 5851 166 3621 3684
+3066 166 166 166 5073 3856 166 166 2224 166 2637 4270 166 166 5679 166 5792
+5850 166 2589 3060 2196 3476 3150 2025 166 166 166 2657 166 3685 3790 5587 2817
+3692 166 166 166 2359 2260 5896 2158 119 2816 5753 166 2739 5772 166 2919 2147
+1985 4271 4838 4991 166 166 166 5244 166 319 166 166 2779 4732 4994 5424 166
+166 3968 3049 3393 4473 4959 5967 5864 5170 4209 166 4810 4815 4205 2339 5023
+2279 5050 166 5837 132 166 166 166 2247 21 4775 166 166 5286 166 4170 4099 4803
+5767 166 166 166 5811 2240 5699 2499 166 4802 166 5785 166 166 166 3181 3435
+166 3339 166 5669 3865 2249 5002 166 4694 5461 4753 166 3157 166 1960 166 166
+166 2440 166 5818 5534 2439 1717 166 3789 2959 166 2943 166 2576 166 2002 2007
+1819 3256 4402 5311 3832 160 166 166 2803 166 3264 166 5863 166 2017 166 2798
+166 166 166 166 5607 4965 166 166 166 4537 4378 5944 3494 5457 5602 1942 5900
+5780 4411 5147 166 4966 2115 155 2827 1980 5063 166 285 5912 3304 2963 5179
+3220 166 166 166 2190 3708 5476 1944 2366 3893 166 166 166 3759 166 5434 2740
+1707 4244 5426 166 166 166 3155 166 4285 166 166 166 166 5721 166 3833 6001 301
+166 166 2574 186 2724 166 1873 3667 166 5216 166 2935 2100 4987 166 2284 166
+166 2911 3828 4009 166 2065 166 5496 6130 5563 4387 166 3771 3469 2989 2222
+4577 3965 4296 2975 3813 3240 166 4780 4481 3387 2338 166 6183 166 166 166 166
+166 2675 1761 2600 5167 3170 4773 2165 5166 166 2223 4642 166 166 4540 166 166
+166 3897 166 2483 1809 5477 3844 4067 2508 2275 166 166 166 166 166 3497 5458
+166 249 2956 166 4651 166 283 166 166 4955 4062 2315 2304 3261 2361 4791 4389
+1997 166 3455 166 166 166 166 166 166 4746 5695 5296 105 1841 3368 166 166 166
+5228 166 3496 4423 2024 3907 4774 166 166 166 166 166 2294 2193 166 166 166 166
+166 166 166 166 4393 166 166 2127 166 4573 166 5350 166 5016 3372 166 5653 166
+5972 4719 166 166 166 166 166 5370 166 6142 166 166 3691 2828 166 2601 166 2937
+2060 3654 3097 2341 5325 4568 4096 2776 166 2946 166 166 166 5843 1777 5295
+2837 4261 4397 5006 5808 4866 166 1713 5732 2954 166 166 27 166 4308 5629 2652
+2434 4474 166 4928 166 4727 3811 166 166 5234 166 6010 166 4911 166 4570 166
+6000 3450 5304 3919 166 166 4008 3942 166 272 2363 2064 3595 3505 166 166 3957
+1695 2452 4659 166 1792 166 131 5968 166 3731 3905 4115 166 166 2468 166 2727
+166 3526 4724 166 4388 3149 5539 5092 4440 6162 166 166 193 4429 2493 166 166
+3683 166 6029 166 277 166 166 166 5240 2408 166 309 2561 210 166 5200 166 166
+166 1930 5692 2697 166 166 166 3330 5331 3860 166 166 4335 166 50 3605 4289
+1763 166 166 166 166 3521 166 166 166 3668 166 166 166 166 166 3271 1656 166
+166 4782 166 2962 166 5907 166 3245 3375 2944 5933 166 166 5406 5655 3139 5423
+166 4359 5231 2548 166 3831 2858 5488 166 5824 166 166 166 3885 4372 166 166
+4024 166 4811 2970 166 4219 211 166 3471 166 166 166 166 3854 166 3358 2877 166
+166 5205 2804 166 166 166 4452 166 166 166 166 3776 166 166 3075 4208 166 5623
+1974 166 2647 166 3235 166 166 166 5211 166 166 4304 2206 166 4157 2182 166
+1816 2626 166 2893 2248 166 166 166 166 1983 5648 166 194 166 2106 4328 166
+4742 166 166 5572 2329 3314 166 6181 166 166 26 166 6026 166 166 2114 1669 4735
+166 166 4256 166 1861 166 5470 2317 166 4404 2482 166 5305 4415 5986 4949 5412
+166 1728 166 1898 166 166 4909 1989 166 166 166 2836 2051 274 166 2799 166 5865
+1663 4705 5121 2555 166 4316 4287 1880 1825 166 3689 166 1733 5012 166 166 2237
+4471 1682 2910 166 5366 166 166 166 166 4532 166 2802 166 166 166 4057 2471 166
+2889 166 166 4026 5682 3091 166 1977 166 2901 6137 5658 88 2318 1965 166 5914
+166 166 4468 1822 166 6050 5956 2201 166 4644 2918 166 3703 166 166 3524 4220
+2913 4210 166 166 2090 166 1906 1911 166 166 3671 2370 166 2552 166 3763 2259
+1924 166 5940 166 166 166 3185 3821 4069 261 2381 3244 166 166 5715 166 2052
+5905 166 2403 166 3030 2199 166 3550 166 166 1846 166 166 95 166 289 3208 2559
+5195 5091 1654 166 1781 1892 166 4516 2629 166 1700 3067 166 166 166 2080 1680
+166 166 166 5700 166 1820 5491 166 4226 166 166 166 166 4653 166 3508 227 5364
+166 2098 166 299 166 5795 166 166 166 166 3690 4134 5517 4534 5042 4874 5798
+4234 166 166 166 166 3702 166 166 3638 3108 3850 166 166 166 16 166 1775 166
+4022 166 223 4095 166 5127 4266 166 189 166 166 5203 166 1805 3884 3778 166 166
+2146 4818 166 2848 3440 4506 5886 3006 218 166 2377 166 4091 5925 166 4320 166
+2701 3036 166 166 166 4715 166 3801 166 3161 166 2077 166 4254 3032 243 1814
+166 166 166 166 166 166 166 166 1835 166 4394 166 5769 4923 166 2917 166 166
+178 166 166 1723 166 5887 166 4956 2952 166 4665 3925 3443 3123 166 166 166 166
+166 166 5144 166 4288 2074 2192 5442 6043 1746 2016 5995 2203 166 5686 5659
+3193 166 4055 166 166 2233 3571 5809 5984 2323 166 166 1740 89 4356 6053 6106
+3282 4796 166 6116 6056 2353 2829 166 5807 2042 166 166 166 1670 5937 4465 5646
+166 5562 3008 166 2419 3736 166 4132 169 166 166 166 2402 166 166 1968 2398 166
+1684 1827 4551 2679 3875 166 5585 3835 2295 166 1991 1803 2992 166 166 5847
+2649 166 76 5415 166 2269 2397 5387 5337 4422 166 2672 4832 4617 166 166 166
+166 4552 166 4612 1750 166 1931 166 1691 2424 4194 6018 166 166 4458 4856 166
+2089 3814 166 2844 166 3592 166 4867 5128 166 2685 166 166 2616 1972 2617 3943
+4664 166 4999 166 166 145 3635 166 166 4851 166 3483 5039 166 3649 3924 166 166
+166 3105 4260 166 6098 166 3568 267 2456 3653 2096 166 166 166 3512 166 3405
+166 3504 166 166 166 4005 2144 1769 166 5474 1920 5554 215 2443 3351 166 5961
+166 166 166 166 242 2331 166 166 5931 166 166 5862 166 1710 166 166 166 3321
+166 4139 166 166 3515 2732 2510 5544 166 166 2783 166 166 166 4018 4649 5789
+166 166 166 166 166 2726 6074 166 166 166 5684 166 166 3395 166 3100 166 5763
+3757 1992 166 3198 2003 166 166 4675 166 1893 5621 166 2270 166 166 166 5421
+5590 5664 4045 166 3687 4406 2699 1811 167 4036 5384 166 166 4601 1823 4041 239
+1954 166 146 166 166 3077 5152 5814 1649 5681 166 5868 166 166 3792 4860 166
+5335 5110 1718 166 166 166 166 3718 3365 2826 166 166 5021 4783 166 5569 5812
+166 166 1876 166 3260 166 1789 5667 4224 166 166 4385 166 166 2620 166 4162
+2883 2143 5497 166 166 5316 5680 166 166 248 4050 166 6021 166 2898 4618 166
+166 166 166 166 5368 166 5378 1842 1914 3696 3962 166 4345 2581 1773 2109 166
+4371 166 166 3761 5277 5870 3146 166 166 166 5764 127 3058 4059 4718 166 5097
+5040 5351 3205 166 166 4996 2991 2014 166 5846 2558 2688 5595 4027 3347 2125
+5696 5608 166 166 3228 3745 5775 166 1757 4647 166 5977 3020 166 240 2565 166
+4459 166 3367 166 166 166 3104 166 166 166 166 166 166 259 5486 2846 166 166
+166 4778 2713 166 3955 5683 2682 2914 5898 166 166 166 4400 317 166 5185 3021
+5983 4332 3891 166 3095 5003 166 166 166 5367 166 279 1784 4019 2736 4905 2651
+5346 166 4841 166 5606 166 166 2806 166 5239 166 166 3237 5490 166 225 166 166
+2254 166 2742 4587 22 166 166 166 5555 166 108 2927 2218 166 2120 166 5452 4087
+4369 166 166 166 166 166 4583 4338 6035 2840 4365 3624 11 1770 166 4630 166
+3216 166 166 166 4638 4699 3535 2536 4627 166 166 5760 1935 166 166 5210 166
+2219 2484 4597 5193 4799 3706 166 166 166 166 3337 3113 5951 4294 166 4040 3200
+4217 5861 2767 3530 4499 2775 4121 134 5939 5880 5908 3869 166 166 3316 6095
+2441 3288 166 3751 4794 166 166 5803 6169 2356 6182 6135 6127 166 3018 166 1674
+166 166 4097 166 5923 287 5965 5129 166 4078 166 166 6114 6015 5990 3573 166
+4146 2681 90 6055 4864 166 166 6119 3284 6054 5456 5113 6125 166 6057 166 3292
+166 166 166 166 166 6185 5105 1760 166 166 166 2720 166 2695 5448 166 1936 166
+1807 3406 166 166 2161 1642 166 5030 166 2036 5451 3427 166 166 166 166 3797
+166 1627 166 4515 166 166 166 4241 166 166 166 2771 166 31 5197 2638 3035 166
+166 3914 166 166 4546 166 166 166 4253 3500 166 166 2526 166 2698 166 3726 2744
+137 166 166 2676 166 5594 166 166 166 4842 166 63 2888 3585 4798 166 5011 166
+5634 5464 166 166 5620 3894 4070 166 2730 166 166 1810 2503 5957 1721 6066 5188
+166 166 1890 4505 1771 5455 166 3132 3984 166 166 2811 1962 166 166 4872 106
+3898 3267 166 2085 166 4950 6040 4525 6044 5866 3613 2907 4615 2135 258 166
+1681 1941 4888 166 4859 6178 6174 4858 5209 1912 3340 166 4640 5706 166 2763
+3153 3951 166 5542 5596 5819 5330 5048 4037 166 6033 4625 3326 2013 5283 136
+3373 2154 166 166 166 4421 166 5438 2627 2266 2320 166 2588 4790 4290 166 4767
+5829 2925 5916 2133 166 }
diff --git a/extra/poker/authors.txt b/extra/poker/authors.txt
new file mode 100644
index 0000000000..fbbb745b7d
--- /dev/null
+++ b/extra/poker/authors.txt
@@ -0,0 +1 @@
+Aaron Schaefer
\ No newline at end of file
diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor
new file mode 100644
index 0000000000..09019a29d7
--- /dev/null
+++ b/extra/poker/poker-docs.factor
@@ -0,0 +1,30 @@
+USING: help.markup help.syntax strings ;
+IN: poker
+
+HELP: <hand>
+{ $values { "str" string } { "hand" "a new hand" } }
+{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
+{ $examples
+ { $example "USING: kernel math.order poker prettyprint ;"
+ "\"AC KC QC JC TC\" \"7C 6D 5H 4S 2C\" [ <hand> ] bi@ <=> ." "+lt+" }
+ { $example "USING: kernel poker prettyprint ;"
+ "\"TC 9C 8C 7C 6C\" \"TH 9H 8H 7H 6H\" [ <hand> ] bi@ = ." "t" }
+}
+{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
+
+HELP: >cards
+{ $values { "hand" "a hand" } { "str" string } }
+{ $description "Outputs a string representation of a hand's cards." }
+{ $examples
+ { $example "USING: poker prettyprint ;"
+ "\"AC KC QC JC TC\" <hand> >cards ." "\"AC KC QC JC TC\"" }
+} ;
+
+HELP: >value
+{ $values { "hand" "a hand" } { "str" string } }
+{ $description "Outputs a string representation of a hand's value." }
+{ $examples
+ { $example "USING: poker prettyprint ;"
+ "\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
+}
+{ $notes "This should not be used as a basis for hand comparison." } ;
diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor
new file mode 100644
index 0000000000..ad371a6bff
--- /dev/null
+++ b/extra/poker/poker-tests.factor
@@ -0,0 +1,28 @@
+USING: accessors poker poker.private tools.test math.order kernel ;
+IN: poker.tests
+
+[ 134236965 ] [ "KD" >ckf ] unit-test
+[ 529159 ] [ "5s" >ckf ] unit-test
+[ 33589533 ] [ "jc" >ckf ] unit-test
+
+[ 7462 ] [ "7C 5D 4H 3S 2C" <hand> value>> ] unit-test
+[ 1601 ] [ "KD QS JC TH 9S" <hand> value>> ] unit-test
+[ 11 ] [ "AC AD AH AS KC" <hand> value>> ] unit-test
+[ 9 ] [ "6C 5C 4C 3C 2C" <hand> value>> ] unit-test
+[ 1 ] [ "AC KC QC JC TC" <hand> value>> ] unit-test
+
+[ "High Card" ] [ "7C 5D 4H 3S 2C" <hand> >value ] unit-test
+[ "Straight" ] [ "KD QS JC TH 9S" <hand> >value ] unit-test
+[ "Four of a Kind" ] [ "AC AD AH AS KC" <hand> >value ] unit-test
+[ "Straight Flush" ] [ "6C 5C 4C 3C 2C" <hand> >value ] unit-test
+
+[ "6C 5C 4C 3C 2C" ] [ "6C 5C 4C 3C 2C" <hand> >cards ] unit-test
+
+[ +gt+ ] [ "7C 5D 4H 3S 2C" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
+[ +lt+ ] [ "AC AD AH AS KC" "KD QS JC TH 9S" [ <hand> ] bi@ <=> ] unit-test
+[ +eq+ ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ <=> ] unit-test
+
+[ t ] [ "7C 5D 4H 3S 2C" "2C 3S 4H 5D 7C" [ <hand> ] bi@ = ] unit-test
+
+[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
+[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test
diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor
new file mode 100644
index 0000000000..e8e9fa23c5
--- /dev/null
+++ b/extra/poker/poker.factor
@@ -0,0 +1,188 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors ascii binary-search combinators kernel locals math
+ math.bitwise math.order poker.arrays sequences splitting ;
+IN: poker
+
+! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
+! the Senzee Perfect Hash Optimization:
+! http://www.suffecool.net/poker/evaluator.html
+! http://www.senzee5.com/2006/06/some-perfect-hash.html
+
+<PRIVATE
+
+! Bitfield Format for Card Values:
+
+! +-------------------------------------+
+! | xxxbbbbb bbbbbbbb ssssrrrr xxpppppp |
+! +-------------------------------------+
+! xxxAKQJT 98765432 CDHSrrrr xxpppppp
+! +-------------------------------------+
+! | 00001000 00000000 01001011 00100101 | King of Diamonds
+! | 00000000 00001000 00010011 00000111 | Five of Spades
+! | 00000010 00000000 10001001 00011101 | Jack of Clubs
+
+! p = prime number value of rank (deuce = 2, trey = 3, four = 5, ..., ace = 41)
+! r = rank of card (deuce = 0, trey = 1, four = 2, ..., ace = 12)
+! s = bit turned on depending on suit of card
+! b = bit turned on depending on rank of card
+! x = bit turned off, not used
+
+CONSTANT: CLUB 8
+CONSTANT: DIAMOND 4
+CONSTANT: HEART 2
+CONSTANT: SPADE 1
+
+CONSTANT: DEUCE 0
+CONSTANT: TREY 1
+CONSTANT: FOUR 2
+CONSTANT: FIVE 3
+CONSTANT: SIX 4
+CONSTANT: SEVEN 5
+CONSTANT: EIGHT 6
+CONSTANT: NINE 7
+CONSTANT: TEN 8
+CONSTANT: JACK 9
+CONSTANT: QUEEN 10
+CONSTANT: KING 11
+CONSTANT: ACE 12
+
+CONSTANT: STRAIGHT_FLUSH 1
+CONSTANT: FOUR_OF_A_KIND 2
+CONSTANT: FULL_HOUSE 3
+CONSTANT: FLUSH 4
+CONSTANT: STRAIGHT 5
+CONSTANT: THREE_OF_A_KIND 6
+CONSTANT: TWO_PAIR 7
+CONSTANT: ONE_PAIR 8
+CONSTANT: HIGH_CARD 9
+
+CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
+
+CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
+ "Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
+
+: card-rank-prime ( rank -- n )
+ RANK_STR index { 2 3 5 7 11 13 17 19 23 29 31 37 41 } nth ;
+
+: card-rank ( rank -- n )
+ {
+ { "2" [ DEUCE ] }
+ { "3" [ TREY ] }
+ { "4" [ FOUR ] }
+ { "5" [ FIVE ] }
+ { "6" [ SIX ] }
+ { "7" [ SEVEN ] }
+ { "8" [ EIGHT ] }
+ { "9" [ NINE ] }
+ { "T" [ TEN ] }
+ { "J" [ JACK ] }
+ { "Q" [ QUEEN ] }
+ { "K" [ KING ] }
+ { "A" [ ACE ] }
+ } case ;
+
+: card-suit ( suit -- n )
+ {
+ { "C" [ CLUB ] }
+ { "D" [ DIAMOND ] }
+ { "H" [ HEART ] }
+ { "S" [ SPADE ] }
+ } case ;
+
+: card-rank-bit ( rank -- n )
+ RANK_STR index 1 swap shift ;
+
+: card-bitfield ( rank rank suit rank -- n )
+ {
+ { card-rank-bit 16 }
+ { card-suit 12 }
+ { card-rank 8 }
+ { card-rank-prime 0 }
+ } bitfield ;
+
+:: (>ckf) ( rank suit -- n )
+ rank rank suit rank card-bitfield ;
+
+: >ckf ( str -- n )
+ #! Cactus Kev Format
+ >upper 1 cut (>ckf) ;
+
+: flush? ( cards -- ? )
+ HEX: F000 [ bitand ] reduce 0 = not ;
+
+: rank-bits ( cards -- q )
+ 0 [ bitor ] reduce -16 shift ;
+
+: lookup ( cards table -- value )
+ [ rank-bits ] dip nth ;
+
+: map-product ( seq quot -- n )
+ [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
+
+: prime-bits ( cards -- q )
+ [ HEX: FF bitand ] map-product ;
+
+: perfect-hash-find ( q -- value )
+ #! magic to convert a hand's unique identifying bits to the
+ #! proper index for fast lookup in a table of hand values
+ HEX: E91AAA35 +
+ dup -16 shift bitxor
+ dup 8 shift w+
+ dup -4 shift bitxor
+ [ -8 shift HEX: 1FF bitand adjustments-table nth ]
+ [ dup 2 shift w+ -19 shift ] bi
+ bitxor values-table nth ;
+
+: hand-value ( cards -- value )
+ dup flush? [ flushes-table lookup ] [
+ dup unique5-table lookup dup 0 > [ nip ] [
+ drop prime-bits perfect-hash-find
+ ] if
+ ] if ;
+
+: >card-rank ( card -- str )
+ -8 shift HEX: F bitand RANK_STR nth ;
+
+: >card-suit ( card -- str )
+ {
+ { [ dup 15 bit? ] [ drop "C" ] }
+ { [ dup 14 bit? ] [ drop "D" ] }
+ { [ dup 13 bit? ] [ drop "H" ] }
+ [ drop "S" ]
+ } cond ;
+
+: hand-rank ( hand -- rank )
+ value>> {
+ { [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
+ { [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
+ { [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
+ { [ dup 1609 > ] [ drop THREE_OF_A_KIND ] } ! 858 three-kind
+ { [ dup 1599 > ] [ drop STRAIGHT ] } ! 10 straights
+ { [ dup 322 > ] [ drop FLUSH ] } ! 1277 flushes
+ { [ dup 166 > ] [ drop FULL_HOUSE ] } ! 156 full house
+ { [ dup 10 > ] [ drop FOUR_OF_A_KIND ] } ! 156 four-kind
+ [ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
+ } cond ;
+
+PRIVATE>
+
+TUPLE: hand
+ { cards sequence }
+ { value integer } ;
+
+M: hand <=> [ value>> ] compare ;
+M: hand equal?
+ over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
+
+: <hand> ( str -- hand )
+ " " split [ >ckf ] map
+ dup hand-value hand boa ;
+
+: >cards ( hand -- str )
+ cards>> [
+ [ >card-rank ] [ >card-suit ] bi append
+ ] map " " join ;
+
+: >value ( hand -- str )
+ hand-rank VALUE_STR nth ;
diff --git a/extra/poker/summary.txt b/extra/poker/summary.txt
new file mode 100644
index 0000000000..c8efe851c8
--- /dev/null
+++ b/extra/poker/summary.txt
@@ -0,0 +1 @@
+5-card poker hand evaluator
diff --git a/extra/project-euler/001/001-tests.factor b/extra/project-euler/001/001-tests.factor
index 1cab275619..32a72dfaf0 100644
--- a/extra/project-euler/001/001-tests.factor
+++ b/extra/project-euler/001/001-tests.factor
@@ -5,3 +5,4 @@ IN: project-euler.001.tests
[ 233168 ] [ euler001a ] unit-test
[ 233168 ] [ euler001b ] unit-test
[ 233168 ] [ euler001c ] unit-test
+[ 233168 ] [ euler001d ] unit-test
diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor
index 20e08242c5..0d4f5fb1bd 100644
--- a/extra/project-euler/001/001.factor
+++ b/extra/project-euler/001/001.factor
@@ -1,6 +1,7 @@
! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.ranges project-euler.common sequences
+ sets ;
IN: project-euler.001
! http://projecteuler.net/index.php?section=problems&id=1
@@ -32,7 +33,7 @@ PRIVATE>
999 15 sum-divisible-by - ;
! [ euler001 ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.0 SD (100 trials)
! ALTERNATE SOLUTIONS
@@ -42,14 +43,14 @@ PRIVATE>
0 999 3 <range> sum 0 999 5 <range> sum + 0 999 15 <range> sum - ;
! [ euler001a ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.03 SD (100 trials)
: euler001b ( -- answer )
1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
-! 0 ms run / 0 ms GC ave time - 100 trials
+! 0 ms ave run time - 0.06 SD (100 trials)
: euler001c ( -- answer )
@@ -58,4 +59,11 @@ PRIVATE>
! [ euler001c ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
+
+: euler001d ( -- answer )
+ { 3 5 } [ [ 999 ] keep <range> ] gather sum ;
+
+! [ euler001d ] 100 ave-time
+! 0 ms ave run time - 0.08 SD (100 trials)
+
SOLUTION: euler001
diff --git a/extra/project-euler/007/007.factor b/extra/project-euler/007/007.factor
index f9208e11b3..1827d0fa06 100644
--- a/extra/project-euler/007/007.factor
+++ b/extra/project-euler/007/007.factor
@@ -17,9 +17,6 @@ IN: project-euler.007
! SOLUTION
! --------
-: nth-prime ( n -- n )
- 1- lprimes lnth ;
-
: euler007 ( -- answer )
10001 nth-prime ;
diff --git a/extra/project-euler/011/011.factor b/extra/project-euler/011/011.factor
index 9d98ac6766..beed787fba 100644
--- a/extra/project-euler/011/011.factor
+++ b/extra/project-euler/011/011.factor
@@ -95,7 +95,7 @@ PRIVATE>
: euler011 ( -- answer )
[
{ [ horizontal ] [ vertical ] [ diagonal/ ] [ diagonal\ ] }
- [ call 4 max-product , ] each
+ [ call( -- matrix ) 4 max-product , ] each
] { } make supremum ;
! [ euler011 ] 100 ave-time
diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor
index a4aded7096..9c7c4fee74 100644
--- a/extra/project-euler/018/018.factor
+++ b/extra/project-euler/018/018.factor
@@ -66,7 +66,7 @@ IN: project-euler.018
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
- } 15 [ 1+ cut swap ] map nip ;
+ } 15 iota [ 1+ cut swap ] map nip ;
PRIVATE>
diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor
index 5ff5234679..64c9ec445e 100755
--- a/extra/project-euler/032/032.factor
+++ b/extra/project-euler/032/032.factor
@@ -27,7 +27,9 @@ IN: project-euler.032
<PRIVATE
: source-032 ( -- seq )
- 9 factorial [ 9 permutation [ 1+ ] map 10 digits>integer ] map ;
+ 9 factorial iota [
+ 9 permutation [ 1+ ] map 10 digits>integer
+ ] map ;
: 1and4 ( n -- ? )
number>string 1 cut-slice 4 cut-slice
diff --git a/extra/project-euler/054/054-tests.factor b/extra/project-euler/054/054-tests.factor
new file mode 100644
index 0000000000..31e915c70c
--- /dev/null
+++ b/extra/project-euler/054/054-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.054 tools.test ;
+IN: project-euler.054.tests
+
+[ 376 ] [ euler054 ] unit-test
diff --git a/extra/project-euler/054/054.factor b/extra/project-euler/054/054.factor
new file mode 100644
index 0000000000..5cf42737fb
--- /dev/null
+++ b/extra/project-euler/054/054.factor
@@ -0,0 +1,84 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays io.encodings.ascii io.files kernel math.order poker
+ project-euler.common sequences ;
+IN: project-euler.054
+
+! http://projecteuler.net/index.php?section=problems&id=54
+
+! DESCRIPTION
+! -----------
+
+! In the card game poker, a hand consists of five cards and are ranked, from
+! lowest to highest, in the following way:
+
+! * High Card: Highest value card.
+! * One Pair: Two cards of the same value.
+! * Two Pairs: Two different pairs.
+! * Three of a Kind: Three cards of the same value.
+! * Straight: All cards are consecutive values.
+! * Flush: All cards of the same suit.
+! * Full House: Three of a kind and a pair.
+! * Four of a Kind: Four cards of the same value.
+! * Straight Flush: All cards are consecutive values of same suit.
+! * Royal Flush: Ten, Jack, Queen, King, Ace, in same suit.
+
+! The cards are valued in the order:
+! 2, 3, 4, 5, 6, 7, 8, 9, 10, Jack, Queen, King, Ace.
+
+! If two players have the same ranked hands then the rank made up of the
+! highest value wins; for example, a pair of eights beats a pair of fives (see
+! example 1 below). But if two ranks tie, for example, both players have a pair
+! of queens, then highest cards in each hand are compared (see example 4
+! below); if the highest cards tie then the next highest cards are compared,
+! and so on.
+
+! Consider the following five hands dealt to two players:
+
+! Hand Player 1 Player 2 Winner
+! ---------------------------------------------------------
+! 1 5H 5C 6S 7S KD 2C 3S 8S 8D TD
+! Pair of Fives Pair of Eights Player 2
+
+! 2 5D 8C 9S JS AC 2C 5C 7D 8S QH
+! Highest card Ace Highest card Queen Player 1
+
+! 3 2D 9C AS AH AC 3D 6D 7D TD QD
+! Three Aces Flush with Diamonds Player 2
+
+! 4 4D 6S 9H QH QC 3D 6D 7H QD QS
+! Pair of Queens Pair of Queens
+! Highest card Nine Highest card Seven Player 1
+
+! 5 2H 2D 4C 4D 4S 3C 3D 3S 9S 9D
+! Full House Full House
+! With Three Fours With Three Threes Player 1
+
+! The file, poker.txt, contains one-thousand random hands dealt to two players.
+! Each line of the file contains ten cards (separated by a single space): the
+! first five are Player 1's cards and the last five are Player 2's cards. You
+! can assume that all hands are valid (no invalid characters or repeated
+! cards), each player's hand is in no specific order, and in each hand there is
+! a clear winner.
+
+! How many hands does Player 1 win?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: source-054 ( -- seq )
+ "resource:extra/project-euler/054/poker.txt" ascii file-lines
+ [ [ 14 head-slice ] [ 14 tail-slice* ] bi 2array ] map ;
+
+PRIVATE>
+
+: euler054 ( -- answer )
+ source-054 [ [ <hand> ] map first2 before? ] count ;
+
+! [ euler054 ] 100 ave-time
+! 34 ms ave run time - 2.65 SD (100 trials)
+
+SOLUTION: euler054
diff --git a/extra/project-euler/054/poker.txt b/extra/project-euler/054/poker.txt
new file mode 100644
index 0000000000..231e249533
--- /dev/null
+++ b/extra/project-euler/054/poker.txt
@@ -0,0 +1,1000 @@
+8C TS KC 9H 4S 7D 2S 5D 3S AC
+5C AD 5D AC 9C 7C 5H 8D TD KS
+3H 7H 6S KC JS QH TD JC 2D 8S
+TH 8H 5C QS TC 9H 4D JC KS JS
+7C 5H KC QH JD AS KH 4C AD 4S
+5H KS 9C 7D 9H 8D 3S 5D 5C AH
+6H 4H 5C 3H 2H 3S QH 5S 6S AS
+TD 8C 4H 7C TC KC 4C 3H 7S KS
+7C 9C 6D KD 3H 4C QS QC AC KH
+JC 6S 5H 2H 2D KD 9D 7C AS JS
+AD QH TH 9D 8H TS 6D 3S AS AC
+2H 4S 5C 5S TC KC JD 6C TS 3C
+QD AS 6H JS 2C 3D 9H KC 4H 8S
+KD 8S 9S 7C 2S 3S 6D 6S 4H KC
+3C 8C 2D 7D 4D 9S 4S QH 4H JD
+8C KC 7S TC 2D TS 8H QD AC 5C
+3D KH QD 6C 6S AD AS 8H 2H QS
+6S 8D 4C 8S 6C QH TC 6D 7D 9D
+2S 8D 8C 4C TS 9S 9D 9C AC 3D
+3C QS 2S 4H JH 3D 2D TD 8S 9H
+5H QS 8S 6D 3C 8C JD AS 7H 7D
+6H TD 9D AS JH 6C QC 9S KD JC
+AH 8S QS 4D TH AC TS 3C 3D 5C
+5S 4D JS 3D 8H 6C TS 3S AD 8C
+6D 7C 5D 5H 3S 5C JC 2H 5S 3D
+5H 6H 2S KS 3D 5D JD 7H JS 8H
+KH 4H AS JS QS QC TC 6D 7C KS
+3D QS TS 2H JS 4D AS 9S JC KD
+QD 5H 4D 5D KH 7H 3D JS KD 4H
+2C 9H 6H 5C 9D 6C JC 2D TH 9S
+7D 6D AS QD JH 4D JS 7C QS 5C
+3H KH QD AD 8C 8H 3S TH 9D 5S
+AH 9S 4D 9D 8S 4H JS 3C TC 8D
+2C KS 5H QD 3S TS 9H AH AD 8S
+5C 7H 5D KD 9H 4D 3D 2D KS AD
+KS KC 9S 6D 2C QH 9D 9H TS TC
+9C 6H 5D QH 4D AD 6D QC JS KH
+9S 3H 9D JD 5C 4D 9H AS TC QH
+2C 6D JC 9C 3C AD 9S KH 9D 7D
+KC 9C 7C JC JS KD 3H AS 3C 7D
+QD KH QS 2C 3S 8S 8H 9H 9C JC
+QH 8D 3C KC 4C 4H 6D AD 9H 9D
+3S KS QS 7H KH 7D 5H 5D JD AD
+2H 2C 6H TH TC 7D 8D 4H 8C AS
+4S 2H AC QC 3S 6D TH 4D 4C KH
+4D TC KS AS 7C 3C 6D 2D 9H 6C
+8C TD 5D QS 2C 7H 4C 9C 3H 9H
+5H JH TS 7S TD 6H AD QD 8H 8S
+5S AD 9C 8C 7C 8D 5H 9D 8S 2S
+4H KH KS 9S 2S KC 5S AD 4S 7D
+QS 9C QD 6H JS 5D AC 8D 2S AS
+KH AC JC 3S 9D 9S 3C 9C 5S JS
+AD 3C 3D KS 3S 5C 9C 8C TS 4S
+JH 8D 5D 6H KD QS QD 3D 6C KC
+8S JD 6C 3S 8C TC QC 3C QH JS
+KC JC 8H 2S 9H 9C JH 8S 8C 9S
+8S 2H QH 4D QC 9D KC AS TH 3C
+8S 6H TH 7C 2H 6S 3C 3H AS 7S
+QH 5S JS 4H 5H TS 8H AH AC JC
+9D 8H 2S 4S TC JC 3C 7H 3H 5C
+3D AD 3C 3S 4C QC AS 5D TH 8C
+6S 9D 4C JS KH AH TS JD 8H AD
+4C 6S 9D 7S AC 4D 3D 3S TC JD
+AD 7H 6H 4H JH KC TD TS 7D 6S
+8H JH TC 3S 8D 8C 9S 2C 5C 4D
+2C 9D KC QH TH QS JC 9C 4H TS
+QS 3C QD 8H KH 4H 8D TD 8S AC
+7C 3C TH 5S 8H 8C 9C JD TC KD
+QC TC JD TS 8C 3H 6H KD 7C TD
+JH QS KS 9C 6D 6S AS 9H KH 6H
+2H 4D AH 2D JH 6H TD 5D 4H JD
+KD 8C 9S JH QD JS 2C QS 5C 7C
+4S TC 7H 8D 2S 6H 7S 9C 7C KC
+8C 5D 7H 4S TD QC 8S JS 4H KS
+AD 8S JH 6D TD KD 7C 6C 2D 7D
+JC 6H 6S JS 4H QH 9H AH 4C 3C
+6H 5H AS 7C 7S 3D KH KC 5D 5C
+JC 3D TD AS 4D 6D 6S QH JD KS
+8C 7S 8S QH 2S JD 5C 7H AH QD
+8S 3C 6H 6C 2C 8D TD 7D 4C 4D
+5D QH KH 7C 2S 7H JS 6D QC QD
+AD 6C 6S 7D TH 6H 2H 8H KH 4H
+KS JS KD 5D 2D KH 7D 9C 8C 3D
+9C 6D QD 3C KS 3S 7S AH JD 2D
+AH QH AS JC 8S 8H 4C KC TH 7D
+JC 5H TD 7C 5D KD 4C AD 8H JS
+KC 2H AC AH 7D JH KH 5D 7S 6D
+9S 5S 9C 6H 8S TD JD 9H 6C AC
+7D 8S 6D TS KD 7H AC 5S 7C 5D
+AH QC JC 4C TC 8C 2H TS 2C 7D
+KD KC 6S 3D 7D 2S 8S 3H 5S 5C
+8S 5D 8H 4C 6H KC 3H 7C 5S KD
+JH 8C 3D 3C 6C KC TD 7H 7C 4C
+JC KC 6H TS QS TD KS 8H 8C 9S
+6C 5S 9C QH 7D AH KS KC 9S 2C
+4D 4S 8H TD 9C 3S 7D 9D AS TH
+6S 7D 3C 6H 5D KD 2C 5C 9D 9C
+2H KC 3D AD 3H QD QS 8D JC 4S
+8C 3H 9C 7C AD 5D JC 9D JS AS
+5D 9H 5C 7H 6S 6C QC JC QD 9S
+JC QS JH 2C 6S 9C QC 3D 4S TC
+4H 5S 8D 3D 4D 2S KC 2H JS 2C
+TD 3S TH KD 4D 7H JH JS KS AC
+7S 8C 9S 2D 8S 7D 5C AD 9D AS
+8C 7H 2S 6C TH 3H 4C 3S 8H AC
+KD 5H JC 8H JD 2D 4H TD JH 5C
+3D AS QH KS 7H JD 8S 5S 6D 5H
+9S 6S TC QS JC 5C 5D 9C TH 8C
+5H 3S JH 9H 2S 2C 6S 7S AS KS
+8C QD JC QS TC QC 4H AC KH 6C
+TC 5H 7D JH 4H 2H 8D JC KS 4D
+5S 9C KH KD 9H 5C TS 3D 7D 2D
+5H AS TC 4D 8C 2C TS 9D 3H 8D
+6H 8D 2D 9H JD 6C 4S 5H 5S 6D
+AD 9C JC 7D 6H 9S 6D JS 9H 3C
+AD JH TC QS 4C 5D 9S 7C 9C AH
+KD 6H 2H TH 8S QD KS 9D 9H AS
+4H 8H 8D 5H 6C AH 5S AS AD 8S
+QS 5D 4S 2H TD KS 5H AC 3H JC
+9C 7D QD KD AC 6D 5H QH 6H 5S
+KC AH QH 2H 7D QS 3H KS 7S JD
+6C 8S 3H 6D KS QD 5D 5C 8H TC
+9H 4D 4S 6S 9D KH QC 4H 6C JD
+TD 2D QH 4S 6H JH KD 3C QD 8C
+4S 6H 7C QD 9D AS AH 6S AD 3C
+2C KC TH 6H 8D AH 5C 6D 8S 5D
+TD TS 7C AD JC QD 9H 3C KC 7H
+5D 4D 5S 8H 4H 7D 3H JD KD 2D
+JH TD 6H QS 4S KD 5C 8S 7D 8H
+AC 3D AS 8C TD 7H KH 5D 6C JD
+9D KS 7C 6D QH TC JD KD AS KC
+JH 8S 5S 7S 7D AS 2D 3D AD 2H
+2H 5D AS 3C QD KC 6H 9H 9S 2C
+9D 5D TH 4C JH 3H 8D TC 8H 9H
+6H KD 2C TD 2H 6C 9D 2D JS 8C
+KD 7S 3C 7C AS QH TS AD 8C 2S
+QS 8H 6C JS 4C 9S QC AD TD TS
+2H 7C TS TC 8C 3C 9H 2D 6D JC
+TC 2H 8D JH KS 6D 3H TD TH 8H
+9D TD 9H QC 5D 6C 8H 8C KC TS
+2H 8C 3D AH 4D TH TC 7D 8H KC
+TS 5C 2D 8C 6S KH AH 5H 6H KC
+5S 5D AH TC 4C JD 8D 6H 8C 6C
+KC QD 3D 8H 2D JC 9H 4H AD 2S
+TD 6S 7D JS KD 4H QS 2S 3S 8C
+4C 9H JH TS 3S 4H QC 5S 9S 9C
+2C KD 9H JS 9S 3H JC TS 5D AC
+AS 2H 5D AD 5H JC 7S TD JS 4C
+2D 4S 8H 3D 7D 2C AD KD 9C TS
+7H QD JH 5H JS AC 3D TH 4C 8H
+6D KH KC QD 5C AD 7C 2D 4H AC
+3D 9D TC 8S QD 2C JC 4H JD AH
+6C TD 5S TC 8S AH 2C 5D AS AC
+TH 7S 3D AS 6C 4C 7H 7D 4H AH
+5C 2H KS 6H 7S 4H 5H 3D 3C 7H
+3C 9S AC 7S QH 2H 3D 6S 3S 3H
+2D 3H AS 2C 6H TC JS 6S 9C 6C
+QH KD QD 6D AC 6H KH 2C TS 8C
+8H 7D 3S 9H 5D 3H 4S QC 9S 5H
+2D 9D 7H 6H 3C 8S 5H 4D 3S 4S
+KD 9S 4S TC 7S QC 3S 8S 2H 7H
+TC 3D 8C 3H 6C 2H 6H KS KD 4D
+KC 3D 9S 3H JS 4S 8H 2D 6C 8S
+6H QS 6C TC QD 9H 7D 7C 5H 4D
+TD 9D 8D 6S 6C TC 5D TS JS 8H
+4H KC JD 9H TC 2C 6S 5H 8H AS
+JS 9C 5C 6S 9D JD 8H KC 4C 6D
+4D 8D 8S 6C 7C 6H 7H 8H 5C KC
+TC 3D JC 6D KS 9S 6H 7S 9C 2C
+6C 3S KD 5H TS 7D 9H 9S 6H KH
+3D QD 4C 6H TS AC 3S 5C 2H KD
+4C AS JS 9S 7C TS 7H 9H JC KS
+4H 8C JD 3H 6H AD 9S 4S 5S KS
+4C 2C 7D 3D AS 9C 2S QS KC 6C
+8S 5H 3D 2S AC 9D 6S 3S 4D TD
+QD TH 7S TS 3D AC 7H 6C 5D QC
+TC QD AD 9C QS 5C 8D KD 3D 3C
+9D 8H AS 3S 7C 8S JD 2D 8D KC
+4C TH AC QH JS 8D 7D 7S 9C KH
+9D 8D 4C JH 2C 2S QD KD TS 4H
+4D 6D 5D 2D JH 3S 8S 3H TC KH
+AD 4D 2C QS 8C KD JH JD AH 5C
+5C 6C 5H 2H JH 4H KS 7C TC 3H
+3C 4C QC 5D JH 9C QD KH 8D TC
+3H 9C JS 7H QH AS 7C 9H 5H JC
+2D 5S QD 4S 3C KC 6S 6C 5C 4C
+5D KH 2D TS 8S 9C AS 9S 7C 4C
+7C AH 8C 8D 5S KD QH QS JH 2C
+8C 9D AH 2H AC QC 5S 8H 7H 2C
+QD 9H 5S QS QC 9C 5H JC TH 4H
+6C 6S 3H 5H 3S 6H KS 8D AC 7S
+AC QH 7H 8C 4S KC 6C 3D 3S TC
+9D 3D JS TH AC 5H 3H 8S 3S TC
+QD KH JS KS 9S QC 8D AH 3C AC
+5H 6C KH 3S 9S JH 2D QD AS 8C
+6C 4D 7S 7H 5S JC 6S 9H 4H JH
+AH 5S 6H 9S AD 3S TH 2H 9D 8C
+4C 8D 9H 7C QC AD 4S 9C KC 5S
+9D 6H 4D TC 4C JH 2S 5D 3S AS
+2H 6C 7C KH 5C AD QS TH JD 8S
+3S 4S 7S AH AS KC JS 2S AD TH
+JS KC 2S 7D 8C 5C 9C TS 5H 9D
+7S 9S 4D TD JH JS KH 6H 5D 2C
+JD JS JC TH 2D 3D QD 8C AC 5H
+7S KH 5S 9D 5D TD 4S 6H 3C 2D
+4S 5D AC 8D 4D 7C AD AS AH 9C
+6S TH TS KS 2C QC AH AS 3C 4S
+2H 8C 3S JC 5C 7C 3H 3C KH JH
+7S 3H JC 5S 6H 4C 2S 4D KC 7H
+4D 7C 4H 9S 8S 6S AD TC 6C JC
+KH QS 3S TC 4C 8H 8S AC 3C TS
+QD QS TH 3C TS 7H 7D AH TD JC
+TD JD QC 4D 9S 7S TS AD 7D AC
+AH 7H 4S 6D 7C 2H 9D KS JC TD
+7C AH JD 4H 6D QS TS 2H 2C 5C
+TC KC 8C 9S 4C JS 3C JC 6S AH
+AS 7D QC 3D 5S JC JD 9D TD KH
+TH 3C 2S 6H AH AC 5H 5C 7S 8H
+QC 2D AC QD 2S 3S JD QS 6S 8H
+KC 4H 3C 9D JS 6H 3S 8S AS 8C
+7H KC 7D JD 2H JC QH 5S 3H QS
+9H TD 3S 8H 7S AC 5C 6C AH 7C
+8D 9H AH JD TD QS 7D 3S 9C 8S
+AH QH 3C JD KC 4S 5S 5D TD KS
+9H 7H 6S JH TH 4C 7C AD 5C 2D
+7C KD 5S TC 9D 6S 6C 5D 2S TH
+KC 9H 8D 5H 7H 4H QC 3D 7C AS
+6S 8S QC TD 4S 5C TH QS QD 2S
+8S 5H TH QC 9H 6S KC 7D 7C 5C
+7H KD AH 4D KH 5C 4S 2D KC QH
+6S 2C TD JC AS 4D 6C 8C 4H 5S
+JC TC JD 5S 6S 8D AS 9D AD 3S
+6D 6H 5D 5S TC 3D 7D QS 9D QD
+4S 6C 8S 3S 7S AD KS 2D 7D 7C
+KC QH JC AC QD 5D 8D QS 7H 7D
+JS AH 8S 5H 3D TD 3H 4S 6C JH
+4S QS 7D AS 9H JS KS 6D TC 5C
+2D 5C 6H TC 4D QH 3D 9H 8S 6C
+6D 7H TC TH 5S JD 5C 9C KS KD
+8D TD QH 6S 4S 6C 8S KC 5C TC
+5S 3D KS AC 4S 7D QD 4C TH 2S
+TS 8H 9S 6S 7S QH 3C AH 7H 8C
+4C 8C TS JS QC 3D 7D 5D 7S JH
+8S 7S 9D QC AC 7C 6D 2H JH KC
+JS KD 3C 6S 4S 7C AH QC KS 5H
+KS 6S 4H JD QS TC 8H KC 6H AS
+KH 7C TC 6S TD JC 5C 7D AH 3S
+3H 4C 4H TC TH 6S 7H 6D 9C QH
+7D 5H 4S 8C JS 4D 3D 8S QH KC
+3H 6S AD 7H 3S QC 8S 4S 7S JS
+3S JD KH TH 6H QS 9C 6C 2D QD
+4S QH 4D 5H KC 7D 6D 8D TH 5S
+TD AD 6S 7H KD KH 9H 5S KC JC
+3H QC AS TS 4S QD KS 9C 7S KC
+TS 6S QC 6C TH TC 9D 5C 5D KD
+JS 3S 4H KD 4C QD 6D 9S JC 9D
+8S JS 6D 4H JH 6H 6S 6C KS KH
+AC 7D 5D TC 9S KH 6S QD 6H AS
+AS 7H 6D QH 8D TH 2S KH 5C 5H
+4C 7C 3D QC TC 4S KH 8C 2D JS
+6H 5D 7S 5H 9C 9H JH 8S TH 7H
+AS JS 2S QD KH 8H 4S AC 8D 8S
+3H 4C TD KD 8C JC 5C QS 2D JD
+TS 7D 5D 6C 2C QS 2H 3C AH KS
+4S 7C 9C 7D JH 6C 5C 8H 9D QD
+2S TD 7S 6D 9C 9S QS KH QH 5C
+JC 6S 9C QH JH 8D 7S JS KH 2H
+8D 5H TH KC 4D 4S 3S 6S 3D QS
+2D JD 4C TD 7C 6D TH 7S JC AH
+QS 7S 4C TH 9D TS AD 4D 3H 6H
+2D 3H 7D JD 3D AS 2S 9C QC 8S
+4H 9H 9C 2C 7S JH KD 5C 5D 6H
+TC 9H 8H JC 3C 9S 8D KS AD KC
+TS 5H JD QS QH QC 8D 5D KH AH
+5D AS 8S 6S 4C AH QC QD TH 7H
+3H 4H 7D 6S 4S 9H AS 8H JS 9D
+JD 8C 2C 9D 7D 5H 5S 9S JC KD
+KD 9C 4S QD AH 7C AD 9D AC TD
+6S 4H 4S 9C 8D KS TC 9D JH 7C
+5S JC 5H 4S QH AC 2C JS 2S 9S
+8C 5H AS QD AD 5C 7D 8S QC TD
+JC 4C 8D 5C KH QS 4D 6H 2H 2C
+TH 4S 2D KC 3H QD AC 7H AD 9D
+KH QD AS 8H TH KC 8D 7S QH 8C
+JC 6C 7D 8C KH AD QS 2H 6S 2D
+JC KH 2D 7D JS QC 5H 4C 5D AD
+TS 3S AD 4S TD 2D TH 6S 9H JH
+9H 2D QS 2C 4S 3D KH AS AC 9D
+KH 6S 8H 4S KD 7D 9D TS QD QC
+JH 5H AH KS AS AD JC QC 5S KH
+5D 7D 6D KS KD 3D 7C 4D JD 3S
+AC JS 8D 5H 9C 3H 4H 4D TS 2C
+6H KS KH 9D 7C 2S 6S 8S 2H 3D
+6H AC JS 7S 3S TD 8H 3H 4H TH
+9H TC QC KC 5C KS 6H 4H AC 8S
+TC 7D QH 4S JC TS 6D 6C AC KH
+QH 7D 7C JH QS QD TH 3H 5D KS
+3D 5S 8D JS 4C 2C KS 7H 9C 4H
+5H 8S 4H TD 2C 3S QD QC 3H KC
+QC JS KD 9C AD 5S 9D 7D 7H TS
+8C JC KH 7C 7S 6C TS 2C QD TH
+5S 9D TH 3C 7S QH 8S 9C 2H 5H
+5D 9H 6H 2S JS KH 3H 7C 2H 5S
+JD 5D 5S 2C TC 2S 6S 6C 3C 8S
+4D KH 8H 4H 2D KS 3H 5C 2S 9H
+3S 2D TD 7H 8S 6H JD KC 9C 8D
+6S QD JH 7C 9H 5H 8S 8H TH TD
+QS 7S TD 7D TS JC KD 7C 3C 2C
+3C JD 8S 4H 2D 2S TD AS 4D AC
+AH KS 6C 4C 4S 7D 8C 9H 6H AS
+5S 3C 9S 2C QS KD 4D 4S AC 5D
+2D TS 2C JS KH QH 5D 8C AS KC
+KD 3H 6C TH 8S 7S KH 6H 9S AC
+6H 7S 6C QS AH 2S 2H 4H 5D 5H
+5H JC QD 2C 2S JD AS QC 6S 7D
+6C TC AS KD 8H 9D 2C 7D JH 9S
+2H 4C 6C AH 8S TD 3H TH 7C TS
+KD 4S TS 6C QH 8D 9D 9C AH 7D
+6D JS 5C QD QC 9C 5D 8C 2H KD
+3C QH JH AD 6S AH KC 8S 6D 6H
+3D 7C 4C 7S 5S 3S 6S 5H JC 3C
+QH 7C 5H 3C 3S 8C TS 4C KD 9C
+QD 3S 7S 5H 7H QH JC 7C 8C KD
+3C KD KH 2S 4C TS AC 6S 2C 7C
+2C KH 3C 4C 6H 4D 5H 5S 7S QD
+4D 7C 8S QD TS 9D KS 6H KD 3C
+QS 4D TS 7S 4C 3H QD 8D 9S TC
+TS QH AC 6S 3C 9H 9D QS 8S 6H
+3S 7S 5D 4S JS 2D 6C QH 6S TH
+4C 4H AS JS 5D 3D TS 9C AC 8S
+6S 9C 7C 3S 5C QS AD AS 6H 3C
+9S 8C 7H 3H 6S 7C AS 9H JD KH
+3D 3H 7S 4D 6C 7C AC 2H 9C TH
+4H 5S 3H AC TC TH 9C 9H 9S 8D
+8D 9H 5H 4D 6C 2H QD 6S 5D 3S
+4C 5C JD QS 4D 3H TH AC QH 8C
+QC 5S 3C 7H AD 4C KS 4H JD 6D
+QS AH 3H KS 9H 2S JS JH 5H 2H
+2H 5S TH 6S TS 3S KS 3C 5H JS
+2D 9S 7H 3D KC JH 6D 7D JS TD
+AC JS 8H 2C 8C JH JC 2D TH 7S
+5D 9S 8H 2H 3D TC AH JC KD 9C
+9D QD JC 2H 6D KH TS 9S QH TH
+2C 8D 4S JD 5H 3H TH TC 9C KC
+AS 3D 9H 7D 4D TH KH 2H 7S 3H
+4H 7S KS 2S JS TS 8S 2H QD 8D
+5S 6H JH KS 8H 2S QC AC 6S 3S
+JC AS AD QS 8H 6C KH 4C 4D QD
+2S 3D TS TD 9S KS 6S QS 5C 8D
+3C 6D 4S QC KC JH QD TH KH AD
+9H AH 4D KS 2S 8D JH JC 7C QS
+2D 6C TH 3C 8H QD QH 2S 3S KS
+6H 5D 9S 4C TS TD JS QD 9D JD
+5H 8H KH 8S KS 7C TD AD 4S KD
+2C 7C JC 5S AS 6C 7D 8S 5H 9C
+6S QD 9S TS KH QS 5S QH 3C KC
+7D 3H 3C KD 5C AS JH 7H 6H JD
+9D 5C 9H KC 8H KS 4S AD 4D 2S
+3S JD QD 8D 2S 7C 5S 6S 5H TS
+6D 9S KC TD 3S 6H QD JD 5C 8D
+5H 9D TS KD 8D 6H TD QC 4C 7D
+6D 4S JD 9D AH 9S AS TD 9H QD
+2D 5S 2H 9C 6H 9S TD QC 7D TC
+3S 2H KS TS 2C 9C 8S JS 9D 7D
+3C KC 6D 5D 6C 6H 8S AS 7S QS
+JH 9S 2H 8D 4C 8H 9H AD TH KH
+QC AS 2S JS 5C 6H KD 3H 7H 2C
+QD 8H 2S 8D 3S 6D AH 2C TC 5C
+JD JS TS 8S 3H 5D TD KC JC 6H
+6S QS TC 3H 5D AH JC 7C 7D 4H
+7C 5D 8H 9C 2H 9H JH KH 5S 2C
+9C 7H 6S TH 3S QC QD 4C AC JD
+2H 5D 9S 7D KC 3S QS 2D AS KH
+2S 4S 2H 7D 5C TD TH QH 9S 4D
+6D 3S TS 6H 4H KS 9D 8H 5S 2D
+9H KS 4H 3S 5C 5D KH 6H 6S JS
+KC AS 8C 4C JC KH QC TH QD AH
+6S KH 9S 2C 5H TC 3C 7H JC 4D
+JD 4S 6S 5S 8D 7H 7S 4D 4C 2H
+7H 9H 5D KH 9C 7C TS TC 7S 5H
+4C 8D QC TS 4S 9H 3D AD JS 7C
+8C QS 5C 5D 3H JS AH KC 4S 9D
+TS JD 8S QS TH JH KH 2D QD JS
+JD QC 5D 6S 9H 3S 2C 8H 9S TS
+2S 4C AD 7H JC 5C 2D 6D 4H 3D
+7S JS 2C 4H 8C AD QD 9C 3S TD
+JD TS 4C 6H 9H 7D QD 6D 3C AS
+AS 7C 4C 6S 5D 5S 5C JS QC 4S
+KD 6S 9S 7C 3C 5S 7D JH QD JS
+4S 7S JH 2C 8S 5D 7H 3D QH AD
+TD 6H 2H 8D 4H 2D 7C AD KH 5D
+TS 3S 5H 2C QD AH 2S 5C KH TD
+KC 4D 8C 5D AS 6C 2H 2S 9H 7C
+KD JS QC TS QS KH JH 2C 5D AD
+3S 5H KC 6C 9H 3H 2H AD 7D 7S
+7S JS JH KD 8S 7D 2S 9H 7C 2H
+9H 2D 8D QC 6S AD AS 8H 5H 6C
+2S 7H 6C 6D 7D 8C 5D 9D JC 3C
+7C 9C 7H JD 2H KD 3S KH AD 4S
+QH AS 9H 4D JD KS KD TS KH 5H
+4C 8H 5S 3S 3D 7D TD AD 7S KC
+JS 8S 5S JC 8H TH 9C 4D 5D KC
+7C 5S 9C QD 2C QH JS 5H 8D KH
+TD 2S KS 3D AD KC 7S TC 3C 5D
+4C 2S AD QS 6C 9S QD TH QH 5C
+8C AD QS 2D 2S KC JD KS 6C JC
+8D 4D JS 2H 5D QD 7S 7D QH TS
+6S 7H 3S 8C 8S 9D QS 8H 6C 9S
+4S TC 2S 5C QD 4D QS 6D TH 6S
+3S 5C 9D 6H 8D 4C 7D TC 7C TD
+AH 6S AS 7H 5S KD 3H 5H AC 4C
+8D 8S AH KS QS 2C AD 6H 7D 5D
+6H 9H 9S 2H QS 8S 9C 5D 2D KD
+TS QC 5S JH 7D 7S TH 9S 9H AC
+7H 3H 6S KC 4D 6D 5C 4S QD TS
+TD 2S 7C QD 3H JH 9D 4H 7S 7H
+KS 3D 4H 5H TC 2S AS 2D 6D 7D
+8H 3C 7H TD 3H AD KC TH 9C KH
+TC 4C 2C 9S 9D 9C 5C 2H JD 3C
+3H AC TS 5D AD 8D 6H QC 6S 8C
+2S TS 3S JD 7H 8S QH 4C 5S 8D
+AC 4S 6C 3C KH 3D 7C 2D 8S 2H
+4H 6C 8S TH 2H 4S 8H 9S 3H 7S
+7C 4C 9C 2C 5C AS 5D KD 4D QH
+9H 4H TS AS 7D 8D 5D 9S 8C 2H
+QC KD AC AD 2H 7S AS 3S 2D 9S
+2H QC 8H TC 6D QD QS 5D KH 3C
+TH JD QS 4C 2S 5S AD 7H 3S AS
+7H JS 3D 6C 3S 6D AS 9S AC QS
+9C TS AS 8C TC 8S 6H 9D 8D 6C
+4D JD 9C KC 7C 6D KS 3S 8C AS
+3H 6S TC 8D TS 3S KC 9S 7C AS
+8C QC 4H 4S 8S 6C 3S TC AH AC
+4D 7D 5C AS 2H 6S TS QC AD TC
+QD QC 8S 4S TH 3D AH TS JH 4H
+5C 2D 9S 2C 3H 3C 9D QD QH 7D
+KC 9H 6C KD 7S 3C 4D AS TC 2D
+3D JS 4D 9D KS 7D TH QC 3H 3C
+8D 5S 2H 9D 3H 8C 4C 4H 3C TH
+JC TH 4S 6S JD 2D 4D 6C 3D 4C
+TS 3S 2D 4H AC 2C 6S 2H JH 6H
+TD 8S AD TC AH AC JH 9S 6S 7S
+6C KC 4S JD 8D 9H 5S 7H QH AH
+KD 8D TS JH 5C 5H 3H AD AS JS
+2D 4H 3D 6C 8C 7S AD 5D 5C 8S
+TD 5D 7S 9C 4S 5H 6C 8C 4C 8S
+JS QH 9C AS 5C QS JC 3D QC 7C
+JC 9C KH JH QS QC 2C TS 3D AD
+5D JH AC 5C 9S TS 4C JD 8C KS
+KC AS 2D KH 9H 2C 5S 4D 3D 6H
+TH AH 2D 8S JC 3D 8C QH 7S 3S
+8H QD 4H JC AS KH KS 3C 9S 6D
+9S QH 7D 9C 4S AC 7H KH 4D KD
+AH AD TH 6D 9C 9S KD KS QH 4H
+QD 6H 9C 7C QS 6D 6S 9D 5S JH
+AH 8D 5H QD 2H JC KS 4H KH 5S
+5C 2S JS 8D 9C 8C 3D AS KC AH
+JD 9S 2H QS 8H 5S 8C TH 5C 4C
+QC QS 8C 2S 2C 3S 9C 4C KS KH
+2D 5D 8S AH AD TD 2C JS KS 8C
+TC 5S 5H 8H QC 9H 6H JD 4H 9S
+3C JH 4H 9H AH 4S 2H 4C 8D AC
+8S TH 4D 7D 6D QD QS 7S TC 7C
+KH 6D 2D JD 5H JS QD JH 4H 4S
+9C 7S JH 4S 3S TS QC 8C TC 4H
+QH 9D 4D JH QS 3S 2C 7C 6C 2D
+4H 9S JD 5C 5H AH 9D TS 2D 4C
+KS JH TS 5D 2D AH JS 7H AS 8D
+JS AH 8C AD KS 5S 8H 2C 6C TH
+2H 5D AD AC KS 3D 8H TS 6H QC
+6D 4H TS 9C 5H JS JH 6S JD 4C
+JH QH 4H 2C 6D 3C 5D 4C QS KC
+6H 4H 6C 7H 6S 2S 8S KH QC 8C
+3H 3D 5D KS 4H TD AD 3S 4D TS
+5S 7C 8S 7D 2C KS 7S 6C 8C JS
+5D 2H 3S 7C 5C QD 5H 6D 9C 9H
+JS 2S KD 9S 8D TD TS AC 8C 9D
+5H QD 2S AC 8C 9H KS 7C 4S 3C
+KH AS 3H 8S 9C JS QS 4S AD 4D
+AS 2S TD AD 4D 9H JC 4C 5H QS
+5D 7C 4H TC 2D 6C JS 4S KC 3S
+4C 2C 5D AC 9H 3D JD 8S QS QH
+2C 8S 6H 3C QH 6D TC KD AC AH
+QC 6C 3S QS 4S AC 8D 5C AD KH
+5S 4C AC KH AS QC 2C 5C 8D 9C
+8H JD 3C KH 8D 5C 9C QD QH 9D
+7H TS 2C 8C 4S TD JC 9C 5H QH
+JS 4S 2C 7C TH 6C AS KS 7S JD
+JH 7C 9H 7H TC 5H 3D 6D 5D 4D
+2C QD JH 2H 9D 5S 3D TD AD KS
+JD QH 3S 4D TH 7D 6S QS KS 4H
+TC KS 5S 8D 8H AD 2S 2D 4C JH
+5S JH TC 3S 2D QS 9D 4C KD 9S
+AC KH 3H AS 9D KC 9H QD 6C 6S
+9H 7S 3D 5C 7D KC TD 8H 4H 6S
+3C 7H 8H TC QD 4D 7S 6S QH 6C
+6D AD 4C QD 6C 5D 7D 9D KS TS
+JH 2H JD 9S 7S TS KH 8D 5D 8H
+2D 9S 4C 7D 9D 5H QD 6D AC 6S
+7S 6D JC QD JH 4C 6S QS 2H 7D
+8C TD JH KD 2H 5C QS 2C JS 7S
+TC 5H 4H JH QD 3S 5S 5D 8S KH
+KS KH 7C 2C 5D JH 6S 9C 6D JC
+5H AH JD 9C JS KC 2H 6H 4D 5S
+AS 3C TH QC 6H 9C 8S 8C TD 7C
+KC 2C QD 9C KH 4D 7S 3C TS 9H
+9C QC 2S TS 8C TD 9S QD 3S 3C
+4D 9D TH JH AH 6S 2S JD QH JS
+QD 9H 6C KD 7D 7H 5D 6S 8H AH
+8H 3C 4S 2H 5H QS QH 7S 4H AC
+QS 3C 7S 9S 4H 3S AH KS 9D 7C
+AD 5S 6S 2H 2D 5H TC 4S 3C 8C
+QH TS 6S 4D JS KS JH AS 8S 6D
+2C 8S 2S TD 5H AS TC TS 6C KC
+KC TS 8H 2H 3H 7C 4C 5S TH TD
+KD AD KH 7H 7S 5D 5H 5S 2D 9C
+AD 9S 3D 7S 8C QC 7C 9C KD KS
+3C QC 9S 8C 4D 5C AS QD 6C 2C
+2H KC 8S JD 7S AC 8D 5C 2S 4D
+9D QH 3D 2S TC 3S KS 3C 9H TD
+KD 6S AC 2C 7H 5H 3S 6C 6H 8C
+QH TC 8S 6S KH TH 4H 5D TS 4D
+8C JS 4H 6H 2C 2H 7D AC QD 3D
+QS KC 6S 2D 5S 4H TD 3H JH 4C
+7S 5H 7H 8H KH 6H QS TH KD 7D
+5H AD KD 7C KH 5S TD 6D 3C 6C
+8C 9C 5H JD 7C KC KH 7H 2H 3S
+7S 4H AD 4D 8S QS TH 3D 7H 5S
+8D TC KS KD 9S 6D AD JD 5C 2S
+7H 8H 6C QD 2H 6H 9D TC 9S 7C
+8D 6D 4C 7C 6C 3C TH KH JS JH
+5S 3S 8S JS 9H AS AD 8H 7S KD
+JH 7C 2C KC 5H AS AD 9C 9S JS
+AD AC 2C 6S QD 7C 3H TH KS KD
+9D JD 4H 8H 4C KH 7S TS 8C KC
+3S 5S 2H 7S 6H 7D KS 5C 6D AD
+5S 8C 9H QS 7H 7S 2H 6C 7D TD
+QS 5S TD AC 9D KC 3D TC 2D 4D
+TD 2H 7D JD QD 4C 7H 5D KC 3D
+4C 3H 8S KD QH 5S QC 9H TC 5H
+9C QD TH 5H TS 5C 9H AH QH 2C
+4D 6S 3C AC 6C 3D 2C 2H TD TH
+AC 9C 5D QC 4D AD 8D 6D 8C KC
+AD 3C 4H AC 8D 8H 7S 9S TD JC
+4H 9H QH JS 2D TH TD TC KD KS
+5S 6S 9S 8D TH AS KH 5H 5C 8S
+JD 2S 9S 6S 5S 8S 5D 7S 7H 9D
+5D 8C 4C 9D AD TS 2C 7D KD TC
+8S QS 4D KC 5C 8D 4S KH JD KD
+AS 5C AD QH 7D 2H 9S 7H 7C TC
+2S 8S JD KH 7S 6C 6D AD 5D QC
+9H 6H 3S 8C 8H AH TC 4H JS TD
+2C TS 4D 7H 2D QC 9C 5D TH 7C
+6C 8H QC 5D TS JH 5C 5H 9H 4S
+2D QC 7H AS JS 8S 2H 4C 4H 8D
+JS 6S AC KD 3D 3C 4S 7H TH KC
+QH KH 6S QS 5S 4H 3C QD 3S 3H
+7H AS KH 8C 4H 9C 5S 3D 6S TS
+9C 7C 3H 5S QD 2C 3D AD AC 5H
+JH TD 2D 4C TS 3H KH AD 3S 7S
+AS 4C 5H 4D 6S KD JC 3C 6H 2D
+3H 6S 8C 2D TH 4S AH QH AD 5H
+7C 2S 9H 7H KC 5C 6D 5S 3H JC
+3C TC 9C 4H QD TD JH 6D 9H 5S
+7C 6S 5C 5D 6C 4S 7H 9H 6H AH
+AD 2H 7D KC 2C 4C 2S 9S 7H 3S
+TH 4C 8S 6S 3S AD KS AS JH TD
+5C TD 4S 4D AD 6S 5D TC 9C 7D
+8H 3S 4D 4S 5S 6H 5C AC 3H 3D
+9H 3C AC 4S QS 8S 9D QH 5H 4D
+JC 6C 5H TS AC 9C JD 8C 7C QD
+8S 8H 9C JD 2D QC QH 6H 3C 8D
+KS JS 2H 6H 5H QH QS 3H 7C 6D
+TC 3H 4S 7H QC 2H 3S 8C JS KH
+AH 8H 5S 4C 9H JD 3H 7S JC AC
+3C 2D 4C 5S 6C 4S QS 3S JD 3D
+5H 2D TC AH KS 6D 7H AD 8C 6H
+6C 7S 3C JD 7C 8H KS KH AH 6D
+AH 7D 3H 8H 8S 7H QS 5H 9D 2D
+JD AC 4H 7S 8S 9S KS AS 9D QH
+7S 2C 8S 5S JH QS JC AH KD 4C
+AH 2S 9H 4H 8D TS TD 6H QH JD
+4H JC 3H QS 6D 7S 9C 8S 9D 8D
+5H TD 4S 9S 4C 8C 8D 7H 3H 3D
+QS KH 3S 2C 2S 3C 7S TD 4S QD
+7C TD 4D 5S KH AC AS 7H 4C 6C
+2S 5H 6D JD 9H QS 8S 2C 2H TD
+2S TS 6H 9H 7S 4H JC 4C 5D 5S
+2C 5H 7D 4H 3S QH JC JS 6D 8H
+4C QH 7C QD 3S AD TH 8S 5S TS
+9H TC 2S TD JC 7D 3S 3D TH QH
+7D 4C 8S 5C JH 8H 6S 3S KC 3H
+JC 3H KH TC QH TH 6H 2C AC 5H
+QS 2H 9D 2C AS 6S 6C 2S 8C 8S
+9H 7D QC TH 4H KD QS AC 7S 3C
+4D JH 6S 5S 8H KS 9S QC 3S AS
+JD 2D 6S 7S TC 9H KC 3H 7D KD
+2H KH 7C 4D 4S 3H JS QD 7D KC
+4C JC AS 9D 3C JS 6C 8H QD 4D
+AH JS 3S 6C 4C 3D JH 6D 9C 9H
+9H 2D 8C 7H 5S KS 6H 9C 2S TC
+6C 8C AD 7H 6H 3D KH AS 5D TH
+KS 8C 3S TS 8S 4D 5S 9S 6C 4H
+9H 4S 4H 5C 7D KC 2D 2H 9D JH
+5C JS TC 9D 9H 5H 7S KH JC 6S
+7C 9H 8H 4D JC KH JD 2H TD TC
+8H 6C 2H 2C KH 6H 9D QS QH 5H
+AC 7D 2S 3D QD JC 2D 8D JD JH
+2H JC 2D 7H 2C 3C 8D KD TD 4H
+3S 4H 6D 8D TS 3H TD 3D 6H TH
+JH JC 3S AC QH 9H 7H 8S QC 2C
+7H TD QS 4S 8S 9C 2S 5D 4D 2H
+3D TS 3H 2S QC 8H 6H KC JC KS
+5D JD 7D TC 8C 6C 9S 3D 8D AC
+8H 6H JH 6C 5D 8D 8S 4H AD 2C
+9D 4H 2D 2C 3S TS AS TC 3C 5D
+4D TH 5H KS QS 6C 4S 2H 3D AD
+5C KC 6H 2C 5S 3C 4D 2D 9H 9S
+JD 4C 3H TH QH 9H 5S AH 8S AC
+7D 9S 6S 2H TD 9C 4H 8H QS 4C
+3C 6H 5D 4H 8C 9C KC 6S QD QS
+3S 9H KD TC 2D JS 8C 6S 4H 4S
+2S 4C 8S QS 6H KH 3H TH 8C 5D
+2C KH 5S 3S 7S 7H 6C 9D QD 8D
+8H KS AC 2D KH TS 6C JS KC 7H
+9C KS 5C TD QC AH 6C 5H 9S 7C
+5D 4D 3H 4H 6S 7C 7S AH QD TD
+2H 7D QC 6S TC TS AH 7S 9D 3H
+TH 5H QD 9S KS 7S 7C 6H 8C TD
+TH 2D 4D QC 5C 7D JD AH 9C 4H
+4H 3H AH 8D 6H QC QH 9H 2H 2C
+2D AD 4C TS 6H 7S TH 4H QS TD
+3C KD 2H 3H QS JD TC QC 5D 8H
+KS JC QD TH 9S KD 8D 8C 2D 9C
+3C QD KD 6D 4D 8D AH AD QC 8S
+8H 3S 9D 2S 3H KS 6H 4C 7C KC
+TH 9S 5C 3D 7D 6H AC 7S 4D 2C
+5C 3D JD 4D 2D 6D 5H 9H 4C KH
+AS 7H TD 6C 2H 3D QD KS 4C 4S
+JC 3C AC 7C JD JS 8H 9S QC 5D
+JD 6S 5S 2H AS 8C 7D 5H JH 3D
+8D TC 5S 9S 8S 3H JC 5H 7S AS
+5C TD 3D 7D 4H 8D 7H 4D 5D JS
+QS 9C KS TD 2S 8S 5C 2H 4H AS
+TH 7S 4H 7D 3H JD KD 5D 2S KC
+JD 7H 4S 8H 4C JS 6H QH 5S 4H
+2C QS 8C 5S 3H QC 2S 6C QD AD
+8C 3D JD TC 4H 2H AD 5S AC 2S
+5D 2C JS 2D AD 9D 3D 4C 4S JH
+8D 5H 5D 6H 7S 4D KS 9D TD JD
+3D 6D 9C 2S AS 7D 5S 5C 8H JD
+7C 8S 3S 6S 5H JD TC AD 7H 7S
+2S 9D TS 4D AC 8D 6C QD JD 3H
+9S KH 2C 3C AC 3D 5H 6H 8D 5D
+KS 3D 2D 6S AS 4C 2S 7C 7H KH
+AC 2H 3S JC 5C QH 4D 2D 5H 7S
+TS AS JD 8C 6H JC 8S 5S 2C 5D
+7S QH 7H 6C QC 8H 2D 7C JD 2S
+2C QD 2S 2H JC 9C 5D 2D JD JH
+7C 5C 9C 8S 7D 6D 8D 6C 9S JH
+2C AD 6S 5H 3S KS 7S 9D KH 4C
+7H 6C 2C 5C TH 9D 8D 3S QC AH
+5S KC 6H TC 5H 8S TH 6D 3C AH
+9C KD 4H AD TD 9S 4S 7D 6H 5D
+7H 5C 5H 6D AS 4C KD KH 4H 9D
+3C 2S 5C 6C JD QS 2H 9D 7D 3H
+AC 2S 6S 7S JS QD 5C QS 6H AD
+5H TH QC 7H TC 3S 7C 6D KC 3D
+4H 3D QC 9S 8H 2C 3S JC KS 5C
+4S 6S 2C 6H 8S 3S 3D 9H 3H JS
+4S 8C 4D 2D 8H 9H 7D 9D AH TS
+9S 2C 9H 4C 8D AS 7D 3D 6D 5S
+6S 4C 7H 8C 3H 5H JC AH 9D 9C
+2S 7C 5S JD 8C 3S 3D 4D 7D 6S
+3C KC 4S 5D 7D 3D JD 7H 3H 4H
+9C 9H 4H 4D TH 6D QD 8S 9S 7S
+2H AC 8S 4S AD 8C 2C AH 7D TC
+TS 9H 3C AD KS TC 3D 8C 8H JD
+QC 8D 2C 3C 7D 7C JD 9H 9C 6C
+AH 6S JS JH 5D AS QC 2C JD TD
+9H KD 2H 5D 2D 3S 7D TC AH TS
+TD 8H AS 5D AH QC AC 6S TC 5H
+KS 4S 7H 4D 8D 9C TC 2H 6H 3H
+3H KD 4S QD QH 3D 8H 8C TD 7S
+8S JD TC AH JS QS 2D KH KS 4D
+3C AD JC KD JS KH 4S TH 9H 2C
+QC 5S JS 9S KS AS 7C QD 2S JD
+KC 5S QS 3S 2D AC 5D 9H 8H KS
+6H 9C TC AD 2C 6D 5S JD 6C 7C
+QS KH TD QD 2C 3H 8S 2S QC AH
+9D 9H JH TC QH 3C 2S JS 5C 7H
+6C 3S 3D 2S 4S QD 2D TH 5D 2C
+2D 6H 6D 2S JC QH AS 7H 4H KH
+5H 6S KS AD TC TS 7C AC 4S 4H
+AD 3C 4H QS 8C 9D KS 2H 2D 4D
+4S 9D 6C 6D 9C AC 8D 3H 7H KD
+JC AH 6C TS JD 6D AD 3S 5D QD
+JC JH JD 3S 7S 8S JS QC 3H 4S
+JD TH 5C 2C AD JS 7H 9S 2H 7S
+8D 3S JH 4D QC AS JD 2C KC 6H
+2C AC 5H KD 5S 7H QD JH AH 2D
+JC QH 8D 8S TC 5H 5C AH 8C 6C
+3H JS 8S QD JH 3C 4H 6D 5C 3S
+6D 4S 4C AH 5H 5S 3H JD 7C 8D
+8H AH 2H 3H JS 3C 7D QC 4H KD
+6S 2H KD 5H 8H 2D 3C 8S 7S QD
+2S 7S KC QC AH TC QS 6D 4C 8D
+5S 9H 2C 3S QD 7S 6C 2H 7C 9D
+3C 6C 5C 5S JD JC KS 3S 5D TS
+7C KS 6S 5S 2S 2D TC 2H 5H QS
+AS 7H 6S TS 5H 9S 9D 3C KD 2H
+4S JS QS 3S 4H 7C 2S AC 6S 9D
+8C JH 2H 5H 7C 5D QH QS KH QC
+3S TD 3H 7C KC 8D 5H 8S KH 8C
+4H KH JD TS 3C 7H AS QC JS 5S
+AH 9D 2C 8D 4D 2D 6H 6C KC 6S
+2S 6H 9D 3S 7H 4D KH 8H KD 3D
+9C TC AC JH KH 4D JD 5H TD 3S
+7S 4H 9D AS 4C 7D QS 9S 2S KH
+3S 8D 8S KS 8C JC 5C KH 2H 5D
+8S QH 2C 4D KC JS QC 9D AC 6H
+8S 8C 7C JS JD 6S 4C 9C AC 4S
+QH 5D 2C 7D JC 8S 2D JS JH 4C
+JS 4C 7S TS JH KC KH 5H QD 4S
+QD 8C 8D 2D 6S TD 9D AC QH 5S
+QH QC JS 3D 3C 5C 4H KH 8S 7H
+7C 2C 5S JC 8S 3H QC 5D 2H KC
+5S 8D KD 6H 4H QD QH 6D AH 3D
+7S KS 6C 2S 4D AC QS 5H TS JD
+7C 2D TC 5D QS AC JS QC 6C KC
+2C KS 4D 3H TS 8S AD 4H 7S 9S
+QD 9H QH 5H 4H 4D KH 3S JC AD
+4D AC KC 8D 6D 4C 2D KH 2C JD
+2C 9H 2D AH 3H 6D 9C 7D TC KS
+8C 3H KD 7C 5C 2S 4S 5H AS AH
+TH JD 4H KD 3H TC 5C 3S AC KH
+6D 7H AH 7S QC 6H 2D TD JD AS
+JH 5D 7H TC 9S 7D JC AS 5S KH
+2H 8C AD TH 6H QD KD 9H 6S 6C
+QH KC 9D 4D 3S JS JH 4H 2C 9H
+TC 7H KH 4H JC 7D 9S 3H QS 7S
+AD 7D JH 6C 7H 4H 3S 3H 4D QH
+JD 2H 5C AS 6C QC 4D 3C TC JH
+AC JD 3H 6H 4C JC AD 7D 7H 9H
+4H TC TS 2C 8C 6S KS 2H JD 9S
+4C 3H QS QC 9S 9H 6D KC 9D 9C
+5C AD 8C 2C QH TH QD JC 8D 8H
+QC 2C 2S QD 9C 4D 3S 8D JH QS
+9D 3S 2C 7S 7C JC TD 3C TC 9H
+3C TS 8H 5C 4C 2C 6S 8D 7C 4H
+KS 7H 2H TC 4H 2C 3S AS AH QS
+8C 2D 2H 2C 4S 4C 6S 7D 5S 3S
+TH QC 5D TD 3C QS KD KC KS AS
+4D AH KD 9H KS 5C 4C 6H JC 7S
+KC 4H 5C QS TC 2H JC 9S AH QH
+4S 9H 3H 5H 3C QD 2H QC JH 8H
+5D AS 7H 2C 3D JH 6H 4C 6S 7D
+9C JD 9H AH JS 8S QH 3H KS 8H
+3S AC QC TS 4D AD 3D AH 8S 9H
+7H 3H QS 9C 9S 5H JH JS AH AC
+8D 3C JD 2H AC 9C 7H 5S 4D 8H
+7C JH 9H 6C JS 9S 7H 8C 9D 4H
+2D AS 9S 6H 4D JS JH 9H AD QD
+6H 7S JH KH AH 7H TD 5S 6S 2C
+8H JH 6S 5H 5S 9D TC 4C QC 9S
+7D 2C KD 3H 5H AS QD 7H JS 4D
+TS QH 6C 8H TH 5H 3C 3H 9C 9D
+AD KH JS 5D 3H AS AC 9S 5C KC
+2C KH 8C JC QS 6D AH 2D KC TC
+9D 3H 2S 7C 4D 6D KH KS 8D 7D
+9H 2S TC JH AC QC 3H 5S 3S 8H
+3S AS KD 8H 4C 3H 7C JH QH TS
+7S 6D 7H 9D JH 4C 3D 3S 6C AS
+4S 2H 2C 4C 8S 5H KC 8C QC QD
+3H 3S 6C QS QC 2D 6S 5D 2C 9D
+2H 8D JH 2S 3H 2D 6C 5C 7S AD
+9H JS 5D QH 8S TS 2H 7S 6S AD
+6D QC 9S 7H 5H 5C 7D KC JD 4H
+QC 5S 9H 9C 4D 6S KS 2S 4C 7C
+9H 7C 4H 8D 3S 6H 5C 8H JS 7S
+2D 6H JS TD 4H 4D JC TH 5H KC
+AC 7C 8D TH 3H 9S 2D 4C KC 4D
+KD QS 9C 7S 3D KS AD TS 4C 4H
+QH 9C 8H 2S 7D KS 7H 5D KD 4C
+9C 2S 2H JC 6S 6C TC QC JH 5C
+7S AC 8H KC 8S 6H QS JC 3D 6S
+JS 2D JH 8C 4S 6H 8H 6D 5D AD
+6H 7D 2S 4H 9H 7C AS AC 8H 5S
+3C JS 4S 6D 5H 2S QH 6S 9C 2C
+3D 5S 6S 9S 4C QS 8D QD 8S TC
+9C 3D AH 9H 5S 2C 7D AD JC 3S
+7H TC AS 3C 6S 6D 7S KH KC 9H
+3S TC 8H 6S 5H JH 8C 7D AC 2S
+QD 9D 9C 3S JC 8C KS 8H 5D 4D
+JS AH JD 6D 9D 8C 9H 9S 8H 3H
+2D 6S 4C 4D 8S AD 4S TC AH 9H
+TS AC QC TH KC 6D 4H 7S 8C 2H
+3C QD JS 9D 5S JC AH 2H TS 9H
+3H 4D QH 5D 9C 5H 7D 4S JC 3S
+8S TH 3H 7C 2H JD JS TS AC 8D
+9C 2H TD KC JD 2S 8C 5S AD 2C
+3D KD 7C 5H 4D QH QD TC 6H 7D
+7H 2C KC 5S KD 6H AH QC 7S QH
+6H 5C AC 5H 2C 9C 2D 7C TD 2S
+4D 9D AH 3D 7C JD 4H 8C 4C KS
+TH 3C JS QH 8H 4C AS 3D QS QC
+4D 7S 5H JH 6D 7D 6H JS KH 3C
+QD 8S 7D 2H 2C 7C JC 2S 5H 8C
+QH 8S 9D TC 2H AD 7C 8D QD 6S
+3S 7C AD 9H 2H 9S JD TS 4C 2D
+3S AS 4H QC 2C 8H 8S 7S TD TC
+JH TH TD 3S 4D 4H 5S 5D QS 2C
+8C QD QH TC 6D 4S 9S 9D 4H QC
+8C JS 9D 6H JD 3H AD 6S TD QC
+KC 8S 3D 7C TD 7D 8D 9H 4S 3S
+6C 4S 3D 9D KD TC KC KS AC 5S
+7C 6S QH 3D JS KD 6H 6D 2D 8C
+JD 2S 5S 4H 8S AC 2D 6S TS 5C
+5H 8C 5S 3C 4S 3D 7C 8D AS 3H
+AS TS 7C 3H AD 7D JC QS 6C 6H
+3S 9S 4C AC QH 5H 5D 9H TS 4H
+6C 5C 7H 7S TD AD JD 5S 2H 2S
+7D 6C KC 3S JD 8D 8S TS QS KH
+8S QS 8D 6C TH AC AH 2C 8H 9S
+7H TD KH QH 8S 3D 4D AH JD AS
+TS 3D 2H JC 2S JH KH 6C QC JS
+KC TH 2D 6H 7S 2S TC 8C 9D QS
+3C 9D 6S KH 8H 6D 5D TH 2C 2H
+6H TC 7D AD 4D 8S TS 9H TD 7S
+JS 6D JD JC 2H AC 6C 3D KH 8D
+KH JD 9S 5D 4H 4C 3H 7S QS 5C
+4H JD 5D 3S 3C 4D KH QH QS 7S
+JD TS 8S QD AH 4C 6H 3S 5S 2C
+QS 3D JD AS 8D TH 7C 6S QC KS
+7S 2H 8C QC 7H AC 6D 2D TH KH
+5S 6C 7H KH 7D AH 8C 5C 7S 3D
+3C KD AD 7D 6C 4D KS 2D 8C 4S
+7C 8D 5S 2D 2S AH AD 2C 9D TD
+3C AD 4S KS JH 7C 5C 8C 9C TH
+AS TD 4D 7C JD 8C QH 3C 5H 9S
+3H 9C 8S 9S 6S QD KS AH 5H JH
+QC 9C 5S 4H 2H TD 7D AS 8C 9D
+8C 2C 9D KD TC 7S 3D KH QC 3C
+4D AS 4C QS 5S 9D 6S JD QH KS
+6D AH 6C 4C 5H TS 9H 7D 3D 5S
+QS JD 7C 8D 9C AC 3S 6S 6C KH
+8H JH 5D 9S 6D AS 6S 3S QC 7H
+QD AD 5C JH 2H AH 4H AS KC 2C
+JH 9C 2C 6H 2D JS 5D 9H KC 6D
+7D 9D KD TH 3H AS 6S QC 6H AD
+JD 4H 7D KC 3H JS 3C TH 3D QS
+4C 3H 8C QD 5H 6H AS 8H AD JD
+TH 8S KD 5D QC 7D JS 5S 5H TS
+7D KC 9D QS 3H 3C 6D TS 7S AH
+7C 4H 7H AH QC AC 4D 5D 6D TH
+3C 4H 2S KD 8H 5H JH TC 6C JD
+4S 8C 3D 4H JS TD 7S JH QS KD
+7C QC KD 4D 7H 6S AD TD TC KH
+5H 9H KC 3H 4D 3D AD 6S QD 6H
+TH 7C 6H TS QH 5S 2C KC TD 6S
+7C 4D 5S JD JH 7D AC KD KH 4H
+7D 6C 8D 8H 5C JH 8S QD TH JD
+8D 7D 6C 7C 9D KD AS 5C QH JH
+9S 2C 8C 3C 4C KS JH 2D 8D 4H
+7S 6C JH KH 8H 3H 9D 2D AH 6D
+4D TC 9C 8D 7H TD KS TH KD 3C
+JD 9H 8D QD AS KD 9D 2C 2S 9C
+8D 3H 5C 7H KS 5H QH 2D 8C 9H
+2D TH 6D QD 6C KC 3H 3S AD 4C
+4H 3H JS 9D 3C TC 5H QH QC JC
+3D 5C 6H 3S 3C JC 5S 7S 2S QH
+AC 5C 8C 4D 5D 4H 2S QD 3C 3H
+2C TD AH 9C KD JS 6S QD 4C QC
+QS 8C 3S 4H TC JS 3H 7C JC AD
+5H 4D 9C KS JC TD 9S TS 8S 9H
+QD TS 7D AS AC 2C TD 6H 8H AH
+6S AD 8C 4S 9H 8D 9D KH 8S 3C
+QS 4D 2D 7S KH JS JC AD 4C 3C
+QS 9S 7H KC TD TH 5H JS AC JH
+6D AC 2S QS 7C AS KS 6S KH 5S
+6D 8H KH 3C QS 2H 5C 9C 9D 6C
+JS 2C 4C 6H 7D JC AC QD TD 3H
+4H QC 8H JD 4C KD KS 5C KC 7S
+6D 2D 3H 2S QD 5S 7H AS TH 6S
+AS 6D 8D 2C 8S TD 8H QD JC AH
+9C 9H 2D TD QH 2H 5C TC 3D 8H
+KC 8S 3D KH 2S TS TC 6S 4D JH
+9H 9D QS AC KC 6H 5D 4D 8D AH
+9S 5C QS 4H 7C 7D 2H 8S AD JS
+3D AC 9S AS 2C 2D 2H 3H JC KH
+7H QH KH JD TC KS 5S 8H 4C 8D
+2H 7H 3S 2S 5H QS 3C AS 9H KD
+AD 3D JD 6H 5S 9C 6D AC 9S 3S
+3D 5D 9C 2D AC 4S 2S AD 6C 6S
+QC 4C 2D 3H 6S KC QH QD 2H JH
+QC 3C 8S 4D 9S 2H 5C 8H QS QD
+6D KD 6S 7H 3S KH 2H 5C JC 6C
+3S 9S TC 6S 8H 2D AD 7S 8S TS
+3C 6H 9C 3H 5C JC 8H QH TD QD
+3C JS QD 5D TD 2C KH 9H TH AS
+9S TC JD 3D 5C 5H AD QH 9H KC
+TC 7H 4H 8H 3H TD 6S AC 7C 2S
+QS 9D 5D 3C JC KS 4D 6C JH 2S
+9S 6S 3C 7H TS 4C KD 6D 3D 9C
+2D 9H AH AC 7H 2S JH 3S 7C QC
+QD 9H 3C 2H AC AS 8S KD 8C KH
+2D 7S TD TH 6D JD 8D 4D 2H 5S
+8S QH KD JD QS JH 4D KC 5H 3S
+3C KH QC 6D 8H 3S AH 7D TD 2D
+5S 9H QH 4S 6S 6C 6D TS TH 7S
+6C 4C 6D QS JS 9C TS 3H 8D 8S
+JS 5C 7S AS 2C AH 2H AD 5S TC
+KD 6C 9C 9D TS 2S JC 4H 2C QD
+QS 9H TC 3H KC KS 4H 3C AD TH
+KH 9C 2H KD 9D TC 7S KC JH 2D
+7C 3S KC AS 8C 5D 9C 9S QH 3H
+2D 8C TD 4C 2H QC 5D TC 2C 7D
+KS 4D 6C QH TD KH 5D 7C AD 8D
+2S 9S 8S 4C 8C 3D 6H QD 7C 7H
+6C 8S QH 5H TS 5C 3C 4S 2S 2H
+8S 6S 2H JC 3S 3H 9D 8C 2S 7H
+QC 2C 8H 9C AC JD 4C 4H 6S 3S
+3H 3S 7D 4C 9S 5H 8H JC 3D TC
+QH 2S 2D 9S KD QD 9H AD 6D 9C
+8D 2D KS 9S JC 4C JD KC 4S TH
+KH TS 6D 4D 5C KD 5H AS 9H AD
+QD JS 7C 6D 5D 5C TH 5H QH QS
+9D QH KH 5H JH 4C 4D TC TH 6C
+KH AS TS 9D KD 9C 7S 4D 8H 5S
+KH AS 2S 7D 9D 4C TS TH AH 7C
+KS 4D AC 8S 9S 8D TH QH 9D 5C
+5D 5C 8C QS TC 4C 3D 3S 2C 8D
+9D KS 2D 3C KC 4S 8C KH 6C JC
+8H AH 6H 7D 7S QD 3C 4C 6C KC
+3H 2C QH 8H AS 7D 4C 8C 4H KC
+QD 5S 4H 2C TD AH JH QH 4C 8S
+3H QS 5S JS 8H 2S 9H 9C 3S 2C
+6H TS 7S JC QD AC TD KC 5S 3H
+QH AS QS 7D JC KC 2C 4C 5C 5S
+QH 3D AS JS 4H 8D 7H JC 2S 9C
+5D 4D 2S 4S 9D 9C 2D QS 8H 7H
+6D 7H 3H JS TS AC 2D JH 7C 8S
+JH 5H KC 3C TC 5S 9H 4C 8H 9D
+8S KC 5H 9H AD KS 9D KH 8D AH
+JC 2H 9H KS 6S 3H QC 5H AH 9C
+5C KH 5S AD 6C JC 9H QC 9C TD
+5S 5D JC QH 2D KS 8H QS 2H TS
+JH 5H 5S AH 7H 3C 8S AS TD KH
+6H 3D JD 2C 4C KC 7S AH 6C JH
+4C KS 9D AD 7S KC 7D 8H 3S 9C
+7H 5C 5H 3C 8H QC 3D KH 6D JC
+2D 4H 5D 7D QC AD AH 9H QH 8H
+KD 8C JS 9D 3S 3C 2H 5D 6D 2S
+8S 6S TS 3C 6H 8D 5S 3H TD 6C
+KS 3D JH 9C 7C 9S QS 5S 4H 6H
+7S 6S TH 4S KC KD 3S JC JH KS
+7C 3C 2S 6D QH 2C 7S 5H 8H AH
+KC 8D QD 6D KH 5C 7H 9D 3D 9C
+6H 2D 8S JS 9S 2S 6D KC 7C TC
+KD 9C JH 7H KC 8S 2S 7S 3D 6H
+4H 9H 2D 4C 8H 7H 5S 8S 2H 8D
+AD 7C 3C 7S 5S 4D 9H 3D JC KH
+5D AS 7D 6D 9C JC 4C QH QS KH
+KD JD 7D 3D QS QC 8S 6D JS QD
+6S 8C 5S QH TH 9H AS AC 2C JD
+QC KS QH 7S 3C 4C 5C KC 5D AH
+6C 4H 9D AH 2C 3H KD 3D TS 5C
+TD 8S QS AS JS 3H KD AC 4H KS
+7D 5D TS 9H 4H 4C 9C 2H 8C QC
+2C 7D 9H 4D KS 4C QH AD KD JS
+QD AD AH KH 9D JS 9H JC KD JD
+8S 3C 4S TS 7S 4D 5C 2S 6H 7C
+JS 7S 5C KD 6D QH 8S TD 2H 6S
+QH 6C TC 6H TD 4C 9D 2H QC 8H
+3D TS 4D 2H 6H 6S 2C 7H 8S 6C
+9H 9D JD JH 3S AH 2C 6S 3H 8S
+2C QS 8C 5S 3H 2S 7D 3C AD 4S
+5C QC QH AS TS 4S 6S 4C 5H JS
+JH 5C TD 4C 6H JS KD KH QS 4H
+TC KH JC 4D 9H 9D 8D KC 3C 8H
+2H TC 8S AD 9S 4H TS 7H 2C 5C
+4H 2S 6C 5S KS AH 9C 7C 8H KD
+TS QH TD QS 3C JH AH 2C 8D 7D
+5D KC 3H 5S AC 4S 7H QS 4C 2H
+3D 7D QC KH JH 6D 6C TD TH KD
+5S 8D TH 6C 9D 7D KH 8C 9S 6D
+JD QS 7S QC 2S QH JC 4S KS 8D
+7S 5S 9S JD KD 9C JC AD 2D 7C
+4S 5H AH JH 9C 5D TD 7C 2D 6S
+KC 6C 7H 6S 9C QD 5S 4H KS TD
+6S 8D KS 2D TH TD 9H JD TS 3S
+KH JS 4H 5D 9D TC TD QC JD TS
+QS QD AC AD 4C 6S 2D AS 3H KC
+4C 7C 3C TD QS 9C KC AS 8D AD
+KC 7H QC 6D 8H 6S 5S AH 7S 8C
+3S AD 9H JC 6D JD AS KH 6S JH
+AD 3D TS KS 7H JH 2D JS QD AC
+9C JD 7C 6D TC 6H 6C JC 3D 3S
+QC KC 3S JC KD 2C 8D AH QS TS
+AS KD 3D JD 8H 7C 8C 5C QD 6C
diff --git a/extra/project-euler/058/058-tests.factor b/extra/project-euler/058/058-tests.factor
new file mode 100644
index 0000000000..13a2aafa94
--- /dev/null
+++ b/extra/project-euler/058/058-tests.factor
@@ -0,0 +1,3 @@
+USING: project-euler.058 tools.test ;
+
+{ 26241 } [ euler058 ] unit-test
diff --git a/extra/project-euler/058/058.factor b/extra/project-euler/058/058.factor
new file mode 100644
index 0000000000..133175f2a8
--- /dev/null
+++ b/extra/project-euler/058/058.factor
@@ -0,0 +1,68 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry kernel math math.primes math.ranges project-euler.common sequences ;
+IN: project-euler.058
+
+! http://projecteuler.net/index.php?section=problems&id=58
+
+! DESCRIPTION
+! -----------
+
+! Starting with 1 and solveling anticlockwise in the following way, a square
+! solve with side length 7 is formed.
+
+! 37 36 35 34 33 32 31
+! 38 17 16 15 14 13 30
+! 39 18 5 4 3 12 29
+! 40 19 6 1 2 11 28
+! 41 20 7 8 9 10 27
+! 42 21 22 23 24 25 26
+! 43 44 45 46 47 48 49
+
+! It is interesting to note that the odd squares lie along the bottom right
+! diagonal, but what is more interesting is that 8 out of the 13 numbers lying
+! along both diagonals are prime; that is, a ratio of 8/13 ≈ 62%.
+
+! If one complete new layer is wrapped around the solve above, a square solve
+! with side length 9 will be formed. If this process is continued, what is the
+! side length of the square solve for which the ratio of primes along both
+! diagonals first falls below 10%?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+CONSTANT: PERCENT_PRIME 0.1
+
+! The corners of a square of side length n are:
+! (n-2)² + 1(n-1)
+! (n-2)² + 2(n-1)
+! (n-2)² + 3(n-1)
+! (n-2)² + 4(n-1) = odd squares, no need to calculate
+
+: prime-corners ( n -- m )
+ 3 [1,b] swap '[ _ [ 1- * ] keep 2 - sq + prime? ] count ;
+
+: total-corners ( n -- m )
+ 1- 2 * ; foldable
+
+: ratio-below? ( count length -- ? )
+ total-corners 1+ / PERCENT_PRIME < ;
+
+: next-layer ( count length -- count' length' )
+ 2 + [ prime-corners + ] keep ;
+
+: solve ( count length -- length )
+ 2dup ratio-below? [ nip ] [ next-layer solve ] if ;
+
+PRIVATE>
+
+: euler058 ( -- answer )
+ 8 7 solve ;
+
+! [ euler058 ] 10 ave-time
+! 12974 ms ave run time - 284.46 SD (10 trials)
+
+SOLUTION: euler058
diff --git a/extra/project-euler/063/063-tests.factor b/extra/project-euler/063/063-tests.factor
new file mode 100644
index 0000000000..0cff44db5e
--- /dev/null
+++ b/extra/project-euler/063/063-tests.factor
@@ -0,0 +1,3 @@
+USING: project-euler.063 tools.test ;
+
+{ 49 } [ euler063 ] unit-test
diff --git a/extra/project-euler/063/063.factor b/extra/project-euler/063/063.factor
new file mode 100644
index 0000000000..80e3990a24
--- /dev/null
+++ b/extra/project-euler/063/063.factor
@@ -0,0 +1,37 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
+IN: project-euler.063
+
+! http://projecteuler.net/index.php?section=problems&id=63
+
+! DESCRIPTION
+! -----------
+
+! The 5-digit number, 16807 = 7^5, is also a fifth power. Similarly, the
+! 9-digit number, 134217728 = 8^9, is a ninth power.
+
+! How many n-digit positive integers exist which are also an nth power?
+
+
+! SOLUTION
+! --------
+
+! Only have to check from 1 to 9 because 10^n already has too many digits.
+! In general, x^n has n digits when:
+
+! 10^(n-1) <= x^n < 10^n
+
+! ...take the left side of that equation, solve for n to see where they meet:
+
+! n = log(10) / [ log(10) - log(x) ]
+
+! Round down since we already know that particular value of n is no good.
+
+: euler063 ( -- answer )
+ 9 [1,b] [ log [ 10 log dup ] dip - /i ] sigma ;
+
+! [ euler063 ] 100 ave-time
+! 0 ms ave run time - 0.0 SD (100 trials)
+
+SOLUTION: euler063
diff --git a/extra/project-euler/069/069-tests.factor b/extra/project-euler/069/069-tests.factor
new file mode 100644
index 0000000000..97741c0ee3
--- /dev/null
+++ b/extra/project-euler/069/069-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.069 tools.test ;
+
+{ 510510 } [ euler069 ] unit-test
+{ 510510 } [ euler069a ] unit-test
diff --git a/extra/project-euler/069/069.factor b/extra/project-euler/069/069.factor
new file mode 100644
index 0000000000..3a59d66522
--- /dev/null
+++ b/extra/project-euler/069/069.factor
@@ -0,0 +1,84 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators fry kernel math math.primes math.primes.factors math.ranges
+ project-euler.common sequences ;
+IN: project-euler.069
+
+! http://projecteuler.net/index.php?section=problems&id=69
+
+! DESCRIPTION
+! -----------
+
+! Euler's Totient function, φ(n) [sometimes called the phi function], is used
+! to determine the number of numbers less than n which are relatively prime to
+! n. For example, as 1, 2, 4, 5, 7, and 8, are all less than nine and
+! relatively prime to nine, φ(9)=6.
+
+! +----+------------------+------+-----------+
+! | n | Relatively Prime | φ(n) | n / φ(n) |
+! +----+------------------+------+-----------+
+! | 2 | 1 | 1 | 2 |
+! | 3 | 1,2 | 2 | 1.5 |
+! | 4 | 1,3 | 2 | 2 |
+! | 5 | 1,2,3,4 | 4 | 1.25 |
+! | 6 | 1,5 | 2 | 3 |
+! | 7 | 1,2,3,4,5,6 | 6 | 1.1666... |
+! | 8 | 1,3,5,7 | 4 | 2 |
+! | 9 | 1,2,4,5,7,8 | 6 | 1.5 |
+! | 10 | 1,3,7,9 | 4 | 2.5 |
+! +----+------------------+------+-----------+
+
+! It can be seen that n = 6 produces a maximum n / φ(n) for n ≤ 10.
+
+! Find the value of n ≤ 1,000,000 for which n / φ(n) is a maximum.
+
+
+! SOLUTION
+! --------
+
+! Brute force
+
+<PRIVATE
+
+: totient-ratio ( n -- m )
+ dup totient / ;
+
+PRIVATE>
+
+: euler069 ( -- answer )
+ 2 1000000 [a,b] [ totient-ratio ] map
+ [ supremum ] keep index 2 + ;
+
+! [ euler069 ] 10 ave-time
+! 25210 ms ave run time - 115.37 SD (10 trials)
+
+
+! ALTERNATE SOLUTIONS
+! -------------------
+
+! In order to obtain maximum n / φ(n), φ(n) needs to be low and n needs to be
+! high. Hence we need a number that has the most factors. A number with the
+! most unique factors would have fewer relatively prime.
+
+<PRIVATE
+
+: primorial ( n -- m )
+ {
+ { [ dup 0 = ] [ drop V{ 1 } ] }
+ { [ dup 1 = ] [ drop V{ 2 } ] }
+ [ nth-prime primes-upto ]
+ } cond product ;
+
+: primorial-upto ( limit -- m )
+ 1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
+ nip penultimate ;
+
+PRIVATE>
+
+: euler069a ( -- answer )
+ 1000000 primorial-upto ;
+
+! [ euler069a ] 100 ave-time
+! 0 ms ave run time - 0.01 SD (100 trials)
+
+SOLUTION: euler069a
diff --git a/extra/project-euler/071/071.factor b/extra/project-euler/071/071.factor
index cccf6bf708..0fd93a8f2d 100644
--- a/extra/project-euler/071/071.factor
+++ b/extra/project-euler/071/071.factor
@@ -32,13 +32,6 @@ IN: project-euler.071
! repeatedly until the denominator is as close to 1000000 as possible without
! going over.
-<PRIVATE
-
-: penultimate ( seq -- elt )
- dup length 2 - swap nth ;
-
-PRIVATE>
-
: euler071 ( -- answer )
2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] produce
nip penultimate numerator ;
diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor
index e013e16575..314698534f 100644
--- a/extra/project-euler/150/150.factor
+++ b/extra/project-euler/150/150.factor
@@ -50,13 +50,13 @@ IN: project-euler.150
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
- 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ;
+ 0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
m [| x |
x 1+ [| y |
- m x - [| z |
+ m x - iota [| z |
x z + table nth-unsafe
[ y z + 1+ swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index ba8c81fbf4..c2ffe26d94 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -1,9 +1,10 @@
-! Copyright (c) 2007-2008 Aaron Schaefer.
+! Copyright (c) 2007-2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel make math math.functions math.matrices math.miller-rabin
- math.order math.parser math.primes.factors math.ranges math.ratios
- sequences sorting strings unicode.case parser accessors vocabs.parser
- namespaces vocabs words quotations prettyprint ;
+USING: accessors arrays kernel lists make math math.functions math.matrices
+ math.miller-rabin math.order math.parser math.primes.factors
+ math.primes.lists math.ranges math.ratios namespaces parser prettyprint
+ quotations sequences sorting strings unicode.case vocabs vocabs.parser
+ words ;
IN: project-euler.common
! A collection of words used by more than one Project Euler solution
@@ -16,11 +17,13 @@ IN: project-euler.common
! log10 - #25, #134
! max-path - #18, #67
! mediant - #71, #73
+! nth-prime - #7, #69
! nth-triangle - #12, #42
! number>digits - #16, #20, #30, #34, #35, #38, #43, #52, #55, #56, #92
! palindrome? - #4, #36, #55
! pandigital? - #32, #38
! pentagonal? - #44, #45
+! penultimate - #69, #71
! propagate-all - #18, #67
! sum-proper-divisors - #21
! tau* - #12
@@ -78,6 +81,9 @@ PRIVATE>
: number-length ( n -- m )
log10 floor 1+ >integer ;
+: nth-prime ( n -- n )
+ 1- lprimes lnth ;
+
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
@@ -90,6 +96,9 @@ PRIVATE>
: pentagonal? ( n -- ? )
dup 0 > [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ;
+: penultimate ( seq -- elt )
+ dup length 2 - swap nth ;
+
! Not strictly needed, but it is nice to be able to dump the triangle after the
! propagation
: propagate-all ( triangle -- new-triangle )
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 1e1da38a3f..95d3644215 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -1,4 +1,4 @@
-! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu.
+! Copyright (c) 2007-2009 Aaron Schaefer, Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: definitions io io.files io.pathnames kernel math math.parser
prettyprint project-euler.ave-time sequences vocabs vocabs.loader
@@ -14,8 +14,9 @@ USING: definitions io io.files io.pathnames kernel math math.parser
project-euler.037 project-euler.038 project-euler.039 project-euler.040
project-euler.041 project-euler.042 project-euler.043 project-euler.044
project-euler.045 project-euler.046 project-euler.047 project-euler.048
- project-euler.049 project-euler.052 project-euler.053 project-euler.055
- project-euler.056 project-euler.057 project-euler.059 project-euler.067
+ project-euler.049 project-euler.052 project-euler.053 project-euler.054
+ project-euler.055 project-euler.056 project-euler.057 project-euler.058
+ project-euler.059 project-euler.063 project-euler.067 project-euler.069
project-euler.071 project-euler.073 project-euler.075 project-euler.076
project-euler.079 project-euler.092 project-euler.097 project-euler.099
project-euler.100 project-euler.116 project-euler.117 project-euler.134
diff --git a/extra/qw/authors.txt b/extra/qw/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/qw/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/qw/qw-docs.factor b/extra/qw/qw-docs.factor
new file mode 100644
index 0000000000..4709ef620d
--- /dev/null
+++ b/extra/qw/qw-docs.factor
@@ -0,0 +1,12 @@
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax multiline ;
+IN: qw
+
+HELP: qw{
+{ $syntax "qw{ lorem ipsum }" }
+{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." }
+{ $examples
+{ $unchecked-example <" USING: prettyprint qw ;
+qw{ pop quiz my hive of big wild ex tranny jocks } . ">
+<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> }
+} ;
diff --git a/extra/qw/qw-tests.factor b/extra/qw/qw-tests.factor
new file mode 100644
index 0000000000..c9d9208751
--- /dev/null
+++ b/extra/qw/qw-tests.factor
@@ -0,0 +1,5 @@
+! (c)2009 Joe Groff bsd license
+USING: qw tools.test ;
+IN: qw.tests
+
+[ { "zippity" "doo" "dah" } ] [ qw{ zippity doo dah } ] unit-test
diff --git a/extra/qw/qw.factor b/extra/qw/qw.factor
new file mode 100644
index 0000000000..ce96587c92
--- /dev/null
+++ b/extra/qw/qw.factor
@@ -0,0 +1,5 @@
+! (c)2009 Joe Groff bsd license
+USING: lexer parser ;
+IN: qw
+
+SYNTAX: qw{ "}" parse-tokens parsed ;
diff --git a/extra/qw/summary.txt b/extra/qw/summary.txt
new file mode 100644
index 0000000000..8c31961dc8
--- /dev/null
+++ b/extra/qw/summary.txt
@@ -0,0 +1 @@
+Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar })
diff --git a/extra/robots/robots-tests.factor b/extra/robots/robots-tests.factor
index a590d9eee0..54b4892680 100644
--- a/extra/robots/robots-tests.factor
+++ b/extra/robots/robots-tests.factor
@@ -1,334 +1,335 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: calendar io.encodings.utf8 io.files robots tools.test ;
+USING: calendar io.encodings.utf8 io.files robots tools.test
+urls ;
IN: robots.tests
[
-{ "http://www.chiplist.com/sitemap.txt" }
-{
- T{ rules
- { user-agents V{ "*" } }
- { allows V{ } }
- { disallows
- V{
- "/cgi-bin/"
- "/scripts/"
- "/ChipList2/scripts/"
- "/ChipList2/styles/"
- "/ads/"
- "/ChipList2/ads/"
- "/advertisements/"
- "/ChipList2/advertisements/"
- "/graphics/"
- "/ChipList2/graphics/"
+ { "http://www.chiplist.com/sitemap.txt" }
+ {
+ T{ rules
+ { user-agents V{ "*" } }
+ { allows V{ } }
+ { disallows
+ V{
+ URL" /cgi-bin/"
+ URL" /scripts/"
+ URL" /ChipList2/scripts/"
+ URL" /ChipList2/styles/"
+ URL" /ads/"
+ URL" /ChipList2/ads/"
+ URL" /advertisements/"
+ URL" /ChipList2/advertisements/"
+ URL" /graphics/"
+ URL" /ChipList2/graphics/"
+ }
}
- }
- { visit-time
- {
- T{ timestamp { hour 2 } }
- T{ timestamp { hour 5 } }
+ { visit-time
+ {
+ T{ timestamp { hour 2 } }
+ T{ timestamp { hour 5 } }
+ }
}
+ { request-rate 1 }
+ { crawl-delay 1 }
+ { unknowns H{ } }
}
- { request-rate 1 }
- { crawl-delay 1 }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "UbiCrawler" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "DOC" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Zao" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "sitecheck.internetseer.com" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Zealbot" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "MSIECrawler" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "SiteSnagger" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "WebStripper" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "WebCopier" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Fetch" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Offline Explorer" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Teleport" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "TeleportPro" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "WebZIP" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "linko" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "HTTrack" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Microsoft.URL.Control" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Xenu" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "larbin" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "libwww" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "ZyBORG" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "Download Ninja" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "wget" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "grub-client" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "k2spider" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "NPBot" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents V{ "WebReaper" } }
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
- }
- T{ rules
- { user-agents
- V{
- "abot"
- "ALeadSoftbot"
- "BeijingCrawler"
- "BilgiBot"
- "bot"
- "botlist"
- "BOTW Spider"
- "bumblebee"
- "Bumblebee"
- "BuzzRankingBot"
- "Charlotte"
- "Clushbot"
- "Crawler"
- "CydralSpider"
- "DataFountains"
- "DiamondBot"
- "Dulance bot"
- "DYNAMIC"
- "EARTHCOM.info"
- "EDI"
- "envolk"
- "Exabot"
- "Exabot-Images"
- "Exabot-Test"
- "exactseek-pagereaper"
- "Exalead NG"
- "FANGCrawl"
- "Feed::Find"
- "flatlandbot"
- "Gigabot"
- "GigabotSiteSearch"
- "GurujiBot"
- "Hatena Antenna"
- "Hatena Bookmark"
- "Hatena RSS"
- "HatenaScreenshot"
- "Helix"
- "HiddenMarket"
- "HyperEstraier"
- "iaskspider"
- "IIITBOT"
- "InfociousBot"
- "iVia"
- "iVia Page Fetcher"
- "Jetbot"
- "Kolinka Forum Search"
- "KRetrieve"
- "LetsCrawl.com"
- "Lincoln State Web Browser"
- "Links4US-Crawler"
- "LOOQ"
- "Lsearch/sondeur"
- "MapoftheInternet.com"
- "NationalDirectory"
- "NetCarta_WebMapper"
- "NewsGator"
- "NextGenSearchBot"
- "ng"
- "nicebot"
- "NP"
- "NPBot"
- "Nudelsalat"
- "Nutch"
- "OmniExplorer_Bot"
- "OpenIntelligenceData"
- "Oracle Enterprise Search"
- "Pajaczek"
- "panscient.com"
- "PeerFactor 404 crawler"
- "PeerFactor Crawler"
- "PlantyNet"
- "PlantyNet_WebRobot"
- "plinki"
- "PMAFind"
- "Pogodak!"
- "QuickFinder Crawler"
- "Radiation Retriever"
- "Reaper"
- "RedCarpet"
- "ScorpionBot"
- "Scrubby"
- "Scumbot"
- "searchbot"
- "Seeker.lookseek.com"
- "SeznamBot"
- "ShowXML"
- "snap.com"
- "snap.com beta crawler"
- "Snapbot"
- "SnapPreviewBot"
- "sohu"
- "SpankBot"
- "Speedy Spider"
- "Speedy_Spider"
- "SpeedySpider"
- "spider"
- "SquigglebotBot"
- "SurveyBot"
- "SynapticSearch"
- "T-H-U-N-D-E-R-S-T-O-N-E"
- "Talkro Web-Shot"
- "Tarantula"
- "TerrawizBot"
- "TheInformant"
- "TMCrawler"
- "TridentSpider"
- "Tutorial Crawler"
- "Twiceler"
- "unwrapbot"
- "URI::Fetch"
- "VengaBot"
- "Vonna.com b o t"
- "Vortex"
- "Votay bot"
- "WebAlta Crawler"
- "Webbot"
- "Webclipping.com"
- "WebCorp"
- "Webinator"
- "WIRE"
- "WISEbot"
- "Xerka WebBot"
- "XSpider"
- "YodaoBot"
- "Yoono"
- "yoono"
+ T{ rules
+ { user-agents V{ "UbiCrawler" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "DOC" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Zao" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "sitecheck.internetseer.com" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Zealbot" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "MSIECrawler" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "SiteSnagger" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "WebStripper" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "WebCopier" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Fetch" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Offline Explorer" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Teleport" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "TeleportPro" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "WebZIP" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "linko" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "HTTrack" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Microsoft.URL.Control" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Xenu" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "larbin" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "libwww" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "ZyBORG" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "Download Ninja" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "wget" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "grub-client" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "k2spider" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "NPBot" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents V{ "WebReaper" } }
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
+ }
+ T{ rules
+ { user-agents
+ V{
+ "abot"
+ "ALeadSoftbot"
+ "BeijingCrawler"
+ "BilgiBot"
+ "bot"
+ "botlist"
+ "BOTW Spider"
+ "bumblebee"
+ "Bumblebee"
+ "BuzzRankingBot"
+ "Charlotte"
+ "Clushbot"
+ "Crawler"
+ "CydralSpider"
+ "DataFountains"
+ "DiamondBot"
+ "Dulance bot"
+ "DYNAMIC"
+ "EARTHCOM.info"
+ "EDI"
+ "envolk"
+ "Exabot"
+ "Exabot-Images"
+ "Exabot-Test"
+ "exactseek-pagereaper"
+ "Exalead NG"
+ "FANGCrawl"
+ "Feed::Find"
+ "flatlandbot"
+ "Gigabot"
+ "GigabotSiteSearch"
+ "GurujiBot"
+ "Hatena Antenna"
+ "Hatena Bookmark"
+ "Hatena RSS"
+ "HatenaScreenshot"
+ "Helix"
+ "HiddenMarket"
+ "HyperEstraier"
+ "iaskspider"
+ "IIITBOT"
+ "InfociousBot"
+ "iVia"
+ "iVia Page Fetcher"
+ "Jetbot"
+ "Kolinka Forum Search"
+ "KRetrieve"
+ "LetsCrawl.com"
+ "Lincoln State Web Browser"
+ "Links4US-Crawler"
+ "LOOQ"
+ "Lsearch/sondeur"
+ "MapoftheInternet.com"
+ "NationalDirectory"
+ "NetCarta_WebMapper"
+ "NewsGator"
+ "NextGenSearchBot"
+ "ng"
+ "nicebot"
+ "NP"
+ "NPBot"
+ "Nudelsalat"
+ "Nutch"
+ "OmniExplorer_Bot"
+ "OpenIntelligenceData"
+ "Oracle Enterprise Search"
+ "Pajaczek"
+ "panscient.com"
+ "PeerFactor 404 crawler"
+ "PeerFactor Crawler"
+ "PlantyNet"
+ "PlantyNet_WebRobot"
+ "plinki"
+ "PMAFind"
+ "Pogodak!"
+ "QuickFinder Crawler"
+ "Radiation Retriever"
+ "Reaper"
+ "RedCarpet"
+ "ScorpionBot"
+ "Scrubby"
+ "Scumbot"
+ "searchbot"
+ "Seeker.lookseek.com"
+ "SeznamBot"
+ "ShowXML"
+ "snap.com"
+ "snap.com beta crawler"
+ "Snapbot"
+ "SnapPreviewBot"
+ "sohu"
+ "SpankBot"
+ "Speedy Spider"
+ "Speedy_Spider"
+ "SpeedySpider"
+ "spider"
+ "SquigglebotBot"
+ "SurveyBot"
+ "SynapticSearch"
+ "T-H-U-N-D-E-R-S-T-O-N-E"
+ "Talkro Web-Shot"
+ "Tarantula"
+ "TerrawizBot"
+ "TheInformant"
+ "TMCrawler"
+ "TridentSpider"
+ "Tutorial Crawler"
+ "Twiceler"
+ "unwrapbot"
+ "URI::Fetch"
+ "VengaBot"
+ "Vonna.com b o t"
+ "Vortex"
+ "Votay bot"
+ "WebAlta Crawler"
+ "Webbot"
+ "Webclipping.com"
+ "WebCorp"
+ "Webinator"
+ "WIRE"
+ "WISEbot"
+ "Xerka WebBot"
+ "XSpider"
+ "YodaoBot"
+ "Yoono"
+ "yoono"
+ }
}
+ { allows V{ } }
+ { disallows V{ URL" /" } }
+ { unknowns H{ } }
}
- { allows V{ } }
- { disallows V{ "/" } }
- { unknowns H{ } }
}
-}
] [ "vocab:robots/robots.txt" utf8 file-contents parse-robots.txt ] unit-test
diff --git a/extra/robots/robots.factor b/extra/robots/robots.factor
index 1b2422f06e..3c0eb045f7 100644
--- a/extra/robots/robots.factor
+++ b/extra/robots/robots.factor
@@ -3,11 +3,21 @@
USING: accessors http.client kernel unicode.categories
sequences urls splitting combinators splitting.monotonic
combinators.short-circuit assocs unicode.case arrays
-math.parser calendar.format make ;
+math.parser calendar.format make fry present globs
+multiline regexp.combinators regexp ;
IN: robots
! visit-time is GMT, request-rate is pages/second
! crawl-rate is seconds
+
+TUPLE: robots site sitemap rules rules-quot ;
+
+: <robots> ( site sitemap rules -- robots )
+ \ robots new
+ swap >>rules
+ swap >>sitemap
+ swap >>site ;
+
TUPLE: rules user-agents allows disallows
visit-time request-rate crawl-delay unknowns ;
@@ -40,8 +50,8 @@ visit-time request-rate crawl-delay unknowns ;
H{ } clone >>unknowns ;
: add-user-agent ( rules agent -- rules ) over user-agents>> push ;
-: add-allow ( rules allow -- rules ) over allows>> push ;
-: add-disallow ( rules disallow -- rules ) over disallows>> push ;
+: add-allow ( rules allow -- rules ) >url over allows>> push ;
+: add-disallow ( rules disallow -- rules ) >url over disallows>> push ;
: parse-robots.txt-line ( rules seq -- rules )
first2 swap {
@@ -57,6 +67,19 @@ visit-time request-rate crawl-delay unknowns ;
[ pick unknowns>> push-at ]
} case ;
+: derive-urls ( url seq -- seq' )
+ [ derive-url present ] with { } map-as ;
+
+: robot-rules-quot ( robots -- quot )
+ [
+ [ site>> ] [ rules>> allows>> ] bi
+ derive-urls [ <glob> ] map
+ <or>
+ ] [
+ [ site>> ] [ rules>> disallows>> ] bi
+ derive-urls [ <glob> ] map <and> <not>
+ ] bi 2array <or> '[ _ matches? ] ;
+
PRIVATE>
: parse-robots.txt ( string -- sitemaps rules-seq )
@@ -64,5 +87,6 @@ PRIVATE>
[ <rules> dup ] dip [ parse-robots.txt-line drop ] with each
] map ;
-: robots ( url -- sitemaps rules-seq )
- get-robots.txt nip parse-robots.txt ;
+: robots ( url -- robots )
+ >url
+ dup get-robots.txt nip parse-robots.txt <robots> ;
diff --git a/extra/roles/authors.txt b/extra/roles/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/roles/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/roles/roles-docs.factor b/extra/roles/roles-docs.factor
new file mode 100644
index 0000000000..412a7b8dcb
--- /dev/null
+++ b/extra/roles/roles-docs.factor
@@ -0,0 +1,48 @@
+! (c)2009 Joe Groff bsd license
+USING: classes.mixin help.markup help.syntax kernel multiline roles ;
+IN: roles
+
+HELP: ROLE:
+{ $syntax <" ROLE: name slots... ;
+ROLE: name < role slots... ;
+ROLE: name <{ roles... } slots... ; "> }
+{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "."
+$nl
+"Slot specifiers take one of the following three forms:"
+{ $list
+ { { $snippet "name" } " - a slot which can hold any object, with no attributes" }
+ { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" }
+ { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
+}
+"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ;
+
+HELP: TUPLE:
+{ $syntax <" TUPLE: name slots ;
+TUPLE: name < estate slots ;
+TUPLE: name <{ estates... } slots... ; "> }
+{ $description "Defines a new " { $link tuple } " class."
+$nl
+"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "."
+$nl
+"Slot specifiers take one of the following three forms:"
+{ $list
+ { { $snippet "name" } " - a slot which can hold any object, with no attributes" }
+ { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" }
+ { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" }
+}
+"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ;
+
+{
+ POSTPONE: ROLE:
+ POSTPONE: TUPLE:
+} related-words
+
+HELP: role
+{ $class-description "The superclass of all role classes. A " { $snippet "role" } " is a " { $link mixin-class } " that includes a set of slot definitions that can be added to " { $link tuple } " classes alongside other " { $snippet "role" } "s." } ;
+
+HELP: multiple-inheritance-attempted
+{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " definition attempts to inherit more than one " { $link tuple } " class." } ;
+
+HELP: role-slot-overlap
+{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ;
+
diff --git a/extra/roles/roles-tests.factor b/extra/roles/roles-tests.factor
new file mode 100644
index 0000000000..fcbc20db16
--- /dev/null
+++ b/extra/roles/roles-tests.factor
@@ -0,0 +1,67 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors classes.tuple compiler.units kernel qw roles sequences
+tools.test ;
+IN: roles.tests
+
+ROLE: fork tines ;
+ROLE: spoon bowl ;
+ROLE: instrument tone ;
+ROLE: tuning-fork <{ fork instrument } volume ;
+
+TUPLE: utensil handle ;
+
+! role consumption and tuple inheritance can be mixed
+TUPLE: foon <{ utensil fork spoon } ;
+TUPLE: tuning-spork <{ utensil spoon tuning-fork } ;
+
+! role class testing
+[ t ] [ fork role? ] unit-test
+[ f ] [ foon role? ] unit-test
+
+! roles aren't tuple classes by themselves and can't be instantiated
+[ f ] [ fork tuple-class? ] unit-test
+[ fork new ] must-fail
+
+! tuples which consume roles fall under their class
+[ t ] [ foon new fork? ] unit-test
+[ t ] [ foon new spoon? ] unit-test
+[ f ] [ foon new tuning-fork? ] unit-test
+[ f ] [ foon new instrument? ] unit-test
+
+[ t ] [ tuning-spork new fork? ] unit-test
+[ t ] [ tuning-spork new spoon? ] unit-test
+[ t ] [ tuning-spork new tuning-fork? ] unit-test
+[ t ] [ tuning-spork new instrument? ] unit-test
+
+! consumed role slots are placed in tuples in order
+[ qw{ handle tines bowl } ] [ foon all-slots [ name>> ] map ] unit-test
+[ qw{ handle bowl tines tone volume } ] [ tuning-spork all-slots [ name>> ] map ] unit-test
+
+! can't combine roles whose slots overlap
+ROLE: bong bowl ;
+SYMBOL: spong
+
+[ [ spong { spoon bong } { } define-tuple-class-with-roles ] with-compilation-unit ]
+[ role-slot-overlap? ] must-fail-with
+
+[ [ spong { spoon bong } { } define-role ] with-compilation-unit ]
+[ role-slot-overlap? ] must-fail-with
+
+! can't try to inherit multiple tuple classes
+TUPLE: tool blade ;
+SYMBOL: knife
+
+[ knife { utensil tool } { } define-tuple-class-with-roles ]
+[ multiple-inheritance-attempted? ] must-fail-with
+
+! make sure method dispatch works
+GENERIC: poke ( pokee poker -- result )
+GENERIC: scoop ( scoopee scooper -- result )
+GENERIC: tune ( tunee tuner -- result )
+
+M: fork poke drop " got poked" append ;
+M: spoon scoop drop " got scooped" append ;
+M: instrument tune drop " got tuned" append ;
+
+[ "potato got poked" "potato got scooped" "potato got tuned" ]
+[ "potato" tuning-spork new [ poke ] [ scoop ] [ tune ] 2tri ] unit-test
diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor
new file mode 100644
index 0000000000..d54b4339a7
--- /dev/null
+++ b/extra/roles/roles.factor
@@ -0,0 +1,69 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays classes classes.mixin classes.parser
+classes.tuple classes.tuple.parser combinators
+combinators.short-circuit kernel lexer make parser sequences
+sets strings words ;
+IN: roles
+
+ERROR: role-slot-overlap class slots ;
+ERROR: multiple-inheritance-attempted classes ;
+
+PREDICATE: role < mixin-class
+ "role-slots" word-prop >boolean ;
+
+: parse-role-definition ( -- class superroles slots )
+ CREATE-CLASS scan {
+ { ";" [ { } { } ] }
+ { "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] }
+ { "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] }
+ [ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
+ } case ;
+
+: slot-name ( name/array -- name )
+ dup string? [ ] [ first ] if ;
+: slot-names ( array -- names )
+ [ slot-name ] map ;
+
+: role-slots ( role -- slots )
+ [ "superroles" word-prop [ role-slots ] map concat ]
+ [ "role-slots" word-prop ] bi append ;
+
+: role-or-tuple-slot-names ( role-or-tuple -- names )
+ dup role?
+ [ role-slots slot-names ]
+ [ all-slots [ name>> ] map ] if ;
+
+: check-for-slot-overlap ( class roles-and-superclass slots -- )
+ [ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append
+ duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ;
+
+: roles>slots ( roles-and-superclass slots -- superclass slots' )
+ [
+ [ role? ] partition
+ dup length {
+ { 0 [ drop tuple ] }
+ { 1 [ first ] }
+ [ drop multiple-inheritance-attempted ]
+ } case
+ swap [ role-slots ] map concat
+ ] dip append ;
+
+: add-to-roles ( class roles -- )
+ [ add-mixin-instance ] with each ;
+
+: (define-role) ( class superroles slots -- )
+ [ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry*
+ [ define-mixin-class ] tri ;
+
+: define-role ( class superroles slots -- )
+ [ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ;
+
+: define-tuple-class-with-roles ( class roles-and-superclass slots -- )
+ [ check-for-slot-overlap ]
+ [ roles>slots define-tuple-class ]
+ [ drop [ role? ] filter add-to-roles ] 3tri ;
+
+SYNTAX: ROLE: parse-role-definition define-role ;
+SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ;
+
+
diff --git a/extra/roles/summary.txt b/extra/roles/summary.txt
new file mode 100644
index 0000000000..a14aae4838
--- /dev/null
+++ b/extra/roles/summary.txt
@@ -0,0 +1 @@
+Mixins for tuples
diff --git a/extra/sandbox/authors.txt b/extra/sandbox/authors.txt
new file mode 100644
index 0000000000..f97e1bfbf9
--- /dev/null
+++ b/extra/sandbox/authors.txt
@@ -0,0 +1 @@
+Maxim Savchenko
diff --git a/extra/sandbox/sandbox-tests.factor b/extra/sandbox/sandbox-tests.factor
new file mode 100644
index 0000000000..5d0496e77b
--- /dev/null
+++ b/extra/sandbox/sandbox-tests.factor
@@ -0,0 +1,57 @@
+! Copyright (C) 2009 Maxim Savchenko
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel accessors continuations lexer vocabs vocabs.parser
+ combinators.short-circuit sandbox tools.test ;
+
+IN: sandbox.tests
+
+<< "sandbox.syntax" load-vocab drop >>
+USE: sandbox.syntax.private
+
+: run-script ( x lines -- y )
+ H{ { "kernel" "kernel" } { "math" "math" } { "sequences" "sequences" } }
+ parse-sandbox call( x -- x! ) ;
+
+[ 120 ]
+[
+ 5
+ {
+ "! Simple factorial example"
+ "APPLYING: kernel math sequences ;"
+ "1 swap [ 1+ * ] each"
+ } run-script
+] unit-test
+
+[
+ 5
+ {
+ "! Jailbreak attempt with USE:"
+ "USE: io"
+ "\"Hello world!\" print"
+ } run-script
+]
+[
+ {
+ [ lexer-error? ]
+ [ error>> condition? ]
+ [ error>> error>> no-word-error? ]
+ [ error>> error>> name>> "USE:" = ]
+ } 1&&
+] must-fail-with
+
+[
+ 5
+ {
+ "! Jailbreak attempt with unauthorized APPLY:"
+ "APPLY: io"
+ "\"Hello world!\" print"
+ } run-script
+]
+[
+ {
+ [ lexer-error? ]
+ [ error>> sandbox-error? ]
+ [ error>> vocab>> "io" = ]
+ } 1&&
+] must-fail-with
diff --git a/extra/sandbox/sandbox.factor b/extra/sandbox/sandbox.factor
new file mode 100644
index 0000000000..097a7c8d8a
--- /dev/null
+++ b/extra/sandbox/sandbox.factor
@@ -0,0 +1,23 @@
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences vectors assocs namespaces parser lexer vocabs
+ combinators.short-circuit vocabs.parser ;
+
+IN: sandbox
+
+SYMBOL: whitelist
+
+: with-sandbox-vocabs ( quot -- )
+ "sandbox.syntax" load-vocab vocab-words 1vector
+ use [ auto-use? off call ] with-variable ; inline
+
+: parse-sandbox ( lines assoc -- quot )
+ whitelist [ [ parse-lines ] with-sandbox-vocabs ] with-variable ;
+
+: reveal-in ( name -- )
+ [ { [ search ] [ no-word ] } 1|| ] keep current-vocab vocab-words set-at ;
+
+SYNTAX: REVEAL: scan reveal-in ;
+
+SYNTAX: REVEALING: ";" parse-tokens [ reveal-in ] each ;
diff --git a/extra/sandbox/summary.txt b/extra/sandbox/summary.txt
new file mode 100644
index 0000000000..3ca1e25684
--- /dev/null
+++ b/extra/sandbox/summary.txt
@@ -0,0 +1 @@
+Basic sandboxing
diff --git a/extra/sandbox/syntax/syntax.factor b/extra/sandbox/syntax/syntax.factor
new file mode 100644
index 0000000000..2ff5f070c7
--- /dev/null
+++ b/extra/sandbox/syntax/syntax.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2009 Maxim Savchenko.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences assocs namespaces lexer vocabs.parser sandbox ;
+IN: sandbox.syntax
+
+<PRIVATE
+
+ERROR: sandbox-error vocab ;
+
+: sandbox-use+ ( alias -- )
+ dup whitelist get at [ use+ ] [ sandbox-error ] ?if ;
+
+PRIVATE>
+
+SYNTAX: APPLY: scan sandbox-use+ ;
+
+SYNTAX: APPLYING: ";" parse-tokens [ sandbox-use+ ] each ;
+
+REVEALING:
+ ! #!
+ HEX: OCT: BIN: f t CHAR: "
+ [ { T{
+ ] } ;
+
+REVEAL: ;
diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor
new file mode 100644
index 0000000000..da097f4c00
--- /dev/null
+++ b/extra/sequence-parser/sequence-parser-tests.factor
@@ -0,0 +1,204 @@
+USING: tools.test sequence-parser unicode.categories kernel
+accessors ;
+IN: sequence-parser.tests
+
+[ "hello" ]
+[ "hello" [ take-rest ] parse-sequence ] unit-test
+
+[ "hi" " how are you?" ]
+[
+ "hi how are you?"
+ [ [ [ current blank? ] take-until ] [ take-rest ] bi ] parse-sequence
+] unit-test
+
+[ "foo" ";bar" ]
+[
+ "foo;bar" [
+ [ CHAR: ; take-until-object ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " "and bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ] [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ]
+ [ "and" take-sequence drop ]
+ [ take-rest ] tri
+ ] parse-sequence
+] unit-test
+
+[ "foo " " bar" ]
+[
+ "foo and bar" [
+ [ "and" take-until-sequence* ]
+ [ take-rest ] bi
+ ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <sequence-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ f "aaaa" ]
+[
+ "aaaa" <sequence-parser>
+ [ "b" take-until-sequence ] [ take-rest ] bi
+] unit-test
+
+[ 6 ]
+[
+ " foo " [ skip-whitespace n>> ] parse-sequence
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <sequence-parser> [ current 3 = ] take-until ] unit-test
+
+[ "ab" ]
+[ "abcd" <sequence-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <sequence-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+ "abcd" <sequence-parser>
+ [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <sequence-parser> "" take-sequence ] unit-test
+
+[ "cd" ]
+[ "abcd" <sequence-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
+
+[ f ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "abc\\\"def" ]
+[
+ "\"abc\\\"def\" asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "asdf" ]
+[
+ "\"abc\" asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
+
+[ f ]
+[
+ "\"abc asdf" <sequence-parser>
+ CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+ "\"abc asdf" <sequence-parser>
+ [ CHAR: \ CHAR: " take-quoted-string drop ]
+ [ "\"abc" take-sequence ] bi
+] unit-test
+
+[ "c" ]
+[ "c" <sequence-parser> take-token ] unit-test
+
+[ f ]
+[ "" <sequence-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "" ]
+[ "" <sequence-parser> take-rest ] unit-test
+
+[ "" ]
+[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <sequence-parser> "abcdefg" take-sequence ] unit-test
+
+[ "1234" ]
+[ "1234f" <sequence-parser> take-integer ] unit-test
+
+[ "yes" ]
+[
+ "yes1234f" <sequence-parser>
+ [ take-integer drop ] [ "yes" take-sequence ] bi
+] unit-test
+
+[ f ] [ "" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" ] [ "abcd" <sequence-parser> 4 take-n ] unit-test
+[ "abcd" "efg" ] [ "abcdefg" <sequence-parser> [ 4 take-n ] [ take-rest ] bi ] unit-test
+
+[ "asdfasdf" ] [
+ "/*asdfasdf*/" <sequence-parser> take-c-comment
+] unit-test
+
+[ "k" ] [
+ "/*asdfasdf*/k" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "//asdfasdf\nomg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "omg" ] [
+ "omg" <sequence-parser>
+ [ take-c++-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "/*asdfasdf" ] [
+ "/*asdfasdf" <sequence-parser> [ take-c-comment drop ] [ take-rest ] bi
+] unit-test
+
+[ "asdf" "eoieoei" ] [
+ "//asdf\neoieoei" <sequence-parser>
+ [ take-c++-comment ] [ take-rest ] bi
+] unit-test
+
+[ f "33asdf" ]
+[ "33asdf" <sequence-parser> [ take-c-identifier ] [ take-rest ] bi ] unit-test
+
+[ "asdf" ]
+[ "asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf" ]
+[ "_asdf" <sequence-parser> take-c-identifier ] unit-test
+
+[ "_asdf400" ]
+[ "_asdf400" <sequence-parser> take-c-identifier ] unit-test
+
+[ "123" ]
+[ "123jjj" <sequence-parser> take-c-integer ] unit-test
+
+[ "123uLL" ]
+[ "123uLL" <sequence-parser> take-c-integer ] unit-test
+
+[ "123ull" ]
+[ "123ull" <sequence-parser> take-c-integer ] unit-test
+
+[ "123u" ]
+[ "123u" <sequence-parser> take-c-integer ] unit-test
+
+[ 36 ]
+[
+ " //jofiejoe\n //eoieow\n/*asdf*/\n "
+ <sequence-parser> skip-whitespace/comments n>>
+] unit-test
+
+[ f ]
+[ "\n" <sequence-parser> take-integer ] unit-test
+
+[ "\n" ] [ "\n" <sequence-parser> [ ] take-while ] unit-test
+[ f ] [ "\n" <sequence-parser> [ not ] take-while ] unit-test
diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor
new file mode 100644
index 0000000000..4cc10fd5fd
--- /dev/null
+++ b/extra/sequence-parser/sequence-parser.factor
@@ -0,0 +1,259 @@
+! Copyright (C) 2005, 2009 Daniel Ehrenberg, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces math kernel sequences accessors fry circular
+unicode.case unicode.categories locals combinators.short-circuit
+make combinators io splitting math.parser math.ranges
+generalizations sorting.functor math.order sorting.slots ;
+IN: sequence-parser
+
+TUPLE: sequence-parser sequence n ;
+
+: <sequence-parser> ( sequence -- sequence-parser )
+ sequence-parser new
+ swap >>sequence
+ 0 >>n ;
+
+:: with-sequence-parser ( sequence-parser quot -- seq/f )
+ sequence-parser n>> :> n
+ sequence-parser quot call [
+ n sequence-parser (>>n) f
+ ] unless* ; inline
+
+: offset ( sequence-parser offset -- char/f )
+ swap
+ [ n>> + ] [ sequence>> ?nth ] bi ; inline
+
+: current ( sequence-parser -- char/f ) 0 offset ; inline
+
+: previous ( sequence-parser -- char/f ) -1 offset ; inline
+
+: peek-next ( sequence-parser -- char/f ) 1 offset ; inline
+
+: advance ( sequence-parser -- sequence-parser )
+ [ 1 + ] change-n ; inline
+
+: advance* ( sequence-parser -- )
+ advance drop ; inline
+
+: get+increment ( sequence-parser -- char/f )
+ [ current ] [ advance drop ] bi ; inline
+
+:: skip-until ( sequence-parser quot: ( obj -- ? ) -- )
+ sequence-parser current [
+ sequence-parser quot call
+ [ sequence-parser advance quot skip-until ] unless
+ ] when ; inline recursive
+
+: sequence-parse-end? ( sequence-parser -- ? ) current not ;
+
+: take-until ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ over sequence-parse-end? [
+ 2drop f
+ ] [
+ [ drop n>> ]
+ [ skip-until ]
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq f like
+ ] if ; inline
+
+: take-while ( sequence-parser quot: ( obj -- ? ) -- sequence/f )
+ [ not ] compose take-until ; inline
+
+: <safe-slice> ( from to seq -- slice/f )
+ 3dup {
+ [ 2drop 0 < ]
+ [ [ drop ] 2dip length > ]
+ [ drop > ]
+ } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
+:: take-sequence ( sequence-parser sequence -- obj/f )
+ sequence-parser [ n>> dup sequence length + ] [ sequence>> ] bi
+ <safe-slice> sequence sequence= [
+ sequence
+ sequence-parser [ sequence length + ] change-n drop
+ ] [
+ f
+ ] if ;
+
+: take-sequence* ( sequence-parser sequence -- )
+ take-sequence drop ;
+
+:: take-until-sequence ( sequence-parser sequence -- sequence'/f )
+ sequence-parser n>> :> saved
+ sequence length <growing-circular> :> growing
+ sequence-parser
+ [
+ current growing push-growing-circular
+ sequence growing sequence=
+ ] take-until :> found
+ growing sequence sequence= [
+ found dup length
+ growing length 1- - head
+ sequence-parser [ growing length - 1 + ] change-n drop
+ ! sequence-parser advance drop
+ ] [
+ saved sequence-parser (>>n)
+ f
+ ] if ;
+
+:: take-until-sequence* ( sequence-parser sequence -- sequence'/f )
+ sequence-parser sequence take-until-sequence :> out
+ out [
+ sequence-parser [ sequence length + ] change-n drop
+ ] when out ;
+
+: skip-whitespace ( sequence-parser -- sequence-parser )
+ [ [ current blank? not ] take-until drop ] keep ;
+
+: skip-whitespace-eol ( sequence-parser -- sequence-parser )
+ [ [ current " \t\r" member? not ] take-until drop ] keep ;
+
+: take-c-comment ( sequence-parser -- seq/f )
+ [
+ dup "/*" take-sequence [
+ "*/" take-until-sequence*
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: take-c++-comment ( sequence-parser -- seq/f )
+ [
+ dup "//" take-sequence [
+ [
+ [
+ { [ current CHAR: \n = ] [ sequence-parse-end? ] } 1||
+ ] take-until
+ ] [
+ advance drop
+ ] bi
+ ] [
+ drop f
+ ] if
+ ] with-sequence-parser ;
+
+: skip-whitespace/comments ( sequence-parser -- sequence-parser )
+ skip-whitespace-eol
+ {
+ { [ dup take-c-comment ] [ skip-whitespace/comments ] }
+ { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
+ [ ]
+ } cond ;
+
+: take-define-identifier ( sequence-parser -- string )
+ skip-whitespace/comments
+ [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
+: take-rest-slice ( sequence-parser -- sequence/f )
+ [ sequence>> ] [ n>> ] bi
+ 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
+: take-rest ( sequence-parser -- sequence )
+ [ take-rest-slice ] [ sequence>> like ] bi ;
+
+: take-until-object ( sequence-parser obj -- sequence )
+ '[ current _ = ] take-until ;
+
+: parse-sequence ( sequence quot -- )
+ [ <sequence-parser> ] dip call ; inline
+
+:: take-quoted-string ( sequence-parser escape-char quote-char -- string )
+ sequence-parser n>> :> start-n
+ sequence-parser advance
+ [
+ {
+ [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
+ [ current quote-char = not ]
+ } 1||
+ ] take-while :> string
+ sequence-parser current quote-char = [
+ sequence-parser advance* string
+ ] [
+ start-n sequence-parser (>>n) f
+ ] if ;
+
+: (take-token) ( sequence-parser -- string )
+ skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
+
+:: take-token* ( sequence-parser escape-char quote-char -- string/f )
+ sequence-parser skip-whitespace
+ dup current {
+ { quote-char [ escape-char quote-char take-quoted-string ] }
+ { f [ drop f ] }
+ [ drop (take-token) ]
+ } case ;
+
+: take-token ( sequence-parser -- string/f )
+ CHAR: \ CHAR: " take-token* ;
+
+: take-integer ( sequence-parser -- n/f )
+ [ current digit? ] take-while ;
+
+:: take-n ( sequence-parser n -- seq/f )
+ n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
+ f
+ ] [
+ sequence-parser n>> dup n + sequence-parser sequence>> subseq
+ sequence-parser [ n + ] change-n drop
+ ] if ;
+
+: c-identifier-begin? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ { CHAR: _ } 3append member? ;
+
+: c-identifier-ch? ( ch -- ? )
+ CHAR: a CHAR: z [a,b]
+ CHAR: A CHAR: Z [a,b]
+ CHAR: 0 CHAR: 9 [a,b]
+ { CHAR: _ } 4 nappend member? ;
+
+: (take-c-identifier) ( sequence-parser -- string/f )
+ dup current c-identifier-begin? [
+ [ current c-identifier-ch? ] take-while
+ ] [
+ drop f
+ ] if ;
+
+: take-c-identifier ( sequence-parser -- string/f )
+ [ (take-c-identifier) ] with-sequence-parser ;
+
+<< "length" [ length ] define-sorting >>
+
+: sort-tokens ( seq -- seq' )
+ { length>=< <=> } sort-by ;
+
+: take-first-matching ( sequence-parser seq -- seq )
+ swap
+ '[ _ [ swap take-sequence ] with-sequence-parser ] find nip ;
+
+
+: take-longest ( sequence-parser seq -- seq )
+ sort-tokens take-first-matching ;
+
+: take-c-integer ( sequence-parser -- string/f )
+ [
+ dup take-integer [
+ swap
+ { "ull" "uLL" "Ull" "ULL" "ll" "LL" "l" "L" "u" "U" }
+ take-longest [ append ] when*
+ ] [
+ drop f
+ ] if*
+ ] with-sequence-parser ;
+
+CONSTANT: c-punctuators
+ {
+ "[" "]" "(" ")" "{" "}" "." "->"
+ "++" "--" "&" "*" "+" "-" "~" "!"
+ "/" "%" "<<" ">>" "<" ">" "<=" ">=" "==" "!=" "^" "|" "&&" "||"
+ "?" ":" ";" "..."
+ "=" "*=" "/=" "%=" "+=" "-=" "<<=" ">>=" "&=" "^=" "|="
+ "," "#" "##"
+ "<:" ":>" "<%" "%>" "%:" "%:%:"
+ }
+
+: take-c-punctuator ( sequence-parser -- string/f )
+ c-punctuators take-longest ;
+
+: write-full ( sequence-parser -- ) sequence>> write ;
+: write-rest ( sequence-parser -- ) take-rest write ;
diff --git a/extra/sequences/product/authors.txt b/extra/sequences/product/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/sequences/product/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor
new file mode 100644
index 0000000000..b7dcaa626e
--- /dev/null
+++ b/extra/sequences/product/product-docs.factor
@@ -0,0 +1,61 @@
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax multiline quotations sequences sequences.product ;
+IN: sequences
+
+HELP: product-sequence
+{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link <product-sequence> } " word." }
+{ $examples
+{ $example <" USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
+"> <" {
+ { 1 "a" }
+ { 2 "a" }
+ { 3 "a" }
+ { 1 "b" }
+ { 2 "b" }
+ { 3 "b" }
+ { 1 "c" }
+ { 2 "c" }
+ { 3 "c" }
+}"> } } ;
+
+HELP: <product-sequence>
+{ $values { "sequences" sequence } { "product-sequence" product-sequence } }
+{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." }
+{ $examples
+{ $example <" USING: arrays prettyprint sequences.product ;
+{ { 1 2 3 } { "a" "b" "c" } } <product-sequence> >array .
+"> <" {
+ { 1 "a" }
+ { 2 "a" }
+ { 3 "a" }
+ { 1 "b" }
+ { 2 "b" }
+ { 3 "b" }
+ { 1 "c" }
+ { 2 "c" }
+ { 3 "c" }
+}"> } } ;
+
+{ product-sequence <product-sequence> } related-words
+
+HELP: product-map
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." }
+{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] map" } "." } ;
+
+HELP: product-each
+{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } }
+{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." }
+{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet "<product-sequence> [ ... ] each" } "." } ;
+
+{ product-map product-each } related-words
+
+ARTICLE: "sequences.product" "Product sequences"
+"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences."
+{ $subsection product-sequence }
+{ $subsection <product-sequence> }
+{ $subsection product-map }
+{ $subsection product-each } ;
+
+ABOUT: "sequences.product"
diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor
index dfabc166ac..5e0997dc2e 100644
--- a/extra/sequences/product/product-tests.factor
+++ b/extra/sequences/product/product-tests.factor
@@ -1,19 +1,26 @@
-USING: arrays kernel sequences sequences.cartesian-product tools.test ;
+! (c)2009 Joe Groff bsd license
+USING: arrays kernel make sequences sequences.product tools.test ;
IN: sequences.product.tests
-[
- { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } }
-] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test
+
+[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ]
+[ { { 0 1 2 } { "a" "b" } } <product-sequence> >array ] unit-test
+
+: x ( n s -- sss ) <repetition> concat ;
+
+[ { "a" "aa" "aaa" "b" "bb" "bbb" } ]
+[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test
[
{
{ 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t }
{ 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f }
}
-] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test
-
-[
- { "012012" "aaabbb" }
-] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test
-
+] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test
+[ "a1b1c1a2b2c2" ] [
+ [
+ { { "a" "b" "c" } { "1" "2" } }
+ [ [ % ] each ] product-each
+ ] "" make
+] unit-test
diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor
new file mode 100644
index 0000000000..665d43f0cd
--- /dev/null
+++ b/extra/sequences/product/product.factor
@@ -0,0 +1,63 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays kernel locals math sequences ;
+IN: sequences.product
+
+TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ;
+
+: <product-sequence> ( sequences -- product-sequence )
+ >array dup [ length ] map product-sequence boa ;
+
+INSTANCE: product-sequence sequence
+
+M: product-sequence length lengths>> product ;
+
+<PRIVATE
+
+: ns ( n lengths -- ns )
+ [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ;
+
+: nths ( ns seqs -- nths )
+ [ nth ] { } 2map-as ;
+
+: product@ ( n product-sequence -- ns seqs )
+ [ lengths>> ns ] [ nip sequences>> ] 2bi ;
+
+:: (carry-n) ( ns lengths i -- )
+ ns length i 1+ = [
+ i ns nth i lengths nth = [
+ 0 i ns set-nth
+ i 1+ ns [ 1+ ] change-nth
+ ns lengths i 1+ (carry-n)
+ ] when
+ ] unless ;
+
+: carry-ns ( ns lengths -- )
+ 0 (carry-n) ;
+
+: product-iter ( ns lengths -- )
+ [ 0 over [ 1+ ] change-nth ] dip carry-ns ;
+
+: start-product-iter ( sequence-product -- ns lengths )
+ [ [ drop 0 ] map ] [ [ length ] map ] bi ;
+
+: end-product-iter? ( ns lengths -- ? )
+ [ 1 tail* first ] bi@ = ;
+
+PRIVATE>
+
+M: product-sequence nth
+ product@ nths ;
+
+:: product-each ( sequences quot -- )
+ sequences start-product-iter :> lengths :> ns
+ [ ns lengths end-product-iter? ]
+ [ ns sequences nths quot call ns lengths product-iter ] until ; inline
+
+:: product-map ( sequences quot -- sequence )
+ 0 :> i!
+ sequences [ length ] [ * ] map-reduce sequences
+ [| result |
+ sequences [ quot call i result set-nth i 1+ i! ] product-each
+ result
+ ] new-like ; inline
+
diff --git a/extra/sequences/product/summary.txt b/extra/sequences/product/summary.txt
new file mode 100644
index 0000000000..c234c84a94
--- /dev/null
+++ b/extra/sequences/product/summary.txt
@@ -0,0 +1 @@
+Cartesian products of sequences
diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor
index 148e5b96f9..003b6bb58b 100644
--- a/extra/site-watcher/db/db.factor
+++ b/extra/site-watcher/db/db.factor
@@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors continuations db db.sqlite db.tuples db.types
io.directories io.files.temp kernel io.streams.string calendar
-debugger combinators.smart sequences ;
+debugger combinators.smart sequences arrays ;
IN: site-watcher.db
-TUPLE: account account-id account-name email twitter sms ;
+TUPLE: account account-name email twitter sms ;
: <account> ( account-name email -- account )
account new
@@ -25,6 +25,12 @@ TUPLE: site site-id url up? changed? last-up error last-error ;
site new
swap >>url ;
+: site-with-url ( url -- site )
+ <site> select-tuple ;
+
+: site-with-id ( id -- site )
+ site new swap >>site-id select-tuple ;
+
site "SITE" {
{ "site-id" "SITE_ID" INTEGER +db-assigned-id+ }
{ "url" "URL" VARCHAR }
@@ -47,9 +53,41 @@ watching-site "WATCHING_SITE" {
{ "site-id" "SITE_ID" INTEGER +user-assigned-id+ }
} define-persistent
-TUPLE: reporting-site email url up? changed? last-up? error last-error ;
+TUPLE: spidering-site < watching-site max-depth max-count ;
-<PRIVATE
+C: <spidering-site> spidering-site
+
+SLOT: site
+
+M: watching-site site>>
+ site-id>> site-with-id ;
+
+SLOT: account
+
+M: watching-site account>>
+ account-name>> account new swap >>account-name select-tuple ;
+
+spidering-site "SPIDERING_SITE" {
+ { "max-depth" "MAX_DEPTH" INTEGER }
+ { "max-count" "MAX_COUNT" INTEGER }
+} define-persistent
+
+: spidering-sites ( username -- sites )
+ spidering-site new swap >>account-name select-tuples ;
+
+: insert-site ( url -- site )
+ <site> dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ;
+
+: select-account/site ( username url -- account site )
+ insert-site site-id>> ;
+
+: add-spidered-site ( username url -- )
+ select-account/site 10 10 <spidering-site> insert-tuple ;
+
+: remove-spidered-site ( username url -- )
+ select-account/site 10 10 <spidering-site> delete-tuples ;
+
+TUPLE: reporting-site site-id email url up? changed? last-up? error last-error ;
: set-notify-site-watchers ( site new-up? -- site )
[ over up?>> = [ t >>changed? ] unless ] keep >>up? ;
@@ -72,18 +110,10 @@ TUPLE: reporting-site email url up? changed? last-up? error last-error ;
[ [ reporting-site boa ] input<sequence ] map
"update site set changed = 0;" sql-command ;
-: insert-site ( url -- site )
- <site> dup select-tuple [ ] [ dup t >>up? insert-tuple ] ?if ;
-
: insert-account ( account-name email -- ) <account> insert-tuple ;
: find-sites ( -- seq ) f <site> select-tuples ;
-: select-account/site ( username url -- account site )
- insert-site site-id>> ;
-
-PRIVATE>
-
: watch-site ( username url -- )
select-account/site <watching-site> insert-tuple ;
diff --git a/extra/site-watcher/email/authors.txt b/extra/site-watcher/email/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/site-watcher/email/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/site-watcher/email/email.factor b/extra/site-watcher/email/email.factor
new file mode 100644
index 0000000000..d028788e26
--- /dev/null
+++ b/extra/site-watcher/email/email.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: smtp namespaces accessors kernel arrays ;
+IN: site-watcher.email
+
+SYMBOL: site-watcher-from
+site-watcher-from [ "factor-site-watcher@gmail.com" ] initialize
+
+: send-site-email ( watching-site body subject -- )
+ [ account>> email>> ] 2dip
+ pick [
+ [ <email> site-watcher-from get >>from ] 3dip
+ [ 1array >>to ] [ >>body ] [ >>subject ] tri* send-email
+ ] [ 3drop ] if ;
\ No newline at end of file
diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor
index b067504e2e..e58d5a79d5 100644
--- a/extra/site-watcher/site-watcher-tests.factor
+++ b/extra/site-watcher/site-watcher-tests.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: db.tuples locals site-watcher site-watcher.db
site-watcher.private kernel db io.directories io.files.temp
-continuations site-watcher.db.private db.sqlite
+continuations db.sqlite
sequences tools.test ;
IN: site-watcher.tests
diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor
index 114cdf3259..535c8cd626 100644
--- a/extra/site-watcher/site-watcher.factor
+++ b/extra/site-watcher/site-watcher.factor
@@ -3,13 +3,9 @@
USING: accessors alarms arrays calendar combinators
combinators.smart continuations debugger http.client fry
init io.streams.string kernel locals math math.parser db
-namespaces sequences site-watcher.db site-watcher.db.private
-smtp ;
+namespaces sequences site-watcher.db site-watcher.email ;
IN: site-watcher
-SYMBOL: site-watcher-from
-"factor-site-watcher@gmail.com" site-watcher-from set-global
-
SYMBOL: site-watcher-frequency
5 minutes site-watcher-frequency set-global
@@ -23,34 +19,31 @@ SYMBOL: running-site-watcher
[ dup url>> http-get 2drop site-good ] [ site-bad ] recover
] each ;
-: site-up-email ( email site -- email )
+: site-up-email ( site -- body )
last-up>> now swap time- duration>minutes 60 /mod
[ >integer number>string ] bi@
[ " hours, " append ] [ " minutes" append ] bi* append
- "Site was down for (at least): " prepend >>body ;
+ "Site was down for (at least): " prepend ;
-: site-down-email ( email site -- email ) error>> >>body ;
+: site-down-email ( site -- body ) error>> ;
: send-report ( site -- )
- [ <email> ] dip
- {
- [ email>> 1array >>to ]
- [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ]
- [ dup up?>> [ site-up-email ] [ site-down-email ] if ]
- [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ]
- } cleave send-email ;
+ [ ]
+ [ dup up?>> [ site-up-email ] [ site-down-email ] if ]
+ [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue ] tri
+ send-site-email ;
: send-reports ( seq -- )
[ ] [ [ send-report ] each ] if-empty ;
PRIVATE>
-: watch-sites ( db -- )
- [ find-sites check-sites sites-to-report send-reports ] with-db ;
+: watch-sites ( -- )
+ find-sites check-sites sites-to-report send-reports ;
: run-site-watcher ( db -- )
[ running-site-watcher get ] dip '[
- [ _ watch-sites ] site-watcher-frequency get every
+ [ _ [ watch-sites ] with-db ] site-watcher-frequency get every
running-site-watcher set
] unless ;
diff --git a/extra/site-watcher/spider/authors.txt b/extra/site-watcher/spider/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/site-watcher/spider/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/site-watcher/spider/spider.factor b/extra/site-watcher/spider/spider.factor
new file mode 100644
index 0000000000..335f1f11f9
--- /dev/null
+++ b/extra/site-watcher/spider/spider.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: site-watcher.db site-watcher.email site-watcher.spider
+spider spider.report
+accessors kernel sequences
+xml.writer concurrency.combinators ;
+IN: site-watcher.spider
+
+: <site-spider> ( spidering-site -- spider )
+ [ max-depth>> ]
+ [ max-count>> ]
+ [ site>> url>> ]
+ tri
+ <spider>
+ swap >>max-count
+ swap >>max-depth ;
+
+: spider-and-email ( spidering-site -- )
+ [ ]
+ [ <site-spider> run-spider spider-report xml>string ]
+ [ site>> url>> "Spidered " prefix ] tri
+ send-site-email ;
+
+: spider-sites ( -- )
+ f spidering-sites [ spider-and-email ] parallel-each ;
\ No newline at end of file
diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor
index fa666dd776..710c953ed1 100755
--- a/extra/spheres/spheres.factor
+++ b/extra/spheres/spheres.factor
@@ -1,7 +1,8 @@
USING: kernel opengl opengl.demo-support opengl.gl opengl.textures
opengl.shaders opengl.framebuffers opengl.capabilities multiline
ui.gadgets accessors sequences ui.render ui math locals arrays
-generalizations combinators ui.gadgets.worlds ;
+generalizations combinators ui.gadgets.worlds
+literals ui.pixel-formats ;
IN: spheres
STRING: plane-vertex-shader
@@ -110,19 +111,16 @@ main()
}
;
-TUPLE: spheres-gadget < demo-gadget
+TUPLE: spheres-world < demo-world
plane-program solid-sphere-program texture-sphere-program
reflection-framebuffer reflection-depthbuffer
- reflection-texture initialized? ;
+ reflection-texture ;
-: <spheres-gadget> ( -- gadget )
- 20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
-
-M: spheres-gadget near-plane ( gadget -- z )
+M: spheres-world near-plane ( gadget -- z )
drop 1.0 ;
-M: spheres-gadget far-plane ( gadget -- z )
+M: spheres-world far-plane ( gadget -- z )
drop 512.0 ;
-M: spheres-gadget distance-step ( gadget -- dz )
+M: spheres-world distance-step ( gadget -- dz )
drop 0.5 ;
: (reflection-dim) ( -- w h )
@@ -136,12 +134,14 @@ M: spheres-gadget distance-step ( gadget -- dz )
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri
- GL_TEXTURE_CUBE_MAP_POSITIVE_X
- GL_TEXTURE_CUBE_MAP_POSITIVE_Y
- GL_TEXTURE_CUBE_MAP_POSITIVE_Z
- GL_TEXTURE_CUBE_MAP_NEGATIVE_X
- GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
- GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray
+ ${
+ GL_TEXTURE_CUBE_MAP_POSITIVE_X
+ GL_TEXTURE_CUBE_MAP_POSITIVE_Y
+ GL_TEXTURE_CUBE_MAP_POSITIVE_Z
+ GL_TEXTURE_CUBE_MAP_NEGATIVE_X
+ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
+ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
+ }
[ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ]
each
] keep ;
@@ -171,22 +171,19 @@ M: spheres-gadget distance-step ( gadget -- dz )
sphere-main-fragment-shader <fragment-shader> check-gl-shader
3array <gl-program> check-gl-program ;
-M: spheres-gadget graft* ( gadget -- )
- dup find-gl-context
+M: spheres-world begin-world
"2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
{ "GL_EXT_framebuffer_object" } require-gl-extensions
+ 20.0 10.0 20.0 set-demo-orientation
(plane-program) >>plane-program
(solid-sphere-program) >>solid-sphere-program
(texture-sphere-program) >>texture-sphere-program
(make-reflection-texture) >>reflection-texture
(make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep
(make-reflection-framebuffer) >>reflection-framebuffer
- t >>initialized?
drop ;
-M: spheres-gadget ungraft* ( gadget -- )
- f >>initialized?
- dup find-gl-context
+M: spheres-world end-world
{
[ reflection-framebuffer>> [ delete-framebuffer ] when* ]
[ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
@@ -196,7 +193,7 @@ M: spheres-gadget ungraft* ( gadget -- )
[ plane-program>> [ delete-gl-program ] when* ]
} cleave ;
-M: spheres-gadget pref-dim* ( gadget -- dim )
+M: spheres-world pref-dim* ( gadget -- dim )
drop { 640 480 } ;
:: (draw-sphere) ( program center radius -- )
@@ -254,7 +251,7 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
[ drop 0 0 (reflection-dim) glViewport ]
[
GL_PROJECTION glMatrixMode
- glLoadIdentity
+ glPushMatrix glLoadIdentity
reflection-frustum glFrustum
GL_MODELVIEW glMatrixMode
glLoadIdentity
@@ -277,15 +274,19 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
[ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face)
glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ]
[ sphere-scene ]
- [ dim>> 0 0 rot first2 glViewport ]
+ [
+ [ 0 0 ] dip dim>> first2 glViewport
+ GL_PROJECTION glMatrixMode
+ glPopMatrix
+ ]
} cleave ] with-framebuffer ;
-: (draw-gadget) ( gadget -- )
+M: spheres-world draw-world*
GL_DEPTH_TEST glEnable
GL_SCISSOR_TEST glDisable
0.15 0.15 1.0 1.0 glClearColor {
[ (draw-reflection-texture) ]
- [ demo-gadget-set-matrices ]
+ [ demo-world-set-matrix ]
[ sphere-scene ]
[ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
[
@@ -297,10 +298,17 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
]
} cleave ;
-M: spheres-gadget draw-gadget* ( gadget -- )
- dup initialized?>> [ (draw-gadget) ] [ drop ] if ;
-
: spheres-window ( -- )
- [ <spheres-gadget> "Spheres" open-window ] with-ui ;
+ [
+ f T{ world-attributes
+ { world-class spheres-world }
+ { title "Spheres" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 16 } }
+ } }
+ } open-window
+ ] with-ui ;
MAIN: spheres-window
diff --git a/extra/spider/report/report.factor b/extra/spider/report/report.factor
index 43952701d5..7779b233f9 100644
--- a/extra/spider/report/report.factor
+++ b/extra/spider/report/report.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators kernel math
math.statistics namespaces sequences sorting xml.syntax
-spider ;
+spider urls html ;
IN: spider.report
SYMBOL: network-failures
@@ -39,10 +39,11 @@ SYMBOL: time-std
timings get sort-values
[ slowest short tail* reverse slowest-pages set ]
[
- values
- [ mean 1000000 /f mean-time set ]
- [ median 1000000 /f median-time set ]
- [ std 1000000 /f time-std set ] tri
+ values [
+ [ mean 1000000 /f mean-time set ]
+ [ median 1000000 /f median-time set ]
+ [ std 1000000 /f time-std set ] tri
+ ] unless-empty
] bi ;
: process-results ( results -- )
@@ -87,27 +88,37 @@ SYMBOL: time-std
slowest-pages-table
timing-summary-table
[XML
- <h2>Slowest pages</h2>
+ <h3>Slowest pages</h3>
<->
- <h2>Summary</h2>
+ <h3>Summary</h3>
<->
XML] ;
: generate-report ( -- html )
+ url get dup
report-broken-pages
report-network-failures
report-timings
[XML
- <h1>Broken pages</h1>
+ <h1>Spider report</h1>
+ URL: <a href=<->><-></a>
+
+ <h2>Broken pages</h2>
<->
- <h1>Network failures</h1>
+ <h2>Network failures</h2>
<->
- <h1>Load times</h1>
+ <h2>Load times</h2>
<->
XML] ;
: spider-report ( spider -- html )
- [ spidered>> process-results generate-report ] with-scope ;
+ [ "Spider report" f ] dip
+ [
+ [ base>> url set ]
+ [ spidered>> process-results ] bi
+ generate-report
+ ] with-scope
+ simple-page ;
diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index 49d6c33f8f..17e91473c3 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -5,12 +5,12 @@ http.client kernel tools.time sets assocs sequences
concurrency.combinators io threads namespaces math multiline
math.parser inspector urls logging combinators.short-circuit
continuations calendar prettyprint dlists deques locals
-spider.unique-deque ;
+spider.unique-deque combinators concurrency.semaphores ;
IN: spider
TUPLE: spider base count max-count sleep max-depth initial-links
filters spidered todo nonmatching quiet currently-spidering
-#threads follow-robots? robots ;
+#threads semaphore follow-robots? robots ;
TUPLE: spider-result url depth headers
fetched-in parsed-html links processed-in fetched-at ;
@@ -26,7 +26,12 @@ fetched-in parsed-html links processed-in fetched-at ;
0 >>count
1/0. >>max-count
H{ } clone >>spidered
- 1 >>#threads ;
+ 1 [ >>#threads ] [ <semaphore> >>semaphore ] bi ;
+
+: <spider-result> ( url depth -- spider-result )
+ spider-result new
+ swap >>depth
+ swap >>url ;
<PRIVATE
@@ -57,26 +62,32 @@ fetched-in parsed-html links processed-in fetched-at ;
: normalize-hrefs ( base links -- links' )
[ derive-url ] with map ;
-: print-spidering ( url depth -- )
+: print-spidering ( spider-result -- )
+ [ url>> ] [ depth>> ] bi
"depth: " write number>string write
", spidering: " write . yield ;
-:: new-spidered-result ( spider url depth -- spider-result )
- f url spider spidered>> set-at
- [ url http-get ] benchmark :> fetched-at :> html :> headers
+:: fill-spidered-result ( spider spider-result -- )
+ f spider-result url>> spider spidered>> set-at
+ [ spider-result url>> http-get ] benchmark :> fetched-in :> html :> headers
[
html parse-html
spider currently-spidering>>
over find-all-links normalize-hrefs
- ] benchmark :> processing-time :> links :> parsed-html
- url depth headers fetched-at parsed-html links processing-time
- now spider-result boa ;
+ ] benchmark :> processed-in :> links :> parsed-html
+ spider-result
+ headers >>headers
+ fetched-in >>fetched-in
+ parsed-html >>parsed-html
+ links >>links
+ processed-in >>processed-in
+ now >>fetched-at drop ;
-:: spider-page ( spider url depth -- )
- spider quiet>> [ url depth print-spidering ] unless
- spider url depth new-spidered-result :> spidered-result
- spider quiet>> [ spidered-result describe ] unless
- spider spidered-result add-spidered ;
+:: spider-page ( spider spider-result -- )
+ spider quiet>> [ spider-result print-spidering ] unless
+ spider spider-result fill-spidered-result
+ spider quiet>> [ spider-result describe ] unless
+ spider spider-result add-spidered ;
\ spider-page ERROR add-error-logging
@@ -94,9 +105,9 @@ fetched-in parsed-html links processed-in fetched-at ;
[ [ count>> ] [ max-count>> ] bi < ]
} 1&& ;
-: setup-next-url ( spider -- spider url depth )
+: setup-next-url ( spider -- spider spider-result )
dup todo>> peek-url url>> >>currently-spidering
- dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
+ dup todo>> pop-url [ url>> ] [ depth>> ] bi <spider-result> ;
: spider-next-page ( spider -- )
setup-next-url spider-page ;
diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor
index ad46abdad3..b26797f8d5 100644
--- a/extra/spider/unique-deque/unique-deque.factor
+++ b/extra/spider/unique-deque/unique-deque.factor
@@ -29,3 +29,9 @@ TUPLE: unique-deque assoc deque ;
: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+
+: slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
+ pick deque-empty? [ 3drop ] [
+ [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
+ [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
+ ] if ; inline recursive
diff --git a/extra/str-fry/authors.txt b/extra/str-fry/authors.txt
new file mode 100644
index 0000000000..ce0899f16e
--- /dev/null
+++ b/extra/str-fry/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
\ No newline at end of file
diff --git a/extra/str-fry/str-fry.factor b/extra/str-fry/str-fry.factor
new file mode 100644
index 0000000000..bfe74f37eb
--- /dev/null
+++ b/extra/str-fry/str-fry.factor
@@ -0,0 +1,7 @@
+USING: combinators effects kernel math sequences splitting
+strings.parser ;
+IN: str-fry
+: str-fry ( str -- quot ) "_" split
+ [ unclip [ [ rot glue ] reduce ] 2curry ]
+ [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
+SYNTAX: I" parse-string rest str-fry over push-all ;
\ No newline at end of file
diff --git a/extra/str-fry/summary.txt b/extra/str-fry/summary.txt
new file mode 100644
index 0000000000..7755f5ae9a
--- /dev/null
+++ b/extra/str-fry/summary.txt
@@ -0,0 +1 @@
+String Frying
\ No newline at end of file
diff --git a/extra/synth/authors.txt b/extra/synth/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/synth/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/extra/synth/buffers/authors.txt b/extra/synth/buffers/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/synth/buffers/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/unmaintained/synth/buffers/buffers.factor b/extra/synth/buffers/buffers.factor
similarity index 89%
rename from unmaintained/synth/buffers/buffers.factor
rename to extra/synth/buffers/buffers.factor
index b0128ca52a..4c0ef64607 100644
--- a/unmaintained/synth/buffers/buffers.factor
+++ b/extra/synth/buffers/buffers.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged ;
+USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged specialized-arrays.uchar specialized-arrays.short ;
IN: synth.buffers
TUPLE: buffer sample-freq 8bit? id ;
@@ -57,11 +57,11 @@ M: 8bit-stereo-buffer buffer-data
M: 16bit-stereo-buffer buffer-data
interleaved-stereo-data 16bit-buffer-data ;
-: telephone-sample-freq 8000 ;
-: half-sample-freq 22050 ;
-: cd-sample-freq 44100 ;
-: digital-sample-freq 48000 ;
-: professional-sample-freq 88200 ;
+CONSTANT: telephone-sample-freq 8000
+CONSTANT: half-sample-freq 22050
+CONSTANT: cd-sample-freq 44100
+CONSTANT: digital-sample-freq 48000
+CONSTANT: professional-sample-freq 88200
: send-buffer ( buffer -- buffer )
{
diff --git a/extra/synth/example/authors.txt b/extra/synth/example/authors.txt
new file mode 100644
index 0000000000..e9c193bac7
--- /dev/null
+++ b/extra/synth/example/authors.txt
@@ -0,0 +1 @@
+Alex Chapman
diff --git a/unmaintained/synth/example/example.factor b/extra/synth/example/example.factor
similarity index 100%
rename from unmaintained/synth/example/example.factor
rename to extra/synth/example/example.factor
diff --git a/unmaintained/synth/summary.txt b/extra/synth/summary.txt
similarity index 100%
rename from unmaintained/synth/summary.txt
rename to extra/synth/summary.txt
diff --git a/unmaintained/synth/synth.factor b/extra/synth/synth.factor
similarity index 100%
rename from unmaintained/synth/synth.factor
rename to extra/synth/synth.factor
diff --git a/extra/system-info/windows/nt/nt.factor b/extra/system-info/windows/nt/nt.factor
index 7f71e08e83..5be2dc89e2 100755
--- a/extra/system-info/windows/nt/nt.factor
+++ b/extra/system-info/windows/nt/nt.factor
@@ -3,7 +3,7 @@
USING: alien alien.c-types alien.strings
kernel libc math namespaces system-info.backend
system-info.windows windows windows.advapi32
-windows.kernel32 system byte-arrays ;
+windows.kernel32 system byte-arrays windows.errors ;
IN: system-info.windows.nt
M: winnt cpus ( -- n )
@@ -41,6 +41,6 @@ M: winnt available-virtual-mem ( -- n )
GetComputerName win32-error=0/f alien>native-string ;
: username ( -- string )
- UNLEN 1+
+ UNLEN 1 +
[ <byte-array> dup ] keep <uint>
GetUserName win32-error=0/f alien>native-string ;
diff --git a/extra/system-info/windows/windows.factor b/extra/system-info/windows/windows.factor
index 66abb59ee9..4d23430131 100755
--- a/extra/system-info/windows/windows.factor
+++ b/extra/system-info/windows/windows.factor
@@ -3,7 +3,7 @@
USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32
words combinators vocabs.loader system-info.backend
-system alien.strings ;
+system alien.strings windows.errors ;
IN: system-info.windows
: system-info ( -- SYSTEM_INFO )
diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
index 37c022fe43..e281871252 100755
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -1,8 +1,10 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.files io.files.links io.directories
io.pathnames io.streams.string kernel math math.parser
continuations namespaces pack prettyprint sequences strings
system tools.hexdump io.encodings.binary summary accessors
-io.backend byte-arrays ;
+io.backend byte-arrays io.streams.byte-array splitting ;
IN: tar
CONSTANT: zero-checksum 256
@@ -10,37 +12,35 @@ CONSTANT: block-size 512
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-ERROR: checksum-error ;
-SYMBOLS: base-dir filename ;
+ERROR: checksum-error header ;
-: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
+: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
-: read-c-string* ( n -- str/f )
+: read-c-string ( n -- str/f )
read [ zero? ] trim-tail [ f ] when-empty ;
: read-tar-header ( -- obj )
\ tar-header new
- 100 read-c-string* >>name
- 8 read-c-string* tar-trim oct> >>mode
- 8 read-c-string* tar-trim oct> >>uid
- 8 read-c-string* tar-trim oct> >>gid
- 12 read-c-string* tar-trim oct> >>size
- 12 read-c-string* tar-trim oct> >>mtime
- 8 read-c-string* tar-trim oct> >>checksum
- read1 >>typeflag
- 100 read-c-string* >>linkname
- 6 read >>magic
- 2 read >>version
- 32 read-c-string* >>uname
- 32 read-c-string* >>gname
- 8 read tar-trim oct> >>devmajor
- 8 read tar-trim oct> >>devminor
- 155 read-c-string* >>prefix ;
+ 100 read-c-string >>name
+ 8 read-c-string trim-string oct> >>mode
+ 8 read-c-string trim-string oct> >>uid
+ 8 read-c-string trim-string oct> >>gid
+ 12 read-c-string trim-string oct> >>size
+ 12 read-c-string trim-string oct> >>mtime
+ 8 read-c-string trim-string oct> >>checksum
+ read1 >>typeflag
+ 100 read-c-string >>linkname
+ 6 read >>magic
+ 2 read >>version
+ 32 read-c-string >>uname
+ 32 read-c-string >>gname
+ 8 read trim-string oct> >>devmajor
+ 8 read trim-string oct> >>devminor
+ 155 read-c-string >>prefix ;
-: header-checksum ( seq -- x )
- 148 cut-slice 8 tail-slice
- [ sum ] bi@ + 256 + ;
+: checksum-header ( seq -- n )
+ 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
: read-data-blocks ( tar-header -- )
dup size>> 0 > [
@@ -60,32 +60,40 @@ SYMBOLS: base-dir filename ;
] if ;
: parse-tar-header ( seq -- obj )
- [ header-checksum ] keep over zero-checksum = [
+ dup checksum-header dup zero-checksum = [
2drop
\ tar-header new
0 >>size
0 >>checksum
] [
- [ read-tar-header ] with-string-reader
- [ checksum>> = [ checksum-error ] unless ] keep
+ [
+ binary [ read-tar-header ] with-byte-reader
+ dup checksum>>
+ ] dip = [ checksum-error ] unless
] if ;
ERROR: unknown-typeflag ch ;
-M: unknown-typeflag summary ( obj -- str )
- ch>> 1string "Unknown typeflag: " prepend ;
-: tar-prepend-path ( path -- newpath )
- base-dir get prepend-path ;
+M: unknown-typeflag summary ( obj -- str )
+ ch>> [ "Unknown typeflag: " ] dip prefix ;
: read/write-blocks ( tar-header path -- )
binary [ read-data-blocks ] with-file-writer ;
+: prepend-current-directory ( path -- path' )
+ current-directory get prepend-path ;
+
! Normal file
: typeflag-0 ( header -- )
- dup name>> tar-prepend-path read/write-blocks ;
+ dup name>> dup "global_pax_header" = [
+ drop [ read-data-blocks ] with-string-writer drop
+ ] [
+ prepend-current-directory read/write-blocks
+ ] if ;
! Hard link
-: typeflag-1 ( header -- ) unknown-typeflag ;
+: typeflag-1 ( header -- )
+ [ name>> ] [ linkname>> ] bi make-hard-link ;
! Symlink
: typeflag-2 ( header -- )
@@ -99,7 +107,7 @@ M: unknown-typeflag summary ( obj -- str )
! Directory
: typeflag-5 ( header -- )
- name>> tar-prepend-path make-directories ;
+ name>> prepend-current-directory make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
@@ -136,10 +144,11 @@ M: unknown-typeflag summary ( obj -- str )
! Long file name
: typeflag-L ( header -- )
- drop ;
+ drop
+ ;
! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] trim-tail filename set
- ! filename get tar-prepend-path make-directories ;
+ ! filename get prepend-current-directory make-directories ;
! Multi volume continuation entry
: typeflag-M ( header -- ) unknown-typeflag ;
@@ -156,8 +165,8 @@ M: unknown-typeflag summary ( obj -- str )
! Vendor extended header type
: typeflag-X ( header -- ) unknown-typeflag ;
-: (parse-tar) ( -- )
- block-size read dup length 512 = [
+: parse-tar ( -- )
+ block-size read dup length block-size = [
parse-tar-header
dup typeflag>>
{
@@ -177,19 +186,19 @@ M: unknown-typeflag summary ( obj -- str )
! { CHAR: E [ typeflag-E ] }
! { CHAR: I [ typeflag-I ] }
! { CHAR: K [ typeflag-K ] }
- ! { CHAR: L [ typeflag-L ] }
+ { CHAR: L [ typeflag-L ] }
! { CHAR: M [ typeflag-M ] }
! { CHAR: N [ typeflag-N ] }
! { CHAR: S [ typeflag-S ] }
! { CHAR: V [ typeflag-V ] }
! { CHAR: X [ typeflag-X ] }
{ f [ drop ] }
- } case (parse-tar)
+ } case parse-tar
] [
drop
] if ;
-: parse-tar ( path -- )
- normalize-path dup parent-directory base-dir [
- binary [ (parse-tar) ] with-file-reader
- ] with-variable ;
+: untar ( path -- )
+ normalize-path dup parent-directory [
+ binary [ parse-tar ] with-file-reader
+ ] with-directory ;
diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor
index d1f398994e..0169249e81 100644
--- a/extra/tetris/gl/gl.factor
+++ b/extra/tetris/gl/gl.factor
@@ -37,7 +37,7 @@ IN: tetris.gl
: draw-tetris ( width height tetris -- )
#! width and height are in pixels
- GL_MODELVIEW [
+ [
{
[ board>> scale-board ]
[ board>> draw-board ]
diff --git a/extra/ui/frp/authors.txt b/extra/ui/frp/authors.txt
new file mode 100644
index 0000000000..2300f69f11
--- /dev/null
+++ b/extra/ui/frp/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor
new file mode 100644
index 0000000000..479a56e513
--- /dev/null
+++ b/extra/ui/frp/frp-docs.factor
@@ -0,0 +1,46 @@
+USING: help.markup help.syntax models monads sequences
+ui.gadgets.buttons ui.gadgets.tracks ;
+IN: ui.frp
+
+! Layout utilities
+
+HELP: ,
+{ $values { "uiitem" "a gadget or model" } }
+{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
+HELP: ->
+{ $values { "uiitem" "a gadget or model" } { "model" model } }
+{ $description "Like " { $link , } "but passes its model on for further use." } ;
+HELP: <hbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
+HELP: <vbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
+
+! Gadgets
+HELP: <frp-button>
+{ $values { "text" "the button's label" } { "button" button } }
+{ $description "Creates an button whose model updates on clicks" } ;
+
+HELP: <merge>
+{ $values { "models" "a list of models" } { "model" merge-model } }
+{ $description "Creates a model that merges the updates of others" } ;
+
+HELP: <filter>
+{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
+{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
+
+HELP: <fold>
+{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
+{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
+
+HELP: <switch>
+{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
+{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
+
+ARTICLE: { "frp" "instances" } "FRP Instances"
+"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
+"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
+
diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor
new file mode 100644
index 0000000000..699d034c72
--- /dev/null
+++ b/extra/ui/frp/frp.factor
@@ -0,0 +1,104 @@
+USING: accessors arrays colors fonts kernel models
+models.product monads sequences ui.gadgets ui.gadgets.buttons
+ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
+ui.gadgets.tracks ui.render ui.gadgets.scrollers ;
+QUALIFIED: make
+IN: ui.frp
+
+! Gadgets
+: <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <model> >>model ;
+TUPLE: frp-table < table quot val-quot color-quot column-titles column-alignment ;
+M: frp-table column-titles column-titles>> ;
+M: frp-table column-alignment column-alignment>> ;
+M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+
+: <frp-table> ( model -- table )
+ frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
+ f <model> >>selected-value sans-serif-font >>font
+ focus-border-color >>focus-border-color
+ transparent >>column-line-color [ ] >>val-quot ;
+: <frp-table*> ( -- table ) f <model> <frp-table> ;
+: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
+: <frp-list*> ( -- table ) f <model> <frp-list> ;
+
+: <frp-field> ( -- field ) f <model> <model-field> ;
+
+! Layout utilities
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: frp-table output-model selected-value>> ;
+M: model-field output-model field-model>> ;
+M: scroller output-model children>> first model>> ;
+
+GENERIC: , ( uiitem -- )
+M: gadget , make:, ;
+M: model , activate-model ;
+
+GENERIC: -> ( uiitem -- model )
+M: gadget -> dup make:, output-model ;
+M: model -> dup , ;
+M: table -> dup , selected-value>> ;
+
+: <box> ( gadgets type -- track )
+ [ { } make:make ] dip <track> swap [ f track-add ] each ; inline
+: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
+: <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
+: <vbox> ( gadgets -- track ) vertical <box> ; inline
+: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
+
+! !!! Model utilities
+TUPLE: multi-model < model ;
+: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
+
+! Events- discrete model utilities
+
+TUPLE: merge-model < multi-model ;
+M: merge-model model-changed [ value>> ] dip set-model ;
+: <merge> ( models -- model ) merge-model <multi-model> ;
+
+TUPLE: filter-model < multi-model quot ;
+M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2keep
+ [ set-model ] [ 2drop ] if ;
+: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
+
+! Behaviors - continuous model utilities
+
+TUPLE: fold-model < multi-model oldval quot ;
+M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
+ call( val oldval -- newval ) ] keep set-model ;
+: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
+ swap [ >>oldval ] [ >>value ] bi ;
+
+TUPLE: switch-model < multi-model original switcher on ;
+M: switch-model model-changed 2dup switcher>> =
+ [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ]
+ [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
+ [ >>original ] [ >>switcher ] bi* ;
+
+TUPLE: mapped < model model quot ;
+
+: <mapped> ( model quot -- arrow )
+ f mapped new-model
+ swap >>quot
+ over >>model
+ [ add-dependency ] keep ;
+
+M: mapped model-changed
+ [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
+ set-model ;
+
+! Instances
+M: model fmap <mapped> ;
+
+SINGLETON: gadget-monad
+INSTANCE: gadget-monad monad
+INSTANCE: gadget monad
+M: gadget monad-of drop gadget-monad ;
+M: gadget-monad return drop <gadget> swap >>model ;
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
\ No newline at end of file
diff --git a/extra/ui/frp/summary.txt b/extra/ui/frp/summary.txt
new file mode 100644
index 0000000000..3b49d34fa8
--- /dev/null
+++ b/extra/ui/frp/summary.txt
@@ -0,0 +1 @@
+Utilities for functional reactive programming in user interfaces
diff --git a/extra/ui/gadgets/alerts/alerts.factor b/extra/ui/gadgets/alerts/alerts.factor
index 04c6b013df..03d60957fa 100644
--- a/extra/ui/gadgets/alerts/alerts.factor
+++ b/extra/ui/gadgets/alerts/alerts.factor
@@ -1,4 +1,4 @@
-USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences io.styles ;
+USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ;
IN: ui.gadgets.alerts
-:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> { "sans-serif" plain 18 } >>font { 200 100 } >>pref-dim add-gadget
+:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align string <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
"okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
\ No newline at end of file
diff --git a/extra/ui/gadgets/alerts/authors.txt b/extra/ui/gadgets/alerts/authors.txt
new file mode 100644
index 0000000000..ce0899f16e
--- /dev/null
+++ b/extra/ui/gadgets/alerts/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
\ No newline at end of file
diff --git a/extra/ui/gadgets/alerts/summary.txt b/extra/ui/gadgets/alerts/summary.txt
new file mode 100644
index 0000000000..f1cd4205d7
--- /dev/null
+++ b/extra/ui/gadgets/alerts/summary.txt
@@ -0,0 +1 @@
+Really simple dialog boxes
\ No newline at end of file
diff --git a/extra/ui/gadgets/book-extras/authors.txt b/extra/ui/gadgets/book-extras/authors.txt
new file mode 100644
index 0000000000..ce0899f16e
--- /dev/null
+++ b/extra/ui/gadgets/book-extras/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
\ No newline at end of file
diff --git a/extra/ui/gadgets/book-extras/summary.txt b/extra/ui/gadgets/book-extras/summary.txt
new file mode 100644
index 0000000000..5a221abffe
--- /dev/null
+++ b/extra/ui/gadgets/book-extras/summary.txt
@@ -0,0 +1 @@
+Easily switch between pages of book views
\ No newline at end of file
diff --git a/extra/ui/gadgets/comboboxes/authors.txt b/extra/ui/gadgets/comboboxes/authors.txt
new file mode 100644
index 0000000000..ce0899f16e
--- /dev/null
+++ b/extra/ui/gadgets/comboboxes/authors.txt
@@ -0,0 +1 @@
+Sam Anklesaria
\ No newline at end of file
diff --git a/extra/ui/gadgets/comboboxes/comboboxes.factor b/extra/ui/gadgets/comboboxes/comboboxes.factor
new file mode 100644
index 0000000000..b0dbe34d16
--- /dev/null
+++ b/extra/ui/gadgets/comboboxes/comboboxes.factor
@@ -0,0 +1,22 @@
+USING: accessors arrays kernel math.rectangles models sequences
+ui.frp ui.gadgets ui.gadgets.glass ui.gadgets.labels
+ui.gadgets.tables ui.gestures ;
+IN: ui.gadgets.comboboxes
+
+TUPLE: combo-table < table spawner ;
+
+M: combo-table handle-gesture [ call-next-method ] 2keep swap
+ T{ button-up } = [
+ [ spawner>> ]
+ [ selected-value>> value>> [ swap set-control-value ] [ drop ] if* ]
+ [ hide-glass ] tri drop t
+ ] [ drop ] if ;
+
+TUPLE: combobox < label-control table ;
+combobox H{
+ { T{ button-down } [ dup table>> over >>spawner <zero-rect> show-glass ] }
+} set-gestures
+
+: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <model> >>model ] keep
+ [ 1array ] map <model> trivial-renderer combo-table new-table
+ >>table ;
\ No newline at end of file
diff --git a/extra/ui/gadgets/comboboxes/summary.txt b/extra/ui/gadgets/comboboxes/summary.txt
new file mode 100644
index 0000000000..0f2ce2b671
--- /dev/null
+++ b/extra/ui/gadgets/comboboxes/summary.txt
@@ -0,0 +1 @@
+Combo boxes have a model choosen from a list of options
\ No newline at end of file
diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor
index aa98793c70..5ff5bb3879 100644
--- a/extra/ui/gadgets/lists/lists.factor
+++ b/extra/ui/gadgets/lists/lists.factor
@@ -90,7 +90,7 @@ M: list focusable-child* drop t ;
: invoke-value-action ( list -- )
dup list-empty? [
- dup hook>> call
+ dup hook>> call( list -- )
] [
[ index>> ] keep nth-gadget invoke-secondary
] if ;
diff --git a/extra/update/util/util.factor b/extra/update/util/util.factor
index beeddc7abb..77cd916139 100644
--- a/extra/update/util/util.factor
+++ b/extra/update/util/util.factor
@@ -20,8 +20,8 @@ DEFER: to-strings
dup class
{
{ \ string [ ] }
- { \ quotation [ call ] }
- { \ word [ execute ] }
+ { \ quotation [ call( -- string ) ] }
+ { \ word [ execute( -- string ) ] }
{ \ fixnum [ number>string ] }
{ \ array [ to-strings concat ] }
}
diff --git a/extra/vpri-talk/vpri-talk.factor b/extra/vpri-talk/vpri-talk.factor
index 1e5c9602b9..4ee499bf50 100644
--- a/extra/vpri-talk/vpri-talk.factor
+++ b/extra/vpri-talk/vpri-talk.factor
@@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: slides help.markup math arrays hashtables namespaces
sequences kernel sequences parser memoize io.encodings.binary
-locals kernel.private help.vocabs assocs quotations
-urls peg.ebnf tools.vocabs tools.annotations tools.crossref
-help.topics math.functions compiler.tree.optimizer
-compiler.cfg.optimizer fry ;
+locals kernel.private help.vocabs assocs quotations urls
+peg.ebnf tools.annotations tools.crossref help.topics
+math.functions compiler.tree.optimizer compiler.cfg.optimizer
+fry ;
IN: vpri-talk
CONSTANT: vpri-slides
diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor
index d62096fffc..2fa9b5fb1d 100644
--- a/extra/webapps/counter/counter.factor
+++ b/extra/webapps/counter/counter.factor
@@ -25,8 +25,8 @@ M: counter-app init-session* drop 0 count sset ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
- [ 1+ ] <counter-action> "inc" add-responder
- [ 1- ] <counter-action> "dec" add-responder
+ [ 1 + ] <counter-action> "inc" add-responder
+ [ 1 - ] <counter-action> "dec" add-responder
<display-action> "" add-responder ;
! Deployment example
diff --git a/extra/webapps/site-watcher/common/authors.txt b/extra/webapps/site-watcher/common/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/webapps/site-watcher/common/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/webapps/site-watcher/common/common.factor b/extra/webapps/site-watcher/common/common.factor
new file mode 100644
index 0000000000..b27cbf3f7f
--- /dev/null
+++ b/extra/webapps/site-watcher/common/common.factor
@@ -0,0 +1,6 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.server.dispatchers ;
+IN: webapps.site-watcher.common
+
+TUPLE: site-watcher-app < dispatcher ;
diff --git a/extra/webapps/site-watcher/common/main.xml b/extra/webapps/site-watcher/common/main.xml
new file mode 100644
index 0000000000..35a0ccb6d1
--- /dev/null
+++ b/extra/webapps/site-watcher/common/main.xml
@@ -0,0 +1,13 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<p>SiteWatcher is a free service for web masters. It periodically tries fetching your web site via HTTP, and sends you an e-mail, SMS or Tweet if this fails. <t:a t:href="$site-watcher-app/login">Sign up now!</t:a></p>
+
+<ul>
+ <li><t:a t:href="$site-watcher-app/update-notify">Your contact info</t:a></li>
+ <li><t:a t:href="$site-watcher-app/watch-list">Watched sites</t:a></li>
+ <li><t:a t:href="$site-watcher-app/spider-list">Spidered sites</t:a></li>
+</ul>
+
+</t:chloe>
diff --git a/extra/webapps/site-watcher/common/site-list.xml b/extra/webapps/site-watcher/common/site-list.xml
new file mode 100644
index 0000000000..765381a4c4
--- /dev/null
+++ b/extra/webapps/site-watcher/common/site-list.xml
@@ -0,0 +1,28 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<h1>Add some sites to watch</h1>
+
+<t:form t:action="$site-watcher-app/add-watch">
+<table>
+ <tr><th>URL:</th><td> <t:field t:name="url" t:size="80" /> <button type="submit">Done</button> </td></tr>
+</table>
+</t:form>
+
+<h1>Keep track of your sites</h1>
+
+<table border="2">
+ <tr> <th>URL</th><th></th> </tr>
+ <t:bind-each t:name="sites">
+ <tr>
+ <td> <t:label t:name="url" /> </td>
+ <td> <t:button t:action="$site-watcher-app/remove-watch" t:for="url">Remove</t:button> </td>
+ </tr>
+ </t:bind-each>
+</table>
+<p>
+ <t:button t:action="$site-watcher-app/check">Check now</t:button>
+</p>
+
+</t:chloe>
diff --git a/extra/webapps/site-watcher/site-watcher.xml b/extra/webapps/site-watcher/common/site-watcher.xml
similarity index 100%
rename from extra/webapps/site-watcher/site-watcher.xml
rename to extra/webapps/site-watcher/common/site-watcher.xml
diff --git a/extra/webapps/site-watcher/common/spider-list.xml b/extra/webapps/site-watcher/common/spider-list.xml
new file mode 100644
index 0000000000..89d191ab41
--- /dev/null
+++ b/extra/webapps/site-watcher/common/spider-list.xml
@@ -0,0 +1,28 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<h1>Add a site to spider</h1>
+
+<t:form t:action="$site-watcher-app/add-spider">
+<table>
+ <tr><th>URL:</th><td> <t:field t:name="url" t:size="80" /> <button type="submit">Done</button> </td></tr>
+</table>
+</t:form>
+
+<h1>Spidered sites</h1>
+
+<table border="2">
+ <tr> <th>URL</th><th></th> </tr>
+ <t:bind-each t:name="sites">
+ <tr>
+ <td> <t:label t:name="url" /> </td>
+ <td> <t:button t:action="$site-watcher-app/remove-spider" t:for="url">Remove</t:button> </td>
+ </tr>
+ </t:bind-each>
+</table>
+<p>
+ <t:button t:action="$site-watcher-app/spider">Spider now</t:button>
+</p>
+
+</t:chloe>
diff --git a/extra/webapps/site-watcher/update-notify.xml b/extra/webapps/site-watcher/common/update-notify.xml
similarity index 100%
rename from extra/webapps/site-watcher/update-notify.xml
rename to extra/webapps/site-watcher/common/update-notify.xml
diff --git a/extra/webapps/site-watcher/main.xml b/extra/webapps/site-watcher/main.xml
deleted file mode 100644
index 938ff09825..0000000000
--- a/extra/webapps/site-watcher/main.xml
+++ /dev/null
@@ -1,7 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<p>SiteWatcher is a free service for web masters. It periodically tries fetching your web site via HTTP, and sends you an e-mail, SMS or Tweet if this fails. <t:a t:href="$site-watcher-app/list">Sign up now!</t:a></p>
-
-</t:chloe>
diff --git a/extra/webapps/site-watcher/site-list.xml b/extra/webapps/site-watcher/site-list.xml
deleted file mode 100644
index c96a25f443..0000000000
--- a/extra/webapps/site-watcher/site-list.xml
+++ /dev/null
@@ -1,32 +0,0 @@
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<p> Don't you hate it when your web site goes down, and all your users go buy that <a href="http://en.wikipedia.org/wiki/Slanket">slanket</a> from your competitor instead. Now using SiteWatcher, you can ensure this will never happen again! </p>
-
-<t:a t:href="$site-watcher-app/update-notify">Contact info</t:a>
-
-<h3>Step 2: add some sites to watch</h3>
-
-<t:form t:action="$site-watcher-app/add">
-<table>
- <tr><th>URL:</th><td> <t:field t:name="url" t:size="80" /> <button type="submit">Done</button> </td></tr>
-</table>
-</t:form>
-
-<h3>Step 3: keep track of your sites</h3>
-
-<table border="2">
- <tr> <th>URL</th><th></th> </tr>
- <t:bind-each t:name="sites">
- <tr>
- <td> <t:label t:name="url" /> </td>
- <td> <t:button t:action="$site-watcher-app/remove" t:for="url">Remove</t:button> </td>
- </tr>
- </t:bind-each>
-</table>
-<p>
- <t:button t:action="$site-watcher-app/check">Check now</t:button>
-</p>
-
-</t:chloe>
diff --git a/extra/webapps/site-watcher/site-watcher.factor b/extra/webapps/site-watcher/site-watcher.factor
index f173edb814..f82eb6dcd8 100644
--- a/extra/webapps/site-watcher/site-watcher.factor
+++ b/extra/webapps/site-watcher/site-watcher.factor
@@ -1,72 +1,22 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs db.sqlite furnace furnace.actions furnace.alloy
-furnace.auth furnace.auth.features.deactivate-user
+USING: accessors assocs db.sqlite furnace furnace.actions
+furnace.alloy furnace.auth furnace.auth.features.deactivate-user
furnace.auth.features.edit-profile
furnace.auth.features.recover-password
furnace.auth.features.registration furnace.auth.login
furnace.boilerplate furnace.redirection html.forms http.server
http.server.dispatchers kernel namespaces site-watcher site-watcher.db
site-watcher.private urls validators io.sockets.secure.unix.debug
-io.servers.connection db db.tuples sequences ;
+io.servers.connection io.files.temp db db.tuples sequences
+webapps.site-watcher.common webapps.site-watcher.watching
+webapps.site-watcher.spidering ;
QUALIFIED: assocs
IN: webapps.site-watcher
-TUPLE: site-watcher-app < dispatcher ;
-
-CONSTANT: site-list-url URL" $site-watcher-app/"
-
: <main-action> ( -- action )
<page-action>
- [
- logged-in?
- [ URL" $site-watcher-app/list" <redirect> ]
- [ { site-watcher-app "main" } <chloe-content> ] if
- ] >>display ;
-
-: <site-list-action> ( -- action )
- <page-action>
- { site-watcher-app "site-list" } >>template
- [
- ! Silly query
- username watching-sites
- "sites" set-value
- ] >>init
- <protected>
- "list watched sites" >>description ;
-
-: <add-site-action> ( -- action )
- <action>
- [
- { { "url" [ v-url ] } } validate-params
- ] >>validate
- [
- username "url" value watch-site
- site-list-url <redirect>
- ] >>submit
- <protected>
- "add a watched site" >>description ;
-
-: <remove-site-action> ( -- action )
- <action>
- [
- { { "url" [ v-url ] } } validate-params
- ] >>validate
- [
- username "url" value unwatch-site
- site-list-url <redirect>
- ] >>submit
- <protected>
- "remove a watched site" >>description ;
-
-: <check-sites-action> ( -- action )
- <action>
- [
- watch-sites
- site-list-url <redirect>
- ] >>submit
- <protected>
- "check watched sites" >>description ;
+ { site-watcher-app "main" } >>template ;
: <update-notify-action> ( -- action )
<page-action>
@@ -95,10 +45,14 @@ CONSTANT: site-list-url URL" $site-watcher-app/"
: <site-watcher-app> ( -- dispatcher )
site-watcher-app new-dispatcher
<main-action> "" add-responder
- <site-list-action> "list" add-responder
- <add-site-action> "add" add-responder
- <remove-site-action> "remove" add-responder
+ <watch-list-action> "watch-list" add-responder
+ <add-watched-site-action> "add-watch" add-responder
+ <remove-watched-site-action> "remove-watch" add-responder
<check-sites-action> "check" add-responder
+ <spider-list-action> "spider-list" add-responder
+ <add-spidered-site-action> "add-spider" add-responder
+ <remove-spidered-site-action> "remove-spider" add-responder
+ <spider-sites-action> "spider" add-responder
<update-notify-action> "update-notify" add-responder ;
: <login-config> ( responder -- responder' )
@@ -116,7 +70,7 @@ CONSTANT: site-list-url URL" $site-watcher-app/"
8431 >>secure ;
: site-watcher-db ( -- db )
- "resource:test.db" <sqlite-db> ;
+ "test.db" temp-file <sqlite-db> ;
<site-watcher-app>
<login-config>
@@ -125,12 +79,12 @@ site-watcher-db <alloy>
main-responder set-global
M: site-watcher-app init-user-profile
- drop
- "username" value "email" value <account> insert-tuple ;
+ drop "username" value "email" value <account> insert-tuple ;
: init-db ( -- )
site-watcher-db [
- { site account watching-site } [ ensure-table ] each
+ { site account watching-site spidering-site }
+ [ ensure-table ] each
] with-db ;
: start-site-watcher ( -- )
diff --git a/extra/webapps/site-watcher/spidering/authors.txt b/extra/webapps/site-watcher/spidering/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/webapps/site-watcher/spidering/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/webapps/site-watcher/spidering/spidering.factor b/extra/webapps/site-watcher/spidering/spidering.factor
new file mode 100644
index 0000000000..a838c6763a
--- /dev/null
+++ b/extra/webapps/site-watcher/spidering/spidering.factor
@@ -0,0 +1,52 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.auth
+furnace.redirection html.forms validators webapps.site-watcher.common
+site-watcher.db site-watcher.spider kernel urls sequences ;
+IN: webapps.site-watcher.spidering
+
+CONSTANT: site-list-url URL" $site-watcher-app/spider-list"
+
+: <spider-list-action> ( -- action )
+ <page-action>
+ { site-watcher-app "spider-list" } >>template
+ [
+ ! Silly query
+ username spidering-sites [ site>> ] map
+ "sites" set-value
+ ] >>init
+ <protected>
+ "list spidered sites" >>description ;
+
+: <add-spidered-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } } validate-params
+ ] >>validate
+ [
+ username "url" value add-spidered-site
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "add a spidered site" >>description ;
+
+: <remove-spidered-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } } validate-params
+ ] >>validate
+ [
+ username "url" value remove-spidered-site
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "remove a spidered site" >>description ;
+
+: <spider-sites-action> ( -- action )
+ <action>
+ [
+ spider-sites
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "spider sites" >>description ;
\ No newline at end of file
diff --git a/extra/webapps/site-watcher/watching/authors.txt b/extra/webapps/site-watcher/watching/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/webapps/site-watcher/watching/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/webapps/site-watcher/watching/watching.factor b/extra/webapps/site-watcher/watching/watching.factor
new file mode 100644
index 0000000000..414595a12a
--- /dev/null
+++ b/extra/webapps/site-watcher/watching/watching.factor
@@ -0,0 +1,52 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors furnace.actions furnace.auth
+furnace.redirection html.forms site-watcher site-watcher.db
+validators webapps.site-watcher.common urls ;
+IN: webapps.site-watcher.watching
+
+CONSTANT: site-list-url URL" $site-watcher-app/watch-list"
+
+: <watch-list-action> ( -- action )
+ <page-action>
+ { site-watcher-app "site-list" } >>template
+ [
+ ! Silly query
+ username watching-sites
+ "sites" set-value
+ ] >>init
+ <protected>
+ "list watched sites" >>description ;
+
+: <add-watched-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } } validate-params
+ ] >>validate
+ [
+ username "url" value watch-site
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "add a watched site" >>description ;
+
+: <remove-watched-site-action> ( -- action )
+ <action>
+ [
+ { { "url" [ v-url ] } } validate-params
+ ] >>validate
+ [
+ username "url" value unwatch-site
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "remove a watched site" >>description ;
+
+: <check-sites-action> ( -- action )
+ <action>
+ [
+ watch-sites
+ site-list-url <redirect>
+ ] >>submit
+ <protected>
+ "check watched sites" >>description ;
\ No newline at end of file
diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor
index 34cd19c34f..e02701b690 100644
--- a/extra/wordtimer/wordtimer.factor
+++ b/extra/wordtimer/wordtimer.factor
@@ -56,9 +56,6 @@ SYMBOL: *calling*
: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} )
[ first2 ] dip
swap [ * - ] keep 2array ;
-
-: change-global ( variable quot -- )
- global swap change-at ;
: (correct-for-timing-overhead) ( timingshash -- timingshash )
time-dummy-word [ subtract-overhead ] curry assoc-map ;
@@ -75,7 +72,7 @@ SYMBOL: *calling*
correct-for-timing-overhead
"total time:" write
] dip pprint nl
- print-word-timings nl ;
+ print-word-timings nl ; inline
: profile-vocab ( vocab quot -- )
"annotating vocab..." print flush
@@ -88,4 +85,4 @@ SYMBOL: *calling*
correct-for-timing-overhead
"total time:" write
] dip pprint
- print-word-timings ;
+ print-word-timings ; inline
diff --git a/license.txt b/license.txt
index 8f4f53585a..e9cd58a5e4 100644
--- a/license.txt
+++ b/license.txt
@@ -1,5 +1,3 @@
-Copyright (C) 2003, 2009 Slava Pestov and friends.
-
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el
index f180d0f2b4..ef39b7af65 100644
--- a/misc/fuel/fuel-connection.el
+++ b/misc/fuel/fuel-connection.el
@@ -164,7 +164,7 @@
(fuel-con--send-string/wait buffer
fuel-con--init-stanza
'fuel-con--establish-connection-cont
- 60000)
+ 3000000)
conn))
(defun fuel-con--establish-connection-cont (ignore)
diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el
index 4842f960d1..8b25744011 100644
--- a/misc/fuel/fuel-debug-uses.el
+++ b/misc/fuel/fuel-debug-uses.el
@@ -88,9 +88,16 @@
fuel-debug--uses nil
fuel-debug--uses-restarts nil))
+(defun fuel-debug--current-usings (file)
+ (with-current-buffer (find-file-noselect file)
+ (sort (fuel-syntax--find-usings t) 'string<)))
+
(defun fuel-debug--uses-for-file (file)
(let* ((lines (fuel-debug--file-lines file))
- (cmd `(:fuel ((V{ ,@lines } fuel-get-uses)) t t)))
+ (old-usings (fuel-debug--current-usings file))
+ (cmd `(:fuel ((V{ ,@old-usings }
+ [ V{ ,@lines } fuel-get-uses ]
+ fuel-use-suggested-vocabs)) t t)))
(fuel-debug--uses-prepare file)
(fuel--with-popup (fuel-debug--uses-buffer)
(insert "Asking Factor. Please, wait ...\n")
@@ -105,8 +112,7 @@
(defun fuel-debug--uses-display (uses)
(let* ((inhibit-read-only t)
- (old (with-current-buffer (find-file-noselect fuel-debug--uses-file)
- (sort (fuel-syntax--find-usings t) 'string<)))
+ (old (fuel-debug--current-usings fuel-debug--uses-file))
(new (sort uses 'string<)))
(erase-buffer)
(fuel-debug--uses-insert-title)
diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el
index bc1bb900ce..aa7d25ebbd 100644
--- a/misc/fuel/fuel-font-lock.el
+++ b/misc/fuel/fuel-font-lock.el
@@ -60,6 +60,7 @@
(declaration keyword "declaration words")
(ebnf-form constant "EBNF: ... ;EBNF form")
(parsing-word keyword "parsing words")
+ (postpone-body comment "postponed form")
(setter-word function-name "setter words (>>foo)")
(getter-word function-name "getter words (foo>>)")
(stack-effect comment "stack effect specifications")
@@ -76,20 +77,19 @@
(defun fuel-font-lock--syntactic-face (state)
(if (nth 3 state) 'factor-font-lock-string
(let ((c (char-after (nth 8 state))))
- (cond ((or (char-equal c ?\ )
- (char-equal c ?\n)
- (char-equal c ?E))
+ (cond ((memq c '(?\ ?\n ?E ?P))
(save-excursion
(goto-char (nth 8 state))
(beginning-of-line)
- (cond ((looking-at-p "USING: ")
+ (cond ((looking-at "E") 'factor-font-lock-ebnf-form)
+ ((looking-at "P") 'factor-font-lock-postpone-body)
+ ((looking-at-p "USING: ")
'factor-font-lock-vocabulary-name)
- ((looking-at-p "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
+ ((looking-at-p
+ "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
'factor-font-lock-symbol)
((looking-at-p "C-ENUM:\\( \\|\n\\)")
'factor-font-lock-constant)
- ((looking-at-p "E")
- 'factor-font-lock-ebnf-form)
(t 'default))))
((or (char-equal c ?U) (char-equal c ?C))
'factor-font-lock-parsing-word)
@@ -102,9 +102,10 @@
(,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-word))
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
- (,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
- (2 'factor-font-lock-type-name)
- (3 'factor-font-lock-invalid-syntax nil t))
+ (,fuel-syntax--constructor-decl-regex
+ (1 'factor-font-lock-word)
+ (2 'factor-font-lock-type-name)
+ (3 'factor-font-lock-invalid-syntax nil t))
(,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
(2 'factor-font-lock-type-name)
(3 'factor-font-lock-invalid-syntax nil t))
diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el
index aa9a7d944e..0186392f34 100644
--- a/misc/fuel/fuel-mode.el
+++ b/misc/fuel/fuel-mode.el
@@ -140,7 +140,7 @@ for details."
(interactive)
(message "Loading all vocabularies in USING: form ...")
(let ((err (fuel-eval--retort-error
- (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000))))
+ (fuel-eval--send/wait '(:fuel* (t .) t :usings) 120000))))
(message (if err "Warning: some vocabularies failed to load"
"All vocabularies loaded"))))
diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index 7aba6282d6..61aa2b7cdd 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/misc/fuel/fuel-syntax.el
@@ -241,18 +241,19 @@
table))
(defconst fuel-syntax--syntactic-keywords
- `(;; Comments
- ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">"))
- ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
- ;; Strings and chars
- ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
- (1 "w") (2 "\"") (4 "\""))
- ("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
- ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
- (3 "\"") (5 "\""))
- ("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
+ `(;; Strings and chars
("\\_<<\\(\"\\)\\_>" (1 "<b"))
("\\_<\\(\"\\)>\\_>" (1 ">b"))
+ ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)?\\(\"\\)\\(\\([^\n\r\f\"\\]\\|\\\\.\\)*\\)\\(\"\\)"
+ (3 "\"") (6 "\""))
+ ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
+ (1 "w") (2 "<b") (4 ">b"))
+ ("\\(CHAR:\\|\\\\\\) \\(\\w\\|!\\)\\( \\|$\\)" (2 "w"))
+ ;; Comments
+ ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">"))
+ ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
+ ;; postpone
+ ("\\_<POSTPONE:\\( \\).*\\(\n\\)" (1 "<b") (2 ">b"))
;; Multiline constructs
("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
@@ -262,7 +263,8 @@
("\\_<C-ENUM:\\( \\|\n\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\|\n\\)\\([^;]\\|$\\)" (1 "<b"))
("\\_<TUPLE: +\\w+? *\\( \\|\n\\)\\([^;<\n]\\|\\_>\\)" (1 "<b"))
- ("\\_<\\(SYMBOLS\\|VARS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)" (2 "<b"))
+ ("\\_<\\(SYMBOLS\\|VARS\\|SINGLETONS\\): *?\\( \\|\n\\)\\([^;\n]\\|\\_>\\)"
+ (2 "<b"))
("\\(\n\\| \\);\\_>" (1 ">b"))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
@@ -275,6 +277,7 @@
("\\_<\\(}\\)\\_>" (1 "){"))
;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()"))
+ ("\\_<call\\((\\)\\_>" (1 "()"))
("\\_<\\()\\)\\_>" (1 ")("))
("\\_<(\\((\\)\\_>" (1 "()"))
("\\_<\\()\\))\\_>" (1 ")("))
diff --git a/extra/advice/advice-docs.factor b/unmaintained/advice/advice-docs.factor
similarity index 100%
rename from extra/advice/advice-docs.factor
rename to unmaintained/advice/advice-docs.factor
diff --git a/extra/advice/advice-tests.factor b/unmaintained/advice/advice-tests.factor
similarity index 98%
rename from extra/advice/advice-tests.factor
rename to unmaintained/advice/advice-tests.factor
index a141489a0f..396687e733 100644
--- a/extra/advice/advice-tests.factor
+++ b/unmaintained/advice/advice-tests.factor
@@ -25,7 +25,7 @@ IN: advice.tests
foo
] unit-test
- : bar ( a -- b ) 1+ ;
+ : bar ( a -- b ) 1 + ;
\ bar make-advised
{ 11 } [
@@ -91,4 +91,4 @@ IN: advice.tests
! [ 3 5 quux ] with-string-writer"> eval
! ] unit-test
-] with-scope
\ No newline at end of file
+] with-scope
diff --git a/extra/advice/advice.factor b/unmaintained/advice/advice.factor
similarity index 88%
rename from extra/advice/advice.factor
rename to unmaintained/advice/advice.factor
index 9c0963469e..44280456c1 100644
--- a/extra/advice/advice.factor
+++ b/unmaintained/advice/advice.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences fry words assocs linked-assocs tools.annotations
-coroutines lexer parser quotations arrays namespaces continuations ;
+coroutines lexer parser quotations arrays namespaces continuations
+summary ;
IN: advice
SYMBOLS: before after around advised in-advice? ;
@@ -45,8 +46,13 @@ PRIVATE>
: remove-advice ( name word loc -- )
word-prop delete-at ;
+ERROR: ad-do-it-error ;
+
+M: ad-do-it-error summary
+ drop "ad-do-it should only be called inside 'around' advice" ;
+
: ad-do-it ( input -- result )
- in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
+ in-advice? get [ ad-do-it-error ] unless coyield ;
: make-advised ( word -- )
[ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
@@ -60,4 +66,4 @@ SYNTAX: ADVISE: ! word adname location => word adname quot loc
scan-word scan scan-word parse-definition swap [ spin ] dip advise ;
SYNTAX: UNADVISE:
- scan-word parsed \ unadvise parsed ;
\ No newline at end of file
+ scan-word parsed \ unadvise parsed ;
diff --git a/extra/advice/authors.txt b/unmaintained/advice/authors.txt
similarity index 100%
rename from extra/advice/authors.txt
rename to unmaintained/advice/authors.txt
diff --git a/extra/advice/summary.txt b/unmaintained/advice/summary.txt
similarity index 100%
rename from extra/advice/summary.txt
rename to unmaintained/advice/summary.txt
diff --git a/unmaintained/advice/tags.txt b/unmaintained/advice/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/unmaintained/advice/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/extra/boolean-expr/authors.txt b/unmaintained/boolean-expr/authors.txt
similarity index 100%
rename from extra/boolean-expr/authors.txt
rename to unmaintained/boolean-expr/authors.txt
diff --git a/extra/boolean-expr/boolean-expr.factor b/unmaintained/boolean-expr/boolean-expr.factor
similarity index 100%
rename from extra/boolean-expr/boolean-expr.factor
rename to unmaintained/boolean-expr/boolean-expr.factor
diff --git a/extra/boolean-expr/summary.txt b/unmaintained/boolean-expr/summary.txt
similarity index 100%
rename from extra/boolean-expr/summary.txt
rename to unmaintained/boolean-expr/summary.txt
diff --git a/extra/boolean-expr/tags.txt b/unmaintained/boolean-expr/tags.txt
similarity index 100%
rename from extra/boolean-expr/tags.txt
rename to unmaintained/boolean-expr/tags.txt
diff --git a/extra/graph-theory/authors.txt b/unmaintained/graph-theory/authors.txt
similarity index 100%
rename from extra/graph-theory/authors.txt
rename to unmaintained/graph-theory/authors.txt
diff --git a/extra/graph-theory/graph-theory-docs.factor b/unmaintained/graph-theory/graph-theory-docs.factor
similarity index 100%
rename from extra/graph-theory/graph-theory-docs.factor
rename to unmaintained/graph-theory/graph-theory-docs.factor
diff --git a/extra/graph-theory/graph-theory.factor b/unmaintained/graph-theory/graph-theory.factor
similarity index 90%
rename from extra/graph-theory/graph-theory.factor
rename to unmaintained/graph-theory/graph-theory.factor
index b14832dc03..1b4224c864 100644
--- a/extra/graph-theory/graph-theory.factor
+++ b/unmaintained/graph-theory/graph-theory.factor
@@ -1,8 +1,7 @@
! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
! See http://factorcode.org/license.txt for BSD license.
-
-USING: kernel combinators fry continuations sequences arrays vectors assocs hashtables heaps namespaces ;
-
+USING: kernel combinators fry continuations sequences arrays
+vectors assocs hashtables heaps namespaces ;
IN: graph-theory
MIXIN: graph
@@ -35,7 +34,7 @@ M: graph num-vertices
vertices length ;
M: graph num-edges
- [ vertices ] [ '[ _ adjlist length ] map sum ] bi ;
+ [ vertices ] [ '[ _ adjlist length ] sigma ] bi ;
M: graph adjlist
[ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
@@ -88,5 +87,5 @@ PRIVATE>
: topological-sort ( graph -- seq/f )
dup dag?
- [ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
+ [ V{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
[ drop f ] if ;
diff --git a/extra/graph-theory/reversals/reversals.factor b/unmaintained/graph-theory/reversals/reversals.factor
similarity index 100%
rename from extra/graph-theory/reversals/reversals.factor
rename to unmaintained/graph-theory/reversals/reversals.factor
diff --git a/extra/graph-theory/sparse/sparse.factor b/unmaintained/graph-theory/sparse/sparse.factor
similarity index 100%
rename from extra/graph-theory/sparse/sparse.factor
rename to unmaintained/graph-theory/sparse/sparse.factor
diff --git a/extra/graph-theory/summary.txt b/unmaintained/graph-theory/summary.txt
similarity index 100%
rename from extra/graph-theory/summary.txt
rename to unmaintained/graph-theory/summary.txt
diff --git a/extra/graph-theory/tags.txt b/unmaintained/graph-theory/tags.txt
similarity index 100%
rename from extra/graph-theory/tags.txt
rename to unmaintained/graph-theory/tags.txt
diff --git a/unmaintained/lint/authors.txt b/unmaintained/lint/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/unmaintained/lint/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/lint/lint-tests.factor b/unmaintained/lint/lint-tests.factor
similarity index 87%
rename from extra/lint/lint-tests.factor
rename to unmaintained/lint/lint-tests.factor
index 70035f1854..7326bc65b0 100644
--- a/extra/lint/lint-tests.factor
+++ b/unmaintained/lint/lint-tests.factor
@@ -2,7 +2,7 @@ USING: io lint kernel math tools.test ;
IN: lint.tests
! Don't write code like this
-: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when
+: lint1 ( obj -- ) [ "hi" print ] [ ] if ; ! when
[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
diff --git a/extra/lint/lint.factor b/unmaintained/lint/lint.factor
similarity index 100%
rename from extra/lint/lint.factor
rename to unmaintained/lint/lint.factor
diff --git a/extra/lint/summary.txt b/unmaintained/lint/summary.txt
similarity index 100%
rename from extra/lint/summary.txt
rename to unmaintained/lint/summary.txt
diff --git a/unmaintained/morse/morse-tests.factor b/unmaintained/morse/morse-tests.factor
deleted file mode 100644
index 144448917f..0000000000
--- a/unmaintained/morse/morse-tests.factor
+++ /dev/null
@@ -1,13 +0,0 @@
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays morse strings tools.test ;
-
-[ "" ] [ CHAR: \\ ch>morse ] unit-test
-[ "..." ] [ CHAR: s ch>morse ] unit-test
-[ CHAR: s ] [ "..." morse>ch ] unit-test
-[ f ] [ "..--..--.." morse>ch ] unit-test
-[ "-- --- .-. ... . / -.-. --- -.. ." ] [ "morse code" >morse ] unit-test
-[ "morse code" ] [ "-- --- .-. ... . / -.-. --- -.. ." morse> ] unit-test
-[ "hello, world!" ] [ "Hello, World!" >morse morse> ] unit-test
-! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
-! [ ] [ "Factor rocks!" play-as-morse ] unit-test
diff --git a/extra/math/matrices/authors.txt b/unmaintained/multi-methods/authors.txt
old mode 100644
new mode 100755
similarity index 100%
rename from extra/math/matrices/authors.txt
rename to unmaintained/multi-methods/authors.txt
diff --git a/extra/multi-methods/multi-methods.factor b/unmaintained/multi-methods/multi-methods.factor
similarity index 100%
rename from extra/multi-methods/multi-methods.factor
rename to unmaintained/multi-methods/multi-methods.factor
diff --git a/extra/multi-methods/summary.txt b/unmaintained/multi-methods/summary.txt
similarity index 100%
rename from extra/multi-methods/summary.txt
rename to unmaintained/multi-methods/summary.txt
diff --git a/unmaintained/multi-methods/tags.txt b/unmaintained/multi-methods/tags.txt
new file mode 100644
index 0000000000..f4274299b1
--- /dev/null
+++ b/unmaintained/multi-methods/tags.txt
@@ -0,0 +1 @@
+extensions
diff --git a/extra/multi-methods/tests/canonicalize.factor b/unmaintained/multi-methods/tests/canonicalize.factor
similarity index 100%
rename from extra/multi-methods/tests/canonicalize.factor
rename to unmaintained/multi-methods/tests/canonicalize.factor
diff --git a/extra/multi-methods/tests/definitions.factor b/unmaintained/multi-methods/tests/definitions.factor
similarity index 93%
rename from extra/multi-methods/tests/definitions.factor
rename to unmaintained/multi-methods/tests/definitions.factor
index 240c9f86d7..aa66f41d8d 100644
--- a/extra/multi-methods/tests/definitions.factor
+++ b/unmaintained/multi-methods/tests/definitions.factor
@@ -2,9 +2,6 @@ IN: multi-methods.tests
USING: multi-methods tools.test math sequences namespaces system
kernel strings words compiler.units quotations ;
-\ GENERIC: must-infer
-\ create-method-in must-infer
-
DEFER: fake
\ fake H{ } clone "multi-methods" set-word-prop
diff --git a/extra/multi-methods/tests/legacy.factor b/unmaintained/multi-methods/tests/legacy.factor
similarity index 100%
rename from extra/multi-methods/tests/legacy.factor
rename to unmaintained/multi-methods/tests/legacy.factor
diff --git a/extra/multi-methods/tests/syntax.factor b/unmaintained/multi-methods/tests/syntax.factor
similarity index 100%
rename from extra/multi-methods/tests/syntax.factor
rename to unmaintained/multi-methods/tests/syntax.factor
diff --git a/extra/multi-methods/tests/topological-sort.factor b/unmaintained/multi-methods/tests/topological-sort.factor
similarity index 100%
rename from extra/multi-methods/tests/topological-sort.factor
rename to unmaintained/multi-methods/tests/topological-sort.factor
diff --git a/extra/newfx/newfx.factor b/unmaintained/newfx/newfx.factor
similarity index 100%
rename from extra/newfx/newfx.factor
rename to unmaintained/newfx/newfx.factor
diff --git a/unmaintained/openal/example/example.factor b/unmaintained/openal/example/example.factor
deleted file mode 100644
index ae0b50afff..0000000000
--- a/unmaintained/openal/example/example.factor
+++ /dev/null
@@ -1,34 +0,0 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-IN: openal.example
-USING: openal kernel alien threads sequences calendar ;
-
-: play-hello ( -- )
- init-openal
- 1 gen-sources
- first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param
- source-play
- 1000 milliseconds sleep ;
-
-: (play-file) ( source -- )
- 100 milliseconds sleep
- dup source-playing? [ (play-file) ] [ drop ] if ;
-
-: play-file ( filename -- )
- init-openal
- create-buffer-from-file
- 1 gen-sources
- first dup >r AL_BUFFER rot set-source-param r>
- dup source-play
- check-error
- (play-file) ;
-
-: play-wav ( filename -- )
- init-openal
- create-buffer-from-wav
- 1 gen-sources
- first dup >r AL_BUFFER rot set-source-param r>
- dup source-play
- check-error
- (play-file) ;
\ No newline at end of file
diff --git a/extra/shell/parser/parser.factor b/unmaintained/shell/parser/parser.factor
similarity index 100%
rename from extra/shell/parser/parser.factor
rename to unmaintained/shell/parser/parser.factor
diff --git a/extra/shell/shell.factor b/unmaintained/shell/shell.factor
similarity index 96%
rename from extra/shell/shell.factor
rename to unmaintained/shell/shell.factor
index d6c98ea203..5f1c75ba8a 100644
--- a/extra/shell/shell.factor
+++ b/unmaintained/shell/shell.factor
@@ -41,7 +41,7 @@ METHOD: expand { glob-expr }
[ ]
if ;
-METHOD: expand { factor-expr } expr>> eval unparse ;
+METHOD: expand { factor-expr } expr>> eval>string ;
DEFER: expansion
@@ -64,7 +64,7 @@ METHOD: expand { object } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run-sword ( basic-expr -- )
- command>> expansion unclip "shell" lookup execute ;
+ command>> expansion unclip "shell" lookup execute( arguments -- ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/unmaintained/ui/offscreen/authors.txt b/unmaintained/ui/offscreen/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/unmaintained/ui/offscreen/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/ui/offscreen/offscreen-docs.factor b/unmaintained/ui/offscreen/offscreen-docs.factor
similarity index 100%
rename from extra/ui/offscreen/offscreen-docs.factor
rename to unmaintained/ui/offscreen/offscreen-docs.factor
diff --git a/extra/ui/offscreen/offscreen.factor b/unmaintained/ui/offscreen/offscreen.factor
similarity index 92%
rename from extra/ui/offscreen/offscreen.factor
rename to unmaintained/ui/offscreen/offscreen.factor
index 8d197eb844..c6669eb16f 100755
--- a/extra/ui/offscreen/offscreen.factor
+++ b/unmaintained/ui/offscreen/offscreen.factor
@@ -6,6 +6,9 @@ IN: ui.offscreen
TUPLE: offscreen-world < world ;
+M: offscreen-world world-pixel-format-attributes
+ { offscreen T{ depth-bits { value 16 } } } ;
+
: <offscreen-world> ( gadget title status -- world )
offscreen-world new-world ;
diff --git a/extra/ui/offscreen/summary.txt b/unmaintained/ui/offscreen/summary.txt
similarity index 100%
rename from extra/ui/offscreen/summary.txt
rename to unmaintained/ui/offscreen/summary.txt
diff --git a/extra/ui/offscreen/tags.txt b/unmaintained/ui/offscreen/tags.txt
similarity index 100%
rename from extra/ui/offscreen/tags.txt
rename to unmaintained/ui/offscreen/tags.txt
diff --git a/vm/Config.arm b/vm/Config.arm
index 2273d61caf..1d7e6f9cc6 100644
--- a/vm/Config.arm
+++ b/vm/Config.arm
@@ -1 +1 @@
-PLAF_DLL_OBJS += vm/cpu-arm.o
+PLAF_DLL_OBJS += vmpp/cpu-arm.o
diff --git a/vm/Config.macosx b/vm/Config.macosx
index 98d14cfdf4..07629f72bb 100644
--- a/vm/Config.macosx
+++ b/vm/Config.macosx
@@ -14,7 +14,7 @@ else
LIBS = -lm -framework Cocoa -framework AppKit
endif
-LINKER = gcc $(CFLAGS) -dynamiclib -single_module -std=gnu99 \
+LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module -std=gnu99 \
-current_version $(VERSION) \
-compatibility_version $(VERSION) \
-fvisibility=hidden \
diff --git a/vm/Config.unix b/vm/Config.unix
old mode 100644
new mode 100755
index 339c3c3ffb..d7214a622b
--- a/vm/Config.unix
+++ b/vm/Config.unix
@@ -14,10 +14,11 @@ PLAF_EXE_OBJS += vm/main-unix.o
ifdef NO_UI
X11_UI_LIBS =
else
- X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lGLU -lX11
+ X11_UI_LIBS = -lpango-1.0 -lpangocairo-1.0 -lcairo -lglib-2.0 -lgobject-2.0 -lGL -lX11
endif
# CFLAGS += -fPIC
+FFI_TEST_CFLAGS = -fPIC
# LINKER = gcc -shared -o
# LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor
diff --git a/vm/Config.x86.32 b/vm/Config.x86.32
index bbd26e8e11..e060ef7019 100644
--- a/vm/Config.x86.32
+++ b/vm/Config.x86.32
@@ -2,4 +2,4 @@ BOOT_ARCH = x86
PLAF_DLL_OBJS += vm/cpu-x86.32.o
# gcc bug workaround
-CFLAGS += -fno-builtin-strlen -fno-builtin-strcat -mtune=pentium4
+CFLAGS += -fno-builtin-strlen -fno-builtin-strcat
diff --git a/vm/alien.c b/vm/alien.cpp
similarity index 50%
rename from vm/alien.c
rename to vm/alien.cpp
index 2681579c5d..06dee31a14 100755
--- a/vm/alien.c
+++ b/vm/alien.cpp
@@ -1,97 +1,61 @@
-#include "master.h"
+#include "master.hpp"
-/* gets the address of an object representing a C pointer */
-void *alien_offset(CELL object)
+namespace factor
{
- F_ALIEN *alien;
- F_BYTE_ARRAY *byte_array;
-
- switch(type_of(object))
- {
- case BYTE_ARRAY_TYPE:
- byte_array = untag_object(object);
- return byte_array + 1;
- case ALIEN_TYPE:
- alien = untag_object(object);
- if(alien->expired != F)
- general_error(ERROR_EXPIRED,object,F,NULL);
- return alien_offset(alien->alien) + alien->displacement;
- case F_TYPE:
- return NULL;
- default:
- type_error(ALIEN_TYPE,object);
- return NULL; /* can't happen */
- }
-}
/* gets the address of an object representing a C pointer, with the
intention of storing the pointer across code which may potentially GC. */
-void *pinned_alien_offset(CELL object)
+char *pinned_alien_offset(cell obj)
{
- F_ALIEN *alien;
-
- switch(type_of(object))
+ switch(tagged<object>(obj).type())
{
case ALIEN_TYPE:
- alien = untag_object(object);
- if(alien->expired != F)
- general_error(ERROR_EXPIRED,object,F,NULL);
- return pinned_alien_offset(alien->alien) + alien->displacement;
+ {
+ alien *ptr = untag<alien>(obj);
+ if(ptr->expired != F)
+ general_error(ERROR_EXPIRED,obj,F,NULL);
+ return pinned_alien_offset(ptr->alien) + ptr->displacement;
+ }
case F_TYPE:
return NULL;
default:
- type_error(ALIEN_TYPE,object);
+ type_error(ALIEN_TYPE,obj);
return NULL; /* can't happen */
}
}
-/* pop an object representing a C pointer */
-void *unbox_alien(void)
-{
- return alien_offset(dpop());
-}
-
/* make an alien */
-CELL allot_alien(CELL delegate, CELL displacement)
+cell allot_alien(cell delegate_, cell displacement)
{
- REGISTER_ROOT(delegate);
- F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN));
- UNREGISTER_ROOT(delegate);
+ gc_root<object> delegate(delegate_);
+ gc_root<alien> new_alien(allot<alien>(sizeof(alien)));
- if(type_of(delegate) == ALIEN_TYPE)
+ if(delegate.type_p(ALIEN_TYPE))
{
- F_ALIEN *delegate_alien = untag_object(delegate);
+ tagged<alien> delegate_alien = delegate.as<alien>();
displacement += delegate_alien->displacement;
- alien->alien = delegate_alien->alien;
+ new_alien->alien = delegate_alien->alien;
}
else
- alien->alien = delegate;
+ new_alien->alien = delegate.value();
- alien->displacement = displacement;
- alien->expired = F;
- return tag_object(alien);
-}
+ new_alien->displacement = displacement;
+ new_alien->expired = F;
-/* make an alien and push */
-void box_alien(void *ptr)
-{
- if(ptr == NULL)
- dpush(F);
- else
- dpush(allot_alien(F,(CELL)ptr));
+ return new_alien.value();
}
/* make an alien pointing at an offset of another alien */
-void primitive_displaced_alien(void)
+PRIMITIVE(displaced_alien)
{
- CELL alien = dpop();
- CELL displacement = to_cell(dpop());
+ cell alien = dpop();
+ cell displacement = to_cell(dpop());
if(alien == F && displacement == 0)
dpush(F);
else
{
- switch(type_of(alien))
+ switch(tagged<object>(alien).type())
{
case BYTE_ARRAY_TYPE:
case ALIEN_TYPE:
@@ -107,33 +71,33 @@ void primitive_displaced_alien(void)
/* address of an object representing a C pointer. Explicitly throw an error
if the object is a byte array, as a sanity check. */
-void primitive_alien_address(void)
+PRIMITIVE(alien_address)
{
- box_unsigned_cell((CELL)pinned_alien_offset(dpop()));
+ box_unsigned_cell((cell)pinned_alien_offset(dpop()));
}
/* pop ( alien n ) from datastack, return alien's address plus n */
-INLINE void *alien_pointer(void)
+static void *alien_pointer(void)
{
- F_FIXNUM offset = to_fixnum(dpop());
+ fixnum offset = to_fixnum(dpop());
return unbox_alien() + offset;
}
/* define words to read/write values at an alien address */
#define DEFINE_ALIEN_ACCESSOR(name,type,boxer,to) \
- void primitive_alien_##name(void) \
+ PRIMITIVE(alien_##name) \
{ \
boxer(*(type*)alien_pointer()); \
} \
- void primitive_set_alien_##name(void) \
+ PRIMITIVE(set_alien_##name) \
{ \
- type* ptr = alien_pointer(); \
+ type *ptr = (type *)alien_pointer(); \
type value = to(dpop()); \
*ptr = value; \
}
-DEFINE_ALIEN_ACCESSOR(signed_cell,F_FIXNUM,box_signed_cell,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_cell,CELL,box_unsigned_cell,to_cell)
+DEFINE_ALIEN_ACCESSOR(signed_cell,fixnum,box_signed_cell,to_fixnum)
+DEFINE_ALIEN_ACCESSOR(unsigned_cell,cell,box_unsigned_cell,to_cell)
DEFINE_ALIEN_ACCESSOR(signed_8,s64,box_signed_8,to_signed_8)
DEFINE_ALIEN_ACCESSOR(unsigned_8,u64,box_unsigned_8,to_unsigned_8)
DEFINE_ALIEN_ACCESSOR(signed_4,s32,box_signed_4,to_fixnum)
@@ -146,33 +110,119 @@ DEFINE_ALIEN_ACCESSOR(float,float,box_float,to_float)
DEFINE_ALIEN_ACCESSOR(double,double,box_double,to_double)
DEFINE_ALIEN_ACCESSOR(cell,void *,box_alien,pinned_alien_offset)
+/* open a native library and push a handle */
+PRIMITIVE(dlopen)
+{
+ gc_root<byte_array> path(dpop());
+ path.untag_check();
+ gc_root<dll> library(allot<dll>(sizeof(dll)));
+ library->path = path.value();
+ ffi_dlopen(library.untagged());
+ dpush(library.value());
+}
+
+/* look up a symbol in a native library */
+PRIMITIVE(dlsym)
+{
+ gc_root<object> library(dpop());
+ gc_root<byte_array> name(dpop());
+ name.untag_check();
+
+ vm_char *sym = (vm_char *)(name.untagged() + 1);
+
+ if(library.value() == F)
+ box_alien(ffi_dlsym(NULL,sym));
+ else
+ {
+ tagged<dll> d = library.as<dll>();
+ d.untag_check();
+
+ if(d->dll == NULL)
+ dpush(F);
+ else
+ box_alien(ffi_dlsym(d.untagged(),sym));
+ }
+}
+
+/* close a native library handle */
+PRIMITIVE(dlclose)
+{
+ ffi_dlclose(untag_check<dll>(dpop()));
+}
+
+PRIMITIVE(dll_validp)
+{
+ cell library = dpop();
+ if(library == F)
+ dpush(T);
+ else
+ dpush(tagged<dll>(library)->dll == NULL ? F : T);
+}
+
+/* gets the address of an object representing a C pointer */
+VM_C_API char *alien_offset(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case BYTE_ARRAY_TYPE:
+ return untag<byte_array>(obj)->data<char>();
+ case ALIEN_TYPE:
+ {
+ alien *ptr = untag<alien>(obj);
+ if(ptr->expired != F)
+ general_error(ERROR_EXPIRED,obj,F,NULL);
+ return alien_offset(ptr->alien) + ptr->displacement;
+ }
+ case F_TYPE:
+ return NULL;
+ default:
+ type_error(ALIEN_TYPE,obj);
+ return NULL; /* can't happen */
+ }
+}
+
+/* pop an object representing a C pointer */
+VM_C_API char *unbox_alien(void)
+{
+ return alien_offset(dpop());
+}
+
+/* make an alien and push */
+VM_C_API void box_alien(void *ptr)
+{
+ if(ptr == NULL)
+ dpush(F);
+ else
+ dpush(allot_alien(F,(cell)ptr));
+}
+
/* for FFI calls passing structs by value */
-void to_value_struct(CELL src, void *dest, CELL size)
+VM_C_API void to_value_struct(cell src, void *dest, cell size)
{
memcpy(dest,alien_offset(src),size);
}
/* for FFI callbacks receiving structs by value */
-void box_value_struct(void *src, CELL size)
+VM_C_API void box_value_struct(void *src, cell size)
{
- F_BYTE_ARRAY *array = allot_byte_array(size);
- memcpy(array + 1,src,size);
- dpush(tag_object(array));
+ byte_array *bytes = allot_byte_array(size);
+ memcpy(bytes->data<void>(),src,size);
+ dpush(tag<byte_array>(bytes));
}
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
-void box_small_struct(CELL x, CELL y, CELL size)
+VM_C_API void box_small_struct(cell x, cell y, cell size)
{
- CELL data[2];
+ cell data[2];
data[0] = x;
data[1] = y;
box_value_struct(data,size);
}
/* On OS X/PPC, complex numbers are returned in registers. */
-void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
{
- CELL data[4];
+ cell data[4];
data[0] = x1;
data[1] = x2;
data[2] = x3;
@@ -180,55 +230,4 @@ void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
box_value_struct(data,size);
}
-/* open a native library and push a handle */
-void primitive_dlopen(void)
-{
- CELL path = tag_object(string_to_native_alien(
- untag_string(dpop())));
- REGISTER_ROOT(path);
- F_DLL* dll = allot_object(DLL_TYPE,sizeof(F_DLL));
- UNREGISTER_ROOT(path);
- dll->path = path;
- ffi_dlopen(dll);
- dpush(tag_object(dll));
-}
-
-/* look up a symbol in a native library */
-void primitive_dlsym(void)
-{
- CELL dll = dpop();
- REGISTER_ROOT(dll);
- F_SYMBOL *sym = unbox_symbol_string();
- UNREGISTER_ROOT(dll);
-
- F_DLL *d;
-
- if(dll == F)
- box_alien(ffi_dlsym(NULL,sym));
- else
- {
- d = untag_dll(dll);
- if(d->dll == NULL)
- dpush(F);
- else
- box_alien(ffi_dlsym(d,sym));
- }
-}
-
-/* close a native library handle */
-void primitive_dlclose(void)
-{
- ffi_dlclose(untag_dll(dpop()));
-}
-
-void primitive_dll_validp(void)
-{
- CELL dll = dpop();
- if(dll == F)
- dpush(T);
- else
- {
- F_DLL *d = untag_dll(dll);
- dpush(d->dll == NULL ? F : T);
- }
}
diff --git a/vm/alien.h b/vm/alien.h
deleted file mode 100755
index dc76d49810..0000000000
--- a/vm/alien.h
+++ /dev/null
@@ -1,50 +0,0 @@
-CELL allot_alien(CELL delegate, CELL displacement);
-
-void primitive_displaced_alien(void);
-void primitive_alien_address(void);
-
-DLLEXPORT void *alien_offset(CELL object);
-
-void fixup_alien(F_ALIEN* d);
-
-DLLEXPORT void *unbox_alien(void);
-DLLEXPORT void box_alien(void *ptr);
-
-void primitive_alien_signed_cell(void);
-void primitive_set_alien_signed_cell(void);
-void primitive_alien_unsigned_cell(void);
-void primitive_set_alien_unsigned_cell(void);
-void primitive_alien_signed_8(void);
-void primitive_set_alien_signed_8(void);
-void primitive_alien_unsigned_8(void);
-void primitive_set_alien_unsigned_8(void);
-void primitive_alien_signed_4(void);
-void primitive_set_alien_signed_4(void);
-void primitive_alien_unsigned_4(void);
-void primitive_set_alien_unsigned_4(void);
-void primitive_alien_signed_2(void);
-void primitive_set_alien_signed_2(void);
-void primitive_alien_unsigned_2(void);
-void primitive_set_alien_unsigned_2(void);
-void primitive_alien_signed_1(void);
-void primitive_set_alien_signed_1(void);
-void primitive_alien_unsigned_1(void);
-void primitive_set_alien_unsigned_1(void);
-void primitive_alien_float(void);
-void primitive_set_alien_float(void);
-void primitive_alien_double(void);
-void primitive_set_alien_double(void);
-void primitive_alien_cell(void);
-void primitive_set_alien_cell(void);
-
-DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
-DLLEXPORT void box_value_struct(void *src, CELL size);
-DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
-void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size);
-
-DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
-
-void primitive_dlopen(void);
-void primitive_dlsym(void);
-void primitive_dlclose(void);
-void primitive_dll_validp(void);
diff --git a/vm/alien.hpp b/vm/alien.hpp
new file mode 100755
index 0000000000..a66135cf92
--- /dev/null
+++ b/vm/alien.hpp
@@ -0,0 +1,49 @@
+namespace factor
+{
+
+cell allot_alien(cell delegate, cell displacement);
+
+PRIMITIVE(displaced_alien);
+PRIMITIVE(alien_address);
+
+PRIMITIVE(alien_signed_cell);
+PRIMITIVE(set_alien_signed_cell);
+PRIMITIVE(alien_unsigned_cell);
+PRIMITIVE(set_alien_unsigned_cell);
+PRIMITIVE(alien_signed_8);
+PRIMITIVE(set_alien_signed_8);
+PRIMITIVE(alien_unsigned_8);
+PRIMITIVE(set_alien_unsigned_8);
+PRIMITIVE(alien_signed_4);
+PRIMITIVE(set_alien_signed_4);
+PRIMITIVE(alien_unsigned_4);
+PRIMITIVE(set_alien_unsigned_4);
+PRIMITIVE(alien_signed_2);
+PRIMITIVE(set_alien_signed_2);
+PRIMITIVE(alien_unsigned_2);
+PRIMITIVE(set_alien_unsigned_2);
+PRIMITIVE(alien_signed_1);
+PRIMITIVE(set_alien_signed_1);
+PRIMITIVE(alien_unsigned_1);
+PRIMITIVE(set_alien_unsigned_1);
+PRIMITIVE(alien_float);
+PRIMITIVE(set_alien_float);
+PRIMITIVE(alien_double);
+PRIMITIVE(set_alien_double);
+PRIMITIVE(alien_cell);
+PRIMITIVE(set_alien_cell);
+
+PRIMITIVE(dlopen);
+PRIMITIVE(dlsym);
+PRIMITIVE(dlclose);
+PRIMITIVE(dll_validp);
+
+VM_C_API char *alien_offset(cell object);
+VM_C_API char *unbox_alien(void);
+VM_C_API void box_alien(void *ptr);
+VM_C_API void to_value_struct(cell src, void *dest, cell size);
+VM_C_API void box_value_struct(void *src, cell size);
+VM_C_API void box_small_struct(cell x, cell y, cell size);
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
+
+}
diff --git a/vm/arrays.cpp b/vm/arrays.cpp
new file mode 100644
index 0000000000..f9a3f211d0
--- /dev/null
+++ b/vm/arrays.cpp
@@ -0,0 +1,87 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+/* make a new array with an initial element */
+array *allot_array(cell capacity, cell fill_)
+{
+ gc_root<object> fill(fill_);
+ gc_root<array> new_array(allot_array_internal<array>(capacity));
+
+ if(fill.value() == tag_fixnum(0))
+ memset(new_array->data(),'\0',capacity * sizeof(cell));
+ else
+ {
+ /* No need for write barrier here. Either the object is in
+ the nursery, or it was allocated directly in tenured space
+ and the write barrier is already hit for us in that case. */
+ cell i;
+ for(i = 0; i < capacity; i++)
+ new_array->data()[i] = fill.value();
+ }
+ return new_array.untagged();
+}
+
+/* push a new array on the stack */
+PRIMITIVE(array)
+{
+ cell initial = dpop();
+ cell size = unbox_array_size();
+ dpush(tag<array>(allot_array(size,initial)));
+}
+
+cell allot_array_1(cell obj_)
+{
+ gc_root<object> obj(obj_);
+ gc_root<array> a(allot_array_internal<array>(1));
+ set_array_nth(a.untagged(),0,obj.value());
+ return a.value();
+}
+
+cell allot_array_2(cell v1_, cell v2_)
+{
+ gc_root<object> v1(v1_);
+ gc_root<object> v2(v2_);
+ gc_root<array> a(allot_array_internal<array>(2));
+ set_array_nth(a.untagged(),0,v1.value());
+ set_array_nth(a.untagged(),1,v2.value());
+ return a.value();
+}
+
+cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_)
+{
+ gc_root<object> v1(v1_);
+ gc_root<object> v2(v2_);
+ gc_root<object> v3(v3_);
+ gc_root<object> v4(v4_);
+ gc_root<array> a(allot_array_internal<array>(4));
+ set_array_nth(a.untagged(),0,v1.value());
+ set_array_nth(a.untagged(),1,v2.value());
+ set_array_nth(a.untagged(),2,v3.value());
+ set_array_nth(a.untagged(),3,v4.value());
+ return a.value();
+}
+
+PRIMITIVE(resize_array)
+{
+ array* a = untag_check<array>(dpop());
+ cell capacity = unbox_array_size();
+ dpush(tag<array>(reallot_array(a,capacity)));
+}
+
+void growable_array::add(cell elt_)
+{
+ gc_root<object> elt(elt_);
+ if(count == array_capacity(elements.untagged()))
+ elements = reallot_array(elements.untagged(),count * 2);
+
+ set_array_nth(elements.untagged(),count++,elt.value());
+}
+
+void growable_array::trim()
+{
+ elements = reallot_array(elements.untagged(),count);
+}
+
+}
diff --git a/vm/arrays.hpp b/vm/arrays.hpp
new file mode 100644
index 0000000000..82da3bb71d
--- /dev/null
+++ b/vm/arrays.hpp
@@ -0,0 +1,43 @@
+namespace factor
+{
+
+inline static cell array_nth(array *array, cell slot)
+{
+#ifdef FACTOR_DEBUG
+ assert(slot < array_capacity(array));
+ assert(array->h.hi_tag() == ARRAY_TYPE);
+#endif
+ return array->data()[slot];
+}
+
+inline static void set_array_nth(array *array, cell slot, cell value)
+{
+#ifdef FACTOR_DEBUG
+ assert(slot < array_capacity(array));
+ assert(array->h.hi_tag() == ARRAY_TYPE);
+ check_tagged_pointer(value);
+#endif
+ array->data()[slot] = value;
+ write_barrier(array);
+}
+
+array *allot_array(cell capacity, cell fill);
+
+cell allot_array_1(cell obj);
+cell allot_array_2(cell v1, cell v2);
+cell allot_array_4(cell v1, cell v2, cell v3, cell v4);
+
+PRIMITIVE(array);
+PRIMITIVE(resize_array);
+
+struct growable_array {
+ cell count;
+ gc_root<array> elements;
+
+ growable_array() : count(0), elements(allot_array(2,F)) {}
+
+ void add(cell elt);
+ void trim();
+};
+
+}
diff --git a/vm/bignum.c b/vm/bignum.cpp
old mode 100644
new mode 100755
similarity index 84%
rename from vm/bignum.c
rename to vm/bignum.cpp
index 497a4bbf62..c487186da0
--- a/vm/bignum.c
+++ b/vm/bignum.cpp
@@ -46,18 +46,23 @@ MIT in each case. */
* - Add local variable GC root recording
* - Remove s48 prefix from function names
* - Various fixes for Win64
+ * - Port to C++
*/
-#include "master.h"
-#include <limits.h>
+#include "master.hpp"
+
+#include <limits>
+
#include <stdio.h>
-#include <stdlib.h> /* abort */
#include <math.h>
+namespace factor
+{
+
/* Exports */
int
-bignum_equal_p(bignum_type x, bignum_type y)
+bignum_equal_p(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
@@ -70,7 +75,7 @@ bignum_equal_p(bignum_type x, bignum_type y)
}
enum bignum_comparison
-bignum_compare(bignum_type x, bignum_type y)
+bignum_compare(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
@@ -93,8 +98,8 @@ bignum_compare(bignum_type x, bignum_type y)
}
/* allocates memory */
-bignum_type
-bignum_add(bignum_type x, bignum_type y)
+bignum *
+bignum_add(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
@@ -111,8 +116,8 @@ bignum_add(bignum_type x, bignum_type y)
}
/* allocates memory */
-bignum_type
-bignum_subtract(bignum_type x, bignum_type y)
+bignum *
+bignum_subtract(bignum * x, bignum * y)
{
return
((BIGNUM_ZERO_P (x))
@@ -131,8 +136,8 @@ bignum_subtract(bignum_type x, bignum_type y)
}
/* allocates memory */
-bignum_type
-bignum_multiply(bignum_type x, bignum_type y)
+bignum *
+bignum_multiply(bignum * x, bignum * y)
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_length_type y_length = (BIGNUM_LENGTH (y));
@@ -165,12 +170,12 @@ bignum_multiply(bignum_type x, bignum_type y)
/* allocates memory */
void
-bignum_divide(bignum_type numerator, bignum_type denominator,
- bignum_type * quotient, bignum_type * remainder)
+bignum_divide(bignum * numerator, bignum * denominator,
+ bignum * * quotient, bignum * * remainder)
{
if (BIGNUM_ZERO_P (denominator))
{
- divide_by_zero_error(NULL);
+ divide_by_zero_error();
return;
}
if (BIGNUM_ZERO_P (numerator))
@@ -237,12 +242,12 @@ bignum_divide(bignum_type numerator, bignum_type denominator,
}
/* allocates memory */
-bignum_type
-bignum_quotient(bignum_type numerator, bignum_type denominator)
+bignum *
+bignum_quotient(bignum * numerator, bignum * denominator)
{
if (BIGNUM_ZERO_P (denominator))
{
- divide_by_zero_error(NULL);
+ divide_by_zero_error();
return (BIGNUM_OUT_OF_BAND);
}
if (BIGNUM_ZERO_P (numerator))
@@ -261,7 +266,7 @@ bignum_quotient(bignum_type numerator, bignum_type denominator)
case bignum_comparison_greater:
default: /* to appease gcc -Wall */
{
- bignum_type quotient;
+ bignum * quotient;
if ((BIGNUM_LENGTH (denominator)) == 1)
{
bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
@@ -270,18 +275,18 @@ bignum_quotient(bignum_type numerator, bignum_type denominator)
if (digit < BIGNUM_RADIX_ROOT)
bignum_divide_unsigned_small_denominator
(numerator, digit,
- ("ient), ((bignum_type *) 0),
+ ("ient), ((bignum * *) 0),
q_negative_p, 0);
else
bignum_divide_unsigned_medium_denominator
(numerator, digit,
- ("ient), ((bignum_type *) 0),
+ ("ient), ((bignum * *) 0),
q_negative_p, 0);
}
else
bignum_divide_unsigned_large_denominator
(numerator, denominator,
- ("ient), ((bignum_type *) 0),
+ ("ient), ((bignum * *) 0),
q_negative_p, 0);
return (quotient);
}
@@ -290,12 +295,12 @@ bignum_quotient(bignum_type numerator, bignum_type denominator)
}
/* allocates memory */
-bignum_type
-bignum_remainder(bignum_type numerator, bignum_type denominator)
+bignum *
+bignum_remainder(bignum * numerator, bignum * denominator)
{
if (BIGNUM_ZERO_P (denominator))
{
- divide_by_zero_error(NULL);
+ divide_by_zero_error();
return (BIGNUM_OUT_OF_BAND);
}
if (BIGNUM_ZERO_P (numerator))
@@ -309,7 +314,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
case bignum_comparison_greater:
default: /* to appease gcc -Wall */
{
- bignum_type remainder;
+ bignum * remainder;
if ((BIGNUM_LENGTH (denominator)) == 1)
{
bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
@@ -321,13 +326,13 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
(numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
bignum_divide_unsigned_medium_denominator
(numerator, digit,
- ((bignum_type *) 0), (&remainder),
+ ((bignum * *) 0), (&remainder),
0, (BIGNUM_NEGATIVE_P (numerator)));
}
else
bignum_divide_unsigned_large_denominator
(numerator, denominator,
- ((bignum_type *) 0), (&remainder),
+ ((bignum * *) 0), (&remainder),
0, (BIGNUM_NEGATIVE_P (numerator)));
return (remainder);
}
@@ -335,7 +340,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
}
#define FOO_TO_BIGNUM(name,type,utype) \
- bignum_type name##_to_bignum(type n) \
+ bignum * name##_to_bignum(type n) \
{ \
int negative_p; \
bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
@@ -343,9 +348,9 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
/* Special cases win when these small constants are cached. */ \
if (n == 0) return (BIGNUM_ZERO ()); \
if (n == 1) return (BIGNUM_ONE (0)); \
- if (n < 0 && n == -1) return (BIGNUM_ONE (1)); \
+ if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
{ \
- utype accumulator = ((negative_p = (n < 0)) ? (-n) : n); \
+ utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
do \
{ \
(*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
@@ -354,7 +359,7 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
while (accumulator != 0); \
} \
{ \
- bignum_type result = \
+ bignum * result = \
(allot_bignum ((end_digits - result_digits), negative_p)); \
bignum_digit_type * scan_digits = result_digits; \
bignum_digit_type * scan_result = (BIGNUM_START_PTR (result)); \
@@ -365,13 +370,13 @@ bignum_remainder(bignum_type numerator, bignum_type denominator)
}
/* all below allocate memory */
-FOO_TO_BIGNUM(cell,CELL,CELL)
-FOO_TO_BIGNUM(fixnum,F_FIXNUM,CELL)
+FOO_TO_BIGNUM(cell,cell,cell)
+FOO_TO_BIGNUM(fixnum,fixnum,cell)
FOO_TO_BIGNUM(long_long,s64,u64)
FOO_TO_BIGNUM(ulong_long,u64,u64)
#define BIGNUM_TO_FOO(name,type,utype) \
- type bignum_to_##name(bignum_type bignum) \
+ type bignum_to_##name(bignum * bignum) \
{ \
if (BIGNUM_ZERO_P (bignum)) \
return (0); \
@@ -386,13 +391,13 @@ FOO_TO_BIGNUM(ulong_long,u64,u64)
}
/* all of the below allocate memory */
-BIGNUM_TO_FOO(cell,CELL,CELL);
-BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
+BIGNUM_TO_FOO(cell,cell,cell);
+BIGNUM_TO_FOO(fixnum,fixnum,cell);
BIGNUM_TO_FOO(long_long,s64,u64)
BIGNUM_TO_FOO(ulong_long,u64,u64)
double
-bignum_to_double(bignum_type bignum)
+bignum_to_double(bignum * bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
@@ -415,10 +420,12 @@ bignum_to_double(bignum_type bignum)
}
/* allocates memory */
-bignum_type
+#define inf std::numeric_limits<double>::infinity()
+
+bignum *
double_to_bignum(double x)
{
- if (x == 1.0/0.0 || x == -1.0/0.0 || x != x) return (BIGNUM_ZERO ());
+ if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ());
int exponent;
double significand = (frexp (x, (&exponent)));
if (exponent <= 0) return (BIGNUM_ZERO ());
@@ -426,13 +433,13 @@ double_to_bignum(double x)
if (significand < 0) significand = (-significand);
{
bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
- bignum_type result = (allot_bignum (length, (x < 0)));
+ bignum * result = (allot_bignum (length, (x < 0)));
bignum_digit_type * start = (BIGNUM_START_PTR (result));
bignum_digit_type * scan = (start + length);
bignum_digit_type digit;
int odd_bits = (exponent % BIGNUM_DIGIT_LENGTH);
if (odd_bits > 0)
- DTB_WRITE_DIGIT ((F_FIXNUM)1 << odd_bits);
+ DTB_WRITE_DIGIT ((fixnum)1 << odd_bits);
while (start < scan)
{
if (significand == 0)
@@ -452,7 +459,7 @@ double_to_bignum(double x)
/* Comparisons */
int
-bignum_equal_p_unsigned(bignum_type x, bignum_type y)
+bignum_equal_p_unsigned(bignum * x, bignum * y)
{
bignum_length_type length = (BIGNUM_LENGTH (x));
if (length != (BIGNUM_LENGTH (y)))
@@ -470,7 +477,7 @@ bignum_equal_p_unsigned(bignum_type x, bignum_type y)
}
enum bignum_comparison
-bignum_compare_unsigned(bignum_type x, bignum_type y)
+bignum_compare_unsigned(bignum * x, bignum * y)
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_length_type y_length = (BIGNUM_LENGTH (y));
@@ -498,23 +505,21 @@ bignum_compare_unsigned(bignum_type x, bignum_type y)
/* Addition */
/* allocates memory */
-bignum_type
-bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
+bignum *
+bignum_add_unsigned(bignum * x, bignum * y, int negative_p)
{
+ GC_BIGNUM(x); GC_BIGNUM(y);
+
if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
{
- bignum_type z = x;
+ bignum * z = x;
x = y;
y = z;
}
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
- REGISTER_BIGNUM(x);
- REGISTER_BIGNUM(y);
- bignum_type r = (allot_bignum ((x_length + 1), negative_p));
- UNREGISTER_BIGNUM(y);
- UNREGISTER_BIGNUM(x);
+ bignum * r = (allot_bignum ((x_length + 1), negative_p));
bignum_digit_type sum;
bignum_digit_type carry = 0;
@@ -568,9 +573,11 @@ bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
/* Subtraction */
/* allocates memory */
-bignum_type
-bignum_subtract_unsigned(bignum_type x, bignum_type y)
+bignum *
+bignum_subtract_unsigned(bignum * x, bignum * y)
{
+ GC_BIGNUM(x); GC_BIGNUM(y);
+
int negative_p = 0;
switch (bignum_compare_unsigned (x, y))
{
@@ -578,7 +585,7 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y)
return (BIGNUM_ZERO ());
case bignum_comparison_less:
{
- bignum_type z = x;
+ bignum * z = x;
x = y;
y = z;
}
@@ -591,11 +598,7 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y)
{
bignum_length_type x_length = (BIGNUM_LENGTH (x));
- REGISTER_BIGNUM(x);
- REGISTER_BIGNUM(y);
- bignum_type r = (allot_bignum (x_length, negative_p));
- UNREGISTER_BIGNUM(y);
- UNREGISTER_BIGNUM(x);
+ bignum * r = (allot_bignum (x_length, negative_p));
bignum_digit_type difference;
bignum_digit_type borrow = 0;
@@ -649,12 +652,14 @@ bignum_subtract_unsigned(bignum_type x, bignum_type y)
where R == BIGNUM_RADIX_ROOT */
/* allocates memory */
-bignum_type
-bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
+bignum *
+bignum_multiply_unsigned(bignum * x, bignum * y, int negative_p)
{
+ GC_BIGNUM(x); GC_BIGNUM(y);
+
if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
{
- bignum_type z = x;
+ bignum * z = x;
x = y;
y = z;
}
@@ -670,12 +675,8 @@ bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
bignum_length_type x_length = (BIGNUM_LENGTH (x));
bignum_length_type y_length = (BIGNUM_LENGTH (y));
- REGISTER_BIGNUM(x);
- REGISTER_BIGNUM(y);
- bignum_type r =
+ bignum * r =
(allot_bignum_zeroed ((x_length + y_length), negative_p));
- UNREGISTER_BIGNUM(y);
- UNREGISTER_BIGNUM(x);
bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
bignum_digit_type * end_x = (scan_x + x_length);
@@ -723,15 +724,15 @@ bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
}
/* allocates memory */
-bignum_type
-bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y,
+bignum *
+bignum_multiply_unsigned_small_factor(bignum * x, bignum_digit_type y,
int negative_p)
{
+ GC_BIGNUM(x);
+
bignum_length_type length_x = (BIGNUM_LENGTH (x));
- REGISTER_BIGNUM(x);
- bignum_type p = (allot_bignum ((length_x + 1), negative_p));
- UNREGISTER_BIGNUM(x);
+ bignum * p = (allot_bignum ((length_x + 1), negative_p));
bignum_destructive_copy (x, p);
(BIGNUM_REF (p, length_x)) = 0;
@@ -740,7 +741,7 @@ bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y,
}
void
-bignum_destructive_add(bignum_type bignum, bignum_digit_type n)
+bignum_destructive_add(bignum * bignum, bignum_digit_type n)
{
bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
bignum_digit_type digit;
@@ -764,7 +765,7 @@ bignum_destructive_add(bignum_type bignum, bignum_digit_type n)
}
void
-bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor)
+bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
{
bignum_digit_type carry = 0;
bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
@@ -802,31 +803,27 @@ bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor)
/* allocates memory */
void
-bignum_divide_unsigned_large_denominator(bignum_type numerator,
- bignum_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
+bignum_divide_unsigned_large_denominator(bignum * numerator,
+ bignum * denominator,
+ bignum * * quotient,
+ bignum * * remainder,
int q_negative_p,
int r_negative_p)
{
+ GC_BIGNUM(numerator); GC_BIGNUM(denominator);
+
bignum_length_type length_n = ((BIGNUM_LENGTH (numerator)) + 1);
bignum_length_type length_d = (BIGNUM_LENGTH (denominator));
- REGISTER_BIGNUM(numerator);
- REGISTER_BIGNUM(denominator);
-
- bignum_type q =
- ((quotient != ((bignum_type *) 0))
+ bignum * q =
+ ((quotient != ((bignum * *) 0))
? (allot_bignum ((length_n - length_d), q_negative_p))
: BIGNUM_OUT_OF_BAND);
-
- REGISTER_BIGNUM(q);
- bignum_type u = (allot_bignum (length_n, r_negative_p));
- UNREGISTER_BIGNUM(q);
-
- UNREGISTER_BIGNUM(denominator);
- UNREGISTER_BIGNUM(numerator);
-
+ GC_BIGNUM(q);
+
+ bignum * u = (allot_bignum (length_n, r_negative_p));
+ GC_BIGNUM(u);
+
int shift = 0;
BIGNUM_ASSERT (length_d > 1);
{
@@ -845,43 +842,31 @@ bignum_divide_unsigned_large_denominator(bignum_type numerator,
}
else
{
- REGISTER_BIGNUM(numerator);
- REGISTER_BIGNUM(denominator);
- REGISTER_BIGNUM(u);
- REGISTER_BIGNUM(q);
- bignum_type v = (allot_bignum (length_d, 0));
- UNREGISTER_BIGNUM(q);
- UNREGISTER_BIGNUM(u);
- UNREGISTER_BIGNUM(denominator);
- UNREGISTER_BIGNUM(numerator);
+ bignum * v = (allot_bignum (length_d, 0));
bignum_destructive_normalization (numerator, u, shift);
bignum_destructive_normalization (denominator, v, shift);
bignum_divide_unsigned_normalized (u, v, q);
- if (remainder != ((bignum_type *) 0))
+ if (remainder != ((bignum * *) 0))
bignum_destructive_unnormalization (u, shift);
}
- REGISTER_BIGNUM(u);
if(q)
q = bignum_trim (q);
- UNREGISTER_BIGNUM(u);
- REGISTER_BIGNUM(q);
u = bignum_trim (u);
- UNREGISTER_BIGNUM(q);
- if (quotient != ((bignum_type *) 0))
+ if (quotient != ((bignum * *) 0))
(*quotient) = q;
- if (remainder != ((bignum_type *) 0))
+ if (remainder != ((bignum * *) 0))
(*remainder) = u;
return;
}
void
-bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q)
+bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q)
{
bignum_length_type u_length = (BIGNUM_LENGTH (u));
bignum_length_type v_length = (BIGNUM_LENGTH (v));
@@ -1036,16 +1021,20 @@ bignum_divide_subtract(bignum_digit_type * v_start,
/* allocates memory */
void
-bignum_divide_unsigned_medium_denominator(bignum_type numerator,
+bignum_divide_unsigned_medium_denominator(bignum * numerator,
bignum_digit_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
+ bignum * * quotient,
+ bignum * * remainder,
int q_negative_p,
int r_negative_p)
{
+ GC_BIGNUM(numerator);
+
bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
bignum_length_type length_q;
- bignum_type q;
+ bignum * q = NULL;
+ GC_BIGNUM(q);
+
int shift = 0;
/* Because `bignum_digit_divide' requires a normalized denominator. */
while (denominator < (BIGNUM_RADIX / 2))
@@ -1057,20 +1046,14 @@ bignum_divide_unsigned_medium_denominator(bignum_type numerator,
{
length_q = length_n;
- REGISTER_BIGNUM(numerator);
q = (allot_bignum (length_q, q_negative_p));
- UNREGISTER_BIGNUM(numerator);
-
bignum_destructive_copy (numerator, q);
}
else
{
length_q = (length_n + 1);
- REGISTER_BIGNUM(numerator);
q = (allot_bignum (length_q, q_negative_p));
- UNREGISTER_BIGNUM(numerator);
-
bignum_destructive_normalization (numerator, q, shift);
}
{
@@ -1087,24 +1070,22 @@ bignum_divide_unsigned_medium_denominator(bignum_type numerator,
q = bignum_trim (q);
- if (remainder != ((bignum_type *) 0))
+ if (remainder != ((bignum * *) 0))
{
if (shift != 0)
r >>= shift;
- REGISTER_BIGNUM(q);
(*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- UNREGISTER_BIGNUM(q);
}
- if (quotient != ((bignum_type *) 0))
+ if (quotient != ((bignum * *) 0))
(*quotient) = q;
}
return;
}
void
-bignum_destructive_normalization(bignum_type source, bignum_type target,
+bignum_destructive_normalization(bignum * source, bignum * target,
int shift_left)
{
bignum_digit_type digit;
@@ -1114,7 +1095,7 @@ bignum_destructive_normalization(bignum_type source, bignum_type target,
bignum_digit_type * end_source = (scan_source + (BIGNUM_LENGTH (source)));
bignum_digit_type * end_target = (scan_target + (BIGNUM_LENGTH (target)));
int shift_right = (BIGNUM_DIGIT_LENGTH - shift_left);
- bignum_digit_type mask = (((CELL)1 << shift_right) - 1);
+ bignum_digit_type mask = (((cell)1 << shift_right) - 1);
while (scan_source < end_source)
{
digit = (*scan_source++);
@@ -1129,14 +1110,14 @@ bignum_destructive_normalization(bignum_type source, bignum_type target,
}
void
-bignum_destructive_unnormalization(bignum_type bignum, int shift_right)
+bignum_destructive_unnormalization(bignum * bignum, int shift_right)
{
bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
bignum_digit_type digit;
bignum_digit_type carry = 0;
int shift_left = (BIGNUM_DIGIT_LENGTH - shift_right);
- bignum_digit_type mask = (((F_FIXNUM)1 << shift_right) - 1);
+ bignum_digit_type mask = (((fixnum)1 << shift_right) - 1);
while (start < scan)
{
digit = (*--scan);
@@ -1284,27 +1265,24 @@ bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
/* allocates memory */
void
-bignum_divide_unsigned_small_denominator(bignum_type numerator,
+bignum_divide_unsigned_small_denominator(bignum * numerator,
bignum_digit_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
+ bignum * * quotient,
+ bignum * * remainder,
int q_negative_p,
int r_negative_p)
{
- REGISTER_BIGNUM(numerator);
- bignum_type q = (bignum_new_sign (numerator, q_negative_p));
- UNREGISTER_BIGNUM(numerator);
+ GC_BIGNUM(numerator);
+
+ bignum * q = (bignum_new_sign (numerator, q_negative_p));
+ GC_BIGNUM(q);
bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
q = (bignum_trim (q));
- if (remainder != ((bignum_type *) 0))
- {
- REGISTER_BIGNUM(q);
+ if (remainder != ((bignum * *) 0))
(*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- UNREGISTER_BIGNUM(q);
- }
(*quotient) = q;
@@ -1316,7 +1294,7 @@ bignum_divide_unsigned_small_denominator(bignum_type numerator,
that all digits are < BIGNUM_RADIX. */
bignum_digit_type
-bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator)
+bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
{
bignum_digit_type numerator;
bignum_digit_type remainder = 0;
@@ -1339,9 +1317,9 @@ bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator)
}
/* allocates memory */
-bignum_type
+bignum *
bignum_remainder_unsigned_small_denominator(
- bignum_type n, bignum_digit_type d, int negative_p)
+ bignum * n, bignum_digit_type d, int negative_p)
{
bignum_digit_type two_digits;
bignum_digit_type * start = (BIGNUM_START_PTR (n));
@@ -1360,34 +1338,34 @@ bignum_remainder_unsigned_small_denominator(
}
/* allocates memory */
-bignum_type
+bignum *
bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
{
if (digit == 0)
return (BIGNUM_ZERO ());
else
{
- bignum_type result = (allot_bignum (1, negative_p));
+ bignum * result = (allot_bignum (1, negative_p));
(BIGNUM_REF (result, 0)) = digit;
return (result);
}
}
/* allocates memory */
-bignum_type
+bignum *
allot_bignum(bignum_length_type length, int negative_p)
{
BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
- bignum_type result = allot_array_internal(BIGNUM_TYPE,length + 1);
+ bignum * result = allot_array_internal<bignum>(length + 1);
BIGNUM_SET_NEGATIVE_P (result, negative_p);
return (result);
}
/* allocates memory */
-bignum_type
+bignum *
allot_bignum_zeroed(bignum_length_type length, int negative_p)
{
- bignum_type result = allot_bignum(length,negative_p);
+ bignum * result = allot_bignum(length,negative_p);
bignum_digit_type * scan = (BIGNUM_START_PTR (result));
bignum_digit_type * end = (scan + length);
while (scan < end)
@@ -1396,11 +1374,11 @@ allot_bignum_zeroed(bignum_length_type length, int negative_p)
}
#define BIGNUM_REDUCE_LENGTH(source, length) \
- source = reallot_array(source,length + 1)
+ source = reallot_array(source,length + 1)
/* allocates memory */
-bignum_type
-bignum_shorten_length(bignum_type bignum, bignum_length_type length)
+bignum *
+bignum_shorten_length(bignum * bignum, bignum_length_type length)
{
bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
@@ -1413,8 +1391,8 @@ bignum_shorten_length(bignum_type bignum, bignum_length_type length)
}
/* allocates memory */
-bignum_type
-bignum_trim(bignum_type bignum)
+bignum *
+bignum_trim(bignum * bignum)
{
bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
@@ -1434,35 +1412,33 @@ bignum_trim(bignum_type bignum)
/* Copying */
/* allocates memory */
-bignum_type
-bignum_new_sign(bignum_type bignum, int negative_p)
+bignum *
+bignum_new_sign(bignum * x, int negative_p)
{
- REGISTER_BIGNUM(bignum);
- bignum_type result =
- (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
- UNREGISTER_BIGNUM(bignum);
+ GC_BIGNUM(x);
+ bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
- bignum_destructive_copy (bignum, result);
+ bignum_destructive_copy (x, result);
return (result);
}
/* allocates memory */
-bignum_type
-bignum_maybe_new_sign(bignum_type bignum, int negative_p)
+bignum *
+bignum_maybe_new_sign(bignum * x, int negative_p)
{
- if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p))
- return (bignum);
+ if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p))
+ return (x);
else
{
- bignum_type result =
- (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
- bignum_destructive_copy (bignum, result);
+ bignum * result =
+ (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+ bignum_destructive_copy (x, result);
return (result);
}
}
void
-bignum_destructive_copy(bignum_type source, bignum_type target)
+bignum_destructive_copy(bignum * source, bignum * target)
{
bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
bignum_digit_type * end_source =
@@ -1478,15 +1454,15 @@ bignum_destructive_copy(bignum_type source, bignum_type target)
*/
/* allocates memory */
-bignum_type
-bignum_bitwise_not(bignum_type x)
+bignum *
+bignum_bitwise_not(bignum * x)
{
return bignum_subtract(BIGNUM_ONE(1), x);
}
/* allocates memory */
-bignum_type
-bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n)
+bignum *
+bignum_arithmetic_shift(bignum * arg1, fixnum n)
{
if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
@@ -1499,8 +1475,8 @@ bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n)
#define XOR_OP 2
/* allocates memory */
-bignum_type
-bignum_bitwise_and(bignum_type arg1, bignum_type arg2)
+bignum *
+bignum_bitwise_and(bignum * arg1, bignum * arg2)
{
return(
(BIGNUM_NEGATIVE_P (arg1))
@@ -1514,8 +1490,8 @@ bignum_bitwise_and(bignum_type arg1, bignum_type arg2)
}
/* allocates memory */
-bignum_type
-bignum_bitwise_ior(bignum_type arg1, bignum_type arg2)
+bignum *
+bignum_bitwise_ior(bignum * arg1, bignum * arg2)
{
return(
(BIGNUM_NEGATIVE_P (arg1))
@@ -1529,8 +1505,8 @@ bignum_bitwise_ior(bignum_type arg1, bignum_type arg2)
}
/* allocates memory */
-bignum_type
-bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
+bignum *
+bignum_bitwise_xor(bignum * arg1, bignum * arg2)
{
return(
(BIGNUM_NEGATIVE_P (arg1))
@@ -1546,15 +1522,17 @@ bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
/* allocates memory */
/* ash for the magnitude */
/* assume arg1 is a big number, n is a long */
-bignum_type
-bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
+bignum *
+bignum_magnitude_ash(bignum * arg1, fixnum n)
{
- bignum_type result = NULL;
+ GC_BIGNUM(arg1);
+
+ bignum * result = NULL;
bignum_digit_type *scan1;
bignum_digit_type *scanr;
bignum_digit_type *end;
- F_FIXNUM digit_offset,bit_offset;
+ fixnum digit_offset,bit_offset;
if (BIGNUM_ZERO_P (arg1)) return (arg1);
@@ -1562,10 +1540,8 @@ bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
digit_offset = n / BIGNUM_DIGIT_LENGTH;
bit_offset = n % BIGNUM_DIGIT_LENGTH;
- REGISTER_BIGNUM(arg1);
result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
- BIGNUM_NEGATIVE_P(arg1));
- UNREGISTER_BIGNUM(arg1);
+ BIGNUM_NEGATIVE_P(arg1));
scanr = BIGNUM_START_PTR (result) + digit_offset;
scan1 = BIGNUM_START_PTR (arg1);
@@ -1587,10 +1563,8 @@ bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
digit_offset = -n / BIGNUM_DIGIT_LENGTH;
bit_offset = -n % BIGNUM_DIGIT_LENGTH;
- REGISTER_BIGNUM(arg1);
result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
- BIGNUM_NEGATIVE_P(arg1));
- UNREGISTER_BIGNUM(arg1);
+ BIGNUM_NEGATIVE_P(arg1));
scanr = BIGNUM_START_PTR (result);
scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
@@ -1610,10 +1584,12 @@ bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n)
}
/* allocates memory */
-bignum_type
-bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
+bignum *
+bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- bignum_type result;
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+
+ bignum * result;
bignum_length_type max_length;
bignum_digit_type *scan1, *end1, digit1;
@@ -1623,11 +1599,7 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
- REGISTER_BIGNUM(arg1);
- REGISTER_BIGNUM(arg2);
result = allot_bignum(max_length, 0);
- UNREGISTER_BIGNUM(arg2);
- UNREGISTER_BIGNUM(arg1);
scanr = BIGNUM_START_PTR(result);
scan1 = BIGNUM_START_PTR(arg1);
@@ -1647,10 +1619,12 @@ bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
}
/* allocates memory */
-bignum_type
-bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
+bignum *
+bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- bignum_type result;
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+
+ bignum * result;
bignum_length_type max_length;
bignum_digit_type *scan1, *end1, digit1;
@@ -1662,11 +1636,7 @@ bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
- REGISTER_BIGNUM(arg1);
- REGISTER_BIGNUM(arg2);
result = allot_bignum(max_length, neg_p);
- UNREGISTER_BIGNUM(arg2);
- UNREGISTER_BIGNUM(arg1);
scanr = BIGNUM_START_PTR(result);
scan1 = BIGNUM_START_PTR(arg1);
@@ -1702,10 +1672,12 @@ bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
}
/* allocates memory */
-bignum_type
-bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
+bignum *
+bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
{
- bignum_type result;
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+
+ bignum * result;
bignum_length_type max_length;
bignum_digit_type *scan1, *end1, digit1, carry1;
@@ -1717,11 +1689,7 @@ bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
- REGISTER_BIGNUM(arg1);
- REGISTER_BIGNUM(arg2);
result = allot_bignum(max_length, neg_p);
- UNREGISTER_BIGNUM(arg2);
- UNREGISTER_BIGNUM(arg1);
scanr = BIGNUM_START_PTR(result);
scan1 = BIGNUM_START_PTR(arg1);
@@ -1765,7 +1733,7 @@ bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
}
void
-bignum_negate_magnitude(bignum_type arg)
+bignum_negate_magnitude(bignum * arg)
{
bignum_digit_type *scan;
bignum_digit_type *end;
@@ -1793,15 +1761,15 @@ bignum_negate_magnitude(bignum_type arg)
}
/* Allocates memory */
-bignum_type
-bignum_integer_length(bignum_type bignum)
+bignum *
+bignum_integer_length(bignum * x)
{
- bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
- bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ GC_BIGNUM(x);
- REGISTER_BIGNUM(bignum);
- bignum_type result = (allot_bignum (2, 0));
- UNREGISTER_BIGNUM(bignum);
+ bignum_length_type index = ((BIGNUM_LENGTH (x)) - 1);
+ bignum_digit_type digit = (BIGNUM_REF (x, index));
+
+ bignum * result = (allot_bignum (2, 0));
(BIGNUM_REF (result, 0)) = index;
(BIGNUM_REF (result, 1)) = 0;
@@ -1816,7 +1784,7 @@ bignum_integer_length(bignum_type bignum)
/* Allocates memory */
int
-bignum_logbitp(int shift, bignum_type arg)
+bignum_logbitp(int shift, bignum * arg)
{
return((BIGNUM_NEGATIVE_P (arg))
? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
@@ -1824,7 +1792,7 @@ bignum_logbitp(int shift, bignum_type arg)
}
int
-bignum_unsigned_logbitp(int shift, bignum_type bignum)
+bignum_unsigned_logbitp(int shift, bignum * bignum)
{
bignum_length_type len = (BIGNUM_LENGTH (bignum));
int index = shift / BIGNUM_DIGIT_LENGTH;
@@ -1832,12 +1800,12 @@ bignum_unsigned_logbitp(int shift, bignum_type bignum)
return 0;
bignum_digit_type digit = (BIGNUM_REF (bignum, index));
int p = shift % BIGNUM_DIGIT_LENGTH;
- bignum_digit_type mask = ((F_FIXNUM)1) << p;
+ bignum_digit_type mask = ((fixnum)1) << p;
return (digit & mask) ? 1 : 0;
}
/* Allocates memory */
-bignum_type
+bignum *
digit_stream_to_bignum(unsigned int n_digits,
unsigned int (*producer)(unsigned int),
unsigned int radix,
@@ -1848,7 +1816,7 @@ digit_stream_to_bignum(unsigned int n_digits,
return (BIGNUM_ZERO ());
if (n_digits == 1)
{
- F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0)));
+ fixnum digit = ((fixnum) ((*producer) (0)));
return (fixnum_to_bignum (negative_p ? (- digit) : digit));
}
{
@@ -1865,7 +1833,7 @@ digit_stream_to_bignum(unsigned int n_digits,
length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
}
{
- bignum_type result = (allot_bignum_zeroed (length, negative_p));
+ bignum * result = (allot_bignum_zeroed (length, negative_p));
while ((n_digits--) > 0)
{
bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
@@ -1876,3 +1844,5 @@ digit_stream_to_bignum(unsigned int n_digits,
}
}
}
+
+}
diff --git a/vm/bignum.h b/vm/bignum.h
deleted file mode 100644
index 02309cad34..0000000000
--- a/vm/bignum.h
+++ /dev/null
@@ -1,127 +0,0 @@
-/* :tabSize=2:indentSize=2:noTabs=true:
-
-Copyright (C) 1989-1992 Massachusetts Institute of Technology
-Portions copyright (C) 2004-2007 Slava Pestov
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy and modify this software, to
-redistribute either the original software or a modified version, and
-to use this software for any purpose is granted, subject to the
-following restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-typedef F_ARRAY * bignum_type;
-#define BIGNUM_OUT_OF_BAND ((bignum_type) 0)
-
-enum bignum_comparison
-{
- bignum_comparison_equal = 0,
- bignum_comparison_less = -1,
- bignum_comparison_greater = 1
-};
-
-int bignum_equal_p(bignum_type, bignum_type);
-enum bignum_comparison bignum_compare(bignum_type, bignum_type);
-bignum_type bignum_add(bignum_type, bignum_type);
-bignum_type bignum_subtract(bignum_type, bignum_type);
-bignum_type bignum_negate(bignum_type);
-bignum_type bignum_multiply(bignum_type, bignum_type);
-void
-bignum_divide(bignum_type numerator, bignum_type denominator,
- bignum_type * quotient, bignum_type * remainder);
-bignum_type bignum_quotient(bignum_type, bignum_type);
-bignum_type bignum_remainder(bignum_type, bignum_type);
-DLLEXPORT bignum_type fixnum_to_bignum(F_FIXNUM);
-DLLEXPORT bignum_type cell_to_bignum(CELL);
-DLLEXPORT bignum_type long_long_to_bignum(s64 n);
-DLLEXPORT bignum_type ulong_long_to_bignum(u64 n);
-F_FIXNUM bignum_to_fixnum(bignum_type);
-CELL bignum_to_cell(bignum_type);
-s64 bignum_to_long_long(bignum_type);
-u64 bignum_to_ulong_long(bignum_type);
-bignum_type double_to_bignum(double);
-double bignum_to_double(bignum_type);
-
-/* Added bitwise operators. */
-
-DLLEXPORT bignum_type bignum_bitwise_not(bignum_type),
- bignum_arithmetic_shift(bignum_type, F_FIXNUM),
- bignum_bitwise_and(bignum_type, bignum_type),
- bignum_bitwise_ior(bignum_type, bignum_type),
- bignum_bitwise_xor(bignum_type, bignum_type);
-
-/* Forward references */
-int bignum_equal_p_unsigned(bignum_type, bignum_type);
-enum bignum_comparison bignum_compare_unsigned(bignum_type, bignum_type);
-bignum_type bignum_add_unsigned(bignum_type, bignum_type, int);
-bignum_type bignum_subtract_unsigned(bignum_type, bignum_type);
-bignum_type bignum_multiply_unsigned(bignum_type, bignum_type, int);
-bignum_type bignum_multiply_unsigned_small_factor
- (bignum_type, bignum_digit_type, int);
-void bignum_destructive_scale_up(bignum_type, bignum_digit_type);
-void bignum_destructive_add(bignum_type, bignum_digit_type);
-void bignum_divide_unsigned_large_denominator
- (bignum_type, bignum_type, bignum_type *, bignum_type *, int, int);
-void bignum_destructive_normalization(bignum_type, bignum_type, int);
-void bignum_destructive_unnormalization(bignum_type, int);
-void bignum_divide_unsigned_normalized(bignum_type, bignum_type, bignum_type);
-bignum_digit_type bignum_divide_subtract
- (bignum_digit_type *, bignum_digit_type *, bignum_digit_type,
- bignum_digit_type *);
-void bignum_divide_unsigned_medium_denominator
- (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int);
-bignum_digit_type bignum_digit_divide
- (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
-bignum_digit_type bignum_digit_divide_subtract
- (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
-void bignum_divide_unsigned_small_denominator
- (bignum_type, bignum_digit_type, bignum_type *, bignum_type *, int, int);
-bignum_digit_type bignum_destructive_scale_down
- (bignum_type, bignum_digit_type);
-bignum_type bignum_remainder_unsigned_small_denominator
- (bignum_type, bignum_digit_type, int);
-bignum_type bignum_digit_to_bignum(bignum_digit_type, int);
-bignum_type allot_bignum(bignum_length_type, int);
-bignum_type allot_bignum_zeroed(bignum_length_type, int);
-bignum_type bignum_shorten_length(bignum_type, bignum_length_type);
-bignum_type bignum_trim(bignum_type);
-bignum_type bignum_new_sign(bignum_type, int);
-bignum_type bignum_maybe_new_sign(bignum_type, int);
-void bignum_destructive_copy(bignum_type, bignum_type);
-
-/* Added for bitwise operations. */
-bignum_type bignum_magnitude_ash(bignum_type arg1, F_FIXNUM n);
-bignum_type bignum_pospos_bitwise_op(int op, bignum_type, bignum_type);
-bignum_type bignum_posneg_bitwise_op(int op, bignum_type, bignum_type);
-bignum_type bignum_negneg_bitwise_op(int op, bignum_type, bignum_type);
-void bignum_negate_magnitude(bignum_type);
-
-bignum_type bignum_integer_length(bignum_type arg1);
-int bignum_unsigned_logbitp(int shift, bignum_type bignum);
-int bignum_logbitp(int shift, bignum_type arg);
-bignum_type digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int),
- unsigned int radix,
- int negative_p);
diff --git a/vm/bignum.hpp b/vm/bignum.hpp
new file mode 100644
index 0000000000..296f0dce4c
--- /dev/null
+++ b/vm/bignum.hpp
@@ -0,0 +1,131 @@
+namespace factor
+{
+
+/* :tabSize=2:indentSize=2:noTabs=true:
+
+Copyright (C) 1989-1992 Massachusetts Institute of Technology
+Portions copyright (C) 2004-2009 Slava Pestov
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy and modify this software, to
+redistribute either the original software or a modified version, and
+to use this software for any purpose is granted, subject to the
+following restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#define BIGNUM_OUT_OF_BAND ((bignum *) 0)
+
+enum bignum_comparison
+{
+ bignum_comparison_equal = 0,
+ bignum_comparison_less = -1,
+ bignum_comparison_greater = 1
+};
+
+int bignum_equal_p(bignum *, bignum *);
+enum bignum_comparison bignum_compare(bignum *, bignum *);
+bignum * bignum_add(bignum *, bignum *);
+bignum * bignum_subtract(bignum *, bignum *);
+bignum * bignum_negate(bignum *);
+bignum * bignum_multiply(bignum *, bignum *);
+void
+bignum_divide(bignum * numerator, bignum * denominator,
+ bignum * * quotient, bignum * * remainder);
+bignum * bignum_quotient(bignum *, bignum *);
+bignum * bignum_remainder(bignum *, bignum *);
+bignum * fixnum_to_bignum(fixnum);
+bignum * cell_to_bignum(cell);
+bignum * long_long_to_bignum(s64 n);
+bignum * ulong_long_to_bignum(u64 n);
+fixnum bignum_to_fixnum(bignum *);
+cell bignum_to_cell(bignum *);
+s64 bignum_to_long_long(bignum *);
+u64 bignum_to_ulong_long(bignum *);
+bignum * double_to_bignum(double);
+double bignum_to_double(bignum *);
+
+/* Added bitwise operators. */
+
+bignum * bignum_bitwise_not(bignum *);
+bignum * bignum_arithmetic_shift(bignum *, fixnum);
+bignum * bignum_bitwise_and(bignum *, bignum *);
+bignum * bignum_bitwise_ior(bignum *, bignum *);
+bignum * bignum_bitwise_xor(bignum *, bignum *);
+
+/* Forward references */
+int bignum_equal_p_unsigned(bignum *, bignum *);
+enum bignum_comparison bignum_compare_unsigned(bignum *, bignum *);
+bignum * bignum_add_unsigned(bignum *, bignum *, int);
+bignum * bignum_subtract_unsigned(bignum *, bignum *);
+bignum * bignum_multiply_unsigned(bignum *, bignum *, int);
+bignum * bignum_multiply_unsigned_small_factor
+ (bignum *, bignum_digit_type, int);
+void bignum_destructive_scale_up(bignum *, bignum_digit_type);
+void bignum_destructive_add(bignum *, bignum_digit_type);
+void bignum_divide_unsigned_large_denominator
+ (bignum *, bignum *, bignum * *, bignum * *, int, int);
+void bignum_destructive_normalization(bignum *, bignum *, int);
+void bignum_destructive_unnormalization(bignum *, int);
+void bignum_divide_unsigned_normalized(bignum *, bignum *, bignum *);
+bignum_digit_type bignum_divide_subtract
+ (bignum_digit_type *, bignum_digit_type *, bignum_digit_type,
+ bignum_digit_type *);
+void bignum_divide_unsigned_medium_denominator
+ (bignum *, bignum_digit_type, bignum * *, bignum * *, int, int);
+bignum_digit_type bignum_digit_divide
+ (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
+bignum_digit_type bignum_digit_divide_subtract
+ (bignum_digit_type, bignum_digit_type, bignum_digit_type, bignum_digit_type *);
+void bignum_divide_unsigned_small_denominator
+ (bignum *, bignum_digit_type, bignum * *, bignum * *, int, int);
+bignum_digit_type bignum_destructive_scale_down
+ (bignum *, bignum_digit_type);
+bignum * bignum_remainder_unsigned_small_denominator
+ (bignum *, bignum_digit_type, int);
+bignum * bignum_digit_to_bignum(bignum_digit_type, int);
+bignum * allot_bignum(bignum_length_type, int);
+bignum * allot_bignum_zeroed(bignum_length_type, int);
+bignum * bignum_shorten_length(bignum *, bignum_length_type);
+bignum * bignum_trim(bignum *);
+bignum * bignum_new_sign(bignum *, int);
+bignum * bignum_maybe_new_sign(bignum *, int);
+void bignum_destructive_copy(bignum *, bignum *);
+
+/* Added for bitwise operations. */
+bignum * bignum_magnitude_ash(bignum * arg1, fixnum n);
+bignum * bignum_pospos_bitwise_op(int op, bignum *, bignum *);
+bignum * bignum_posneg_bitwise_op(int op, bignum *, bignum *);
+bignum * bignum_negneg_bitwise_op(int op, bignum *, bignum *);
+void bignum_negate_magnitude(bignum *);
+
+bignum * bignum_integer_length(bignum * arg1);
+int bignum_unsigned_logbitp(int shift, bignum * bignum);
+int bignum_logbitp(int shift, bignum * arg);
+bignum * digit_stream_to_bignum(unsigned int n_digits,
+ unsigned int (*producer)(unsigned int),
+ unsigned int radix,
+ int negative_p);
+
+}
diff --git a/vm/bignumint.h b/vm/bignumint.hpp
similarity index 83%
rename from vm/bignumint.h
rename to vm/bignumint.hpp
index a101473fc6..0b743b35a4 100644
--- a/vm/bignumint.h
+++ b/vm/bignumint.hpp
@@ -33,6 +33,9 @@ Technology nor of any adaptation thereof in any advertising,
promotional, or sales literature without prior written consent from
MIT in each case. */
+namespace factor
+{
+
/* Internal Interface to Bignum Code */
#undef BIGNUM_ZERO_P
#undef BIGNUM_NEGATIVE_P
@@ -42,11 +45,11 @@ MIT in each case. */
definition is `CHAR_BIT', which is defined in the Ansi C header
file "limits.h". */
-typedef F_FIXNUM bignum_digit_type;
-typedef F_FIXNUM bignum_length_type;
+typedef fixnum bignum_digit_type;
+typedef fixnum bignum_length_type;
/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
-#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)AREF(bignum,0))
+#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)(bignum + 1))
/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
#define BIGNUM_EXCEPTION abort
@@ -54,18 +57,18 @@ typedef F_FIXNUM bignum_length_type;
#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
-#define BIGNUM_RADIX (((CELL) 1) << BIGNUM_DIGIT_LENGTH)
-#define BIGNUM_RADIX_ROOT (((CELL) 1) << BIGNUM_HALF_DIGIT_LENGTH)
+#define BIGNUM_RADIX (bignum_digit_type)(((cell) 1) << BIGNUM_DIGIT_LENGTH)
+#define BIGNUM_RADIX_ROOT (((bignum_digit_type) 1) << BIGNUM_HALF_DIGIT_LENGTH)
#define BIGNUM_DIGIT_MASK (BIGNUM_RADIX - 1)
#define BIGNUM_HALF_DIGIT_MASK (BIGNUM_RADIX_ROOT - 1)
#define BIGNUM_START_PTR(bignum) \
((BIGNUM_TO_POINTER (bignum)) + 1)
-#define BIGNUM_LENGTH(bignum) (untag_fixnum_fast((bignum)->capacity) - 1)
+#define BIGNUM_LENGTH(bignum) (untag_fixnum((bignum)->capacity) - 1)
-#define BIGNUM_NEGATIVE_P(bignum) (array_nth(bignum,0) != 0)
-#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
+#define BIGNUM_NEGATIVE_P(bignum) (bignum->data()[0] != 0)
+#define BIGNUM_SET_NEGATIVE_P(bignum,neg) (bignum->data()[0] = neg)
#define BIGNUM_ZERO_P(bignum) \
((BIGNUM_LENGTH (bignum)) == 0)
@@ -75,9 +78,9 @@ typedef F_FIXNUM bignum_length_type;
/* These definitions are here to facilitate caching of the constants
0, 1, and -1. */
-#define BIGNUM_ZERO() untag_object(bignum_zero)
+#define BIGNUM_ZERO() untag<bignum>(bignum_zero)
#define BIGNUM_ONE(neg_p) \
- untag_object(neg_p ? bignum_neg_one : bignum_pos_one)
+ untag<bignum>(neg_p ? bignum_neg_one : bignum_pos_one)
#define HD_LOW(digit) ((digit) & BIGNUM_HALF_DIGIT_MASK)
#define HD_HIGH(digit) ((digit) >> BIGNUM_HALF_DIGIT_LENGTH)
@@ -98,3 +101,5 @@ typedef F_FIXNUM bignum_length_type;
}
#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */
+
+}
diff --git a/vm/booleans.cpp b/vm/booleans.cpp
new file mode 100644
index 0000000000..8407e10099
--- /dev/null
+++ b/vm/booleans.cpp
@@ -0,0 +1,16 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+VM_C_API void box_boolean(bool value)
+{
+ dpush(value ? T : F);
+}
+
+VM_C_API bool to_boolean(cell value)
+{
+ return value != F;
+}
+
+}
diff --git a/vm/booleans.hpp b/vm/booleans.hpp
new file mode 100644
index 0000000000..ea16e0536b
--- /dev/null
+++ b/vm/booleans.hpp
@@ -0,0 +1,12 @@
+namespace factor
+{
+
+inline static cell tag_boolean(cell untagged)
+{
+ return (untagged ? T : F);
+}
+
+VM_C_API void box_boolean(bool value);
+VM_C_API bool to_boolean(cell value);
+
+}
diff --git a/vm/byte_arrays.cpp b/vm/byte_arrays.cpp
new file mode 100644
index 0000000000..2eda3f33c4
--- /dev/null
+++ b/vm/byte_arrays.cpp
@@ -0,0 +1,64 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+byte_array *allot_byte_array(cell size)
+{
+ byte_array *array = allot_array_internal<byte_array>(size);
+ memset(array + 1,0,size);
+ return array;
+}
+
+PRIMITIVE(byte_array)
+{
+ cell size = unbox_array_size();
+ dpush(tag<byte_array>(allot_byte_array(size)));
+}
+
+PRIMITIVE(uninitialized_byte_array)
+{
+ cell size = unbox_array_size();
+ dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
+}
+
+PRIMITIVE(resize_byte_array)
+{
+ byte_array *array = untag_check<byte_array>(dpop());
+ cell capacity = unbox_array_size();
+ dpush(tag<byte_array>(reallot_array(array,capacity)));
+}
+
+void growable_byte_array::append_bytes(void *elts, cell len)
+{
+ cell new_size = count + len;
+
+ if(new_size >= array_capacity(elements.untagged()))
+ elements = reallot_array(elements.untagged(),new_size * 2);
+
+ memcpy(&elements->data<u8>()[count],elts,len);
+
+ count += len;
+}
+
+void growable_byte_array::append_byte_array(cell byte_array_)
+{
+ gc_root<byte_array> byte_array(byte_array_);
+
+ cell len = array_capacity(byte_array.untagged());
+ cell new_size = count + len;
+
+ if(new_size >= array_capacity(elements.untagged()))
+ elements = reallot_array(elements.untagged(),new_size * 2);
+
+ memcpy(&elements->data<u8>()[count],byte_array->data<u8>(),len);
+
+ count += len;
+}
+
+void growable_byte_array::trim()
+{
+ elements = reallot_array(elements.untagged(),count);
+}
+
+}
diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp
new file mode 100644
index 0000000000..ebdc6bead6
--- /dev/null
+++ b/vm/byte_arrays.hpp
@@ -0,0 +1,23 @@
+namespace factor
+{
+
+byte_array *allot_byte_array(cell size);
+
+PRIMITIVE(byte_array);
+PRIMITIVE(uninitialized_byte_array);
+PRIMITIVE(resize_byte_array);
+
+/* Macros to simulate a byte vector in C */
+struct growable_byte_array {
+ cell count;
+ gc_root<byte_array> elements;
+
+ growable_byte_array() : count(0), elements(allot_byte_array(2)) { }
+
+ void append_bytes(void *elts, cell len);
+ void append_byte_array(cell elts);
+
+ void trim();
+};
+
+}
diff --git a/vm/callstack.c b/vm/callstack.c
deleted file mode 100755
index b7e6b946bb..0000000000
--- a/vm/callstack.c
+++ /dev/null
@@ -1,230 +0,0 @@
-#include "master.h"
-
-/* called before entry into Factor code. */
-F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom)
-{
- stack_chain->callstack_bottom = callstack_bottom;
-}
-
-void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator)
-{
- F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
-
- while((CELL)frame >= top)
- {
- F_STACK_FRAME *next = frame_successor(frame);
- iterator(frame);
- frame = next;
- }
-}
-
-void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator)
-{
- CELL top = (CELL)FIRST_STACK_FRAME(stack);
- CELL bottom = top + untag_fixnum_fast(stack->length);
-
- iterate_callstack(top,bottom,iterator);
-}
-
-F_CALLSTACK *allot_callstack(CELL size)
-{
- F_CALLSTACK *callstack = allot_object(
- CALLSTACK_TYPE,
- callstack_size(size));
- callstack->length = tag_fixnum(size);
- return callstack;
-}
-
-F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom)
-{
- F_STACK_FRAME *frame = bottom - 1;
-
- while(frame >= top)
- frame = frame_successor(frame);
-
- return frame + 1;
-}
-
-/* We ignore the topmost frame, the one calling 'callstack',
-so that set-callstack doesn't get stuck in an infinite loop.
-
-This means that if 'callstack' is called in tail position, we
-will have popped a necessary frame... however this word is only
-called by continuation implementation, and user code shouldn't
-be calling it at all, so we leave it as it is for now. */
-F_STACK_FRAME *capture_start(void)
-{
- F_STACK_FRAME *frame = stack_chain->callstack_bottom - 1;
- while(frame >= stack_chain->callstack_top
- && frame_successor(frame) >= stack_chain->callstack_top)
- {
- frame = frame_successor(frame);
- }
- return frame + 1;
-}
-
-void primitive_callstack(void)
-{
- F_STACK_FRAME *top = capture_start();
- F_STACK_FRAME *bottom = stack_chain->callstack_bottom;
-
- F_FIXNUM size = (CELL)bottom - (CELL)top;
- if(size < 0)
- size = 0;
-
- F_CALLSTACK *callstack = allot_callstack(size);
- memcpy(FIRST_STACK_FRAME(callstack),top,size);
- dpush(tag_object(callstack));
-}
-
-void primitive_set_callstack(void)
-{
- F_CALLSTACK *stack = untag_callstack(dpop());
-
- set_callstack(stack_chain->callstack_bottom,
- FIRST_STACK_FRAME(stack),
- untag_fixnum_fast(stack->length),
- memcpy);
-
- /* We cannot return here ... */
- critical_error("Bug in set_callstack()",0);
-}
-
-F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame)
-{
- return (F_CODE_BLOCK *)frame->xt - 1;
-}
-
-CELL frame_type(F_STACK_FRAME *frame)
-{
- return frame_code(frame)->block.type;
-}
-
-CELL frame_executing(F_STACK_FRAME *frame)
-{
- F_CODE_BLOCK *compiled = frame_code(frame);
- if(compiled->literals == F || !stack_traces_p())
- return F;
- else
- {
- F_ARRAY *array = untag_object(compiled->literals);
- return array_nth(array,0);
- }
-}
-
-F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
-{
- if(frame->size == 0)
- critical_error("Stack frame has zero size",(CELL)frame);
- return (F_STACK_FRAME *)((CELL)frame - frame->size);
-}
-
-CELL frame_scan(F_STACK_FRAME *frame)
-{
- if(frame_type(frame) == QUOTATION_TYPE)
- {
- CELL quot = frame_executing(frame);
- if(quot == F)
- return F;
- else
- {
- XT return_addr = FRAME_RETURN_ADDRESS(frame);
- XT quot_xt = (XT)(frame_code(frame) + 1);
-
- return tag_fixnum(quot_code_offset_to_scan(
- quot,(CELL)(return_addr - quot_xt)));
- }
- }
- else
- return F;
-}
-
-/* C doesn't have closures... */
-static CELL frame_count;
-
-void count_stack_frame(F_STACK_FRAME *frame)
-{
- frame_count += 2;
-}
-
-static CELL frame_index;
-static F_ARRAY *array;
-
-void stack_frame_to_array(F_STACK_FRAME *frame)
-{
- set_array_nth(array,frame_index++,frame_executing(frame));
- set_array_nth(array,frame_index++,frame_scan(frame));
-}
-
-void primitive_callstack_to_array(void)
-{
- F_CALLSTACK *stack = untag_callstack(dpop());
-
- frame_count = 0;
- iterate_callstack_object(stack,count_stack_frame);
-
- REGISTER_UNTAGGED(stack);
- array = allot_array_internal(ARRAY_TYPE,frame_count);
- UNREGISTER_UNTAGGED(stack);
-
- frame_index = 0;
- iterate_callstack_object(stack,stack_frame_to_array);
-
- dpush(tag_object(array));
-}
-
-F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack)
-{
- F_STACK_FRAME *top = FIRST_STACK_FRAME(callstack);
- CELL bottom = (CELL)top + untag_fixnum_fast(callstack->length);
-
- F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1;
-
- while(frame >= top && frame_successor(frame) >= top)
- frame = frame_successor(frame);
-
- return frame;
-}
-
-/* Some primitives implementing a limited form of callstack mutation.
-Used by the single stepper. */
-void primitive_innermost_stack_frame_quot(void)
-{
- F_STACK_FRAME *inner = innermost_stack_frame(
- untag_callstack(dpop()));
- type_check(QUOTATION_TYPE,frame_executing(inner));
-
- dpush(frame_executing(inner));
-}
-
-void primitive_innermost_stack_frame_scan(void)
-{
- F_STACK_FRAME *inner = innermost_stack_frame(
- untag_callstack(dpop()));
- type_check(QUOTATION_TYPE,frame_executing(inner));
-
- dpush(frame_scan(inner));
-}
-
-void primitive_set_innermost_stack_frame_quot(void)
-{
- F_CALLSTACK *callstack = untag_callstack(dpop());
- F_QUOTATION *quot = untag_quotation(dpop());
-
- REGISTER_UNTAGGED(callstack);
- REGISTER_UNTAGGED(quot);
-
- jit_compile(tag_object(quot),true);
-
- UNREGISTER_UNTAGGED(quot);
- UNREGISTER_UNTAGGED(callstack);
-
- F_STACK_FRAME *inner = innermost_stack_frame(callstack);
- type_check(QUOTATION_TYPE,frame_executing(inner));
-
- CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt;
-
- inner->xt = quot->xt;
-
- FRAME_RETURN_ADDRESS(inner) = quot->xt + offset;
-}
diff --git a/vm/callstack.cpp b/vm/callstack.cpp
new file mode 100755
index 0000000000..56056426dd
--- /dev/null
+++ b/vm/callstack.cpp
@@ -0,0 +1,230 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+static void check_frame(stack_frame *frame)
+{
+#ifdef FACTOR_DEBUG
+ check_code_pointer((cell)frame->xt);
+ assert(frame->size != 0);
+#endif
+}
+
+void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
+{
+ stack_frame *frame = (stack_frame *)bottom - 1;
+
+ while((cell)frame >= top)
+ {
+ iterator(frame);
+ frame = frame_successor(frame);
+ }
+}
+
+void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
+{
+ cell top = (cell)FIRST_STACK_FRAME(stack);
+ cell bottom = top + untag_fixnum(stack->length);
+
+ iterate_callstack(top,bottom,iterator);
+}
+
+callstack *allot_callstack(cell size)
+{
+ callstack *stack = allot<callstack>(callstack_size(size));
+ stack->length = tag_fixnum(size);
+ return stack;
+}
+
+stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom)
+{
+ stack_frame *frame = bottom - 1;
+
+ while(frame >= top)
+ frame = frame_successor(frame);
+
+ return frame + 1;
+}
+
+/* We ignore the topmost frame, the one calling 'callstack',
+so that set-callstack doesn't get stuck in an infinite loop.
+
+This means that if 'callstack' is called in tail position, we
+will have popped a necessary frame... however this word is only
+called by continuation implementation, and user code shouldn't
+be calling it at all, so we leave it as it is for now. */
+stack_frame *capture_start(void)
+{
+ stack_frame *frame = stack_chain->callstack_bottom - 1;
+ while(frame >= stack_chain->callstack_top
+ && frame_successor(frame) >= stack_chain->callstack_top)
+ {
+ frame = frame_successor(frame);
+ }
+ return frame + 1;
+}
+
+PRIMITIVE(callstack)
+{
+ stack_frame *top = capture_start();
+ stack_frame *bottom = stack_chain->callstack_bottom;
+
+ fixnum size = (cell)bottom - (cell)top;
+ if(size < 0)
+ size = 0;
+
+ callstack *stack = allot_callstack(size);
+ memcpy(FIRST_STACK_FRAME(stack),top,size);
+ dpush(tag<callstack>(stack));
+}
+
+PRIMITIVE(set_callstack)
+{
+ callstack *stack = untag_check<callstack>(dpop());
+
+ set_callstack(stack_chain->callstack_bottom,
+ FIRST_STACK_FRAME(stack),
+ untag_fixnum(stack->length),
+ memcpy);
+
+ /* We cannot return here ... */
+ critical_error("Bug in set_callstack()",0);
+}
+
+code_block *frame_code(stack_frame *frame)
+{
+ check_frame(frame);
+ return (code_block *)frame->xt - 1;
+}
+
+cell frame_type(stack_frame *frame)
+{
+ return frame_code(frame)->block.type;
+}
+
+cell frame_executing(stack_frame *frame)
+{
+ code_block *compiled = frame_code(frame);
+ if(compiled->literals == F || !stack_traces_p())
+ return F;
+ else
+ {
+ array *literals = untag<array>(compiled->literals);
+ return array_nth(literals,0);
+ }
+}
+
+stack_frame *frame_successor(stack_frame *frame)
+{
+ check_frame(frame);
+ return (stack_frame *)((cell)frame - frame->size);
+}
+
+cell frame_scan(stack_frame *frame)
+{
+ if(frame_type(frame) == QUOTATION_TYPE)
+ {
+ cell quot = frame_executing(frame);
+ if(quot == F)
+ return F;
+ else
+ {
+ char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame);
+ char *quot_xt = (char *)(frame_code(frame) + 1);
+
+ return tag_fixnum(quot_code_offset_to_scan(
+ quot,(cell)(return_addr - quot_xt)));
+ }
+ }
+ else
+ return F;
+}
+
+/* C doesn't have closures... */
+static cell frame_count;
+
+void count_stack_frame(stack_frame *frame)
+{
+ frame_count += 2;
+}
+
+static cell frame_index;
+static array *frames;
+
+void stack_frame_to_array(stack_frame *frame)
+{
+ set_array_nth(frames,frame_index++,frame_executing(frame));
+ set_array_nth(frames,frame_index++,frame_scan(frame));
+}
+
+PRIMITIVE(callstack_to_array)
+{
+ gc_root<callstack> callstack(dpop());
+
+ frame_count = 0;
+ iterate_callstack_object(callstack.untagged(),count_stack_frame);
+
+ frames = allot_array_internal<array>(frame_count);
+
+ frame_index = 0;
+ iterate_callstack_object(callstack.untagged(),stack_frame_to_array);
+
+ dpush(tag<array>(frames));
+}
+
+stack_frame *innermost_stack_frame(callstack *callstack)
+{
+ stack_frame *top = FIRST_STACK_FRAME(callstack);
+ cell bottom = (cell)top + untag_fixnum(callstack->length);
+
+ stack_frame *frame = (stack_frame *)bottom - 1;
+
+ while(frame >= top && frame_successor(frame) >= top)
+ frame = frame_successor(frame);
+
+ return frame;
+}
+
+stack_frame *innermost_stack_frame_quot(callstack *callstack)
+{
+ stack_frame *inner = innermost_stack_frame(callstack);
+ tagged<quotation>(frame_executing(inner)).untag_check();
+ return inner;
+}
+
+/* Some primitives implementing a limited form of callstack mutation.
+Used by the single stepper. */
+PRIMITIVE(innermost_stack_frame_quot)
+{
+ dpush(frame_executing(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
+}
+
+PRIMITIVE(innermost_stack_frame_scan)
+{
+ dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
+}
+
+PRIMITIVE(set_innermost_stack_frame_quot)
+{
+ gc_root<callstack> callstack(dpop());
+ gc_root<quotation> quot(dpop());
+
+ callstack.untag_check();
+ quot.untag_check();
+
+ jit_compile(quot.value(),true);
+
+ stack_frame *inner = innermost_stack_frame_quot(callstack.untagged());
+ cell offset = (char *)FRAME_RETURN_ADDRESS(inner) - (char *)inner->xt;
+ inner->xt = quot->xt;
+ FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
+}
+
+/* called before entry into Factor code. */
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom)
+{
+ stack_chain->callstack_bottom = callstack_bottom;
+}
+
+}
diff --git a/vm/callstack.h b/vm/callstack.h
deleted file mode 100755
index 3c13e7b1cd..0000000000
--- a/vm/callstack.h
+++ /dev/null
@@ -1,21 +0,0 @@
-F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom);
-
-#define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1)
-
-typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame);
-
-F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom);
-void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator);
-void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator);
-F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame);
-F_CODE_BLOCK *frame_code(F_STACK_FRAME *frame);
-CELL frame_executing(F_STACK_FRAME *frame);
-CELL frame_scan(F_STACK_FRAME *frame);
-CELL frame_type(F_STACK_FRAME *frame);
-
-void primitive_callstack(void);
-void primitive_set_callstack(void);
-void primitive_callstack_to_array(void);
-void primitive_innermost_stack_frame_quot(void);
-void primitive_innermost_stack_frame_scan(void);
-void primitive_set_innermost_stack_frame_quot(void);
diff --git a/vm/callstack.hpp b/vm/callstack.hpp
new file mode 100755
index 0000000000..efdbc7ba05
--- /dev/null
+++ b/vm/callstack.hpp
@@ -0,0 +1,31 @@
+namespace factor
+{
+
+inline static cell callstack_size(cell size)
+{
+ return sizeof(callstack) + size;
+}
+
+#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1)
+
+typedef void (*CALLSTACK_ITER)(stack_frame *frame);
+
+stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
+void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator);
+void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator);
+stack_frame *frame_successor(stack_frame *frame);
+code_block *frame_code(stack_frame *frame);
+cell frame_executing(stack_frame *frame);
+cell frame_scan(stack_frame *frame);
+cell frame_type(stack_frame *frame);
+
+PRIMITIVE(callstack);
+PRIMITIVE(set_callstack);
+PRIMITIVE(callstack_to_array);
+PRIMITIVE(innermost_stack_frame_quot);
+PRIMITIVE(innermost_stack_frame_scan);
+PRIMITIVE(set_innermost_stack_frame_quot);
+
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom);
+
+}
diff --git a/vm/code_block.c b/vm/code_block.c
deleted file mode 100644
index 8dda8bc16e..0000000000
--- a/vm/code_block.c
+++ /dev/null
@@ -1,449 +0,0 @@
-#include "master.h"
-
-void flush_icache_for(F_CODE_BLOCK *block)
-{
- flush_icache((CELL)block,block->block.size);
-}
-
-void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
-{
- if(compiled->relocation != F)
- {
- F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
-
- CELL index = stack_traces_p() ? 1 : 0;
-
- F_REL *rel = (F_REL *)(relocation + 1);
- F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
-
- while(rel < rel_end)
- {
- iter(*rel,index,compiled);
-
- switch(REL_TYPE(*rel))
- {
- case RT_PRIMITIVE:
- case RT_XT:
- case RT_IMMEDIATE:
- case RT_HERE:
- index++;
- break;
- case RT_DLSYM:
- index += 2;
- break;
- case RT_THIS:
- case RT_STACK_CHAIN:
- break;
- default:
- critical_error("Bad rel type",*rel);
- return; /* Can't happen */
- }
-
- rel++;
- }
- }
-}
-
-/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
-INLINE void store_address_2_2(CELL cell, CELL value)
-{
- put(cell - CELLS,((get(cell - CELLS) & ~0xffff) | ((value >> 16) & 0xffff)));
- put(cell,((get(cell) & ~0xffff) | (value & 0xffff)));
-}
-
-/* Store a value into a bitfield of a PowerPC instruction */
-INLINE void store_address_masked(CELL cell, F_FIXNUM value, CELL mask, F_FIXNUM shift)
-{
- /* This is unaccurate but good enough */
- F_FIXNUM test = (F_FIXNUM)mask >> 1;
- if(value <= -test || value >= test)
- critical_error("Value does not fit inside relocation",0);
-
- u32 original = *(u32*)cell;
- original &= ~mask;
- *(u32*)cell = (original | ((value >> shift) & mask));
-}
-
-/* Perform a fixup on a code block */
-void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value)
-{
- F_FIXNUM relative_value = absolute_value - offset;
-
- switch(class)
- {
- case RC_ABSOLUTE_CELL:
- put(offset,absolute_value);
- break;
- case RC_ABSOLUTE:
- *(u32*)offset = absolute_value;
- break;
- case RC_RELATIVE:
- *(u32*)offset = relative_value - sizeof(u32);
- break;
- case RC_ABSOLUTE_PPC_2_2:
- store_address_2_2(offset,absolute_value);
- break;
- case RC_RELATIVE_PPC_2:
- store_address_masked(offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
- break;
- case RC_RELATIVE_PPC_3:
- store_address_masked(offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
- break;
- case RC_RELATIVE_ARM_3:
- store_address_masked(offset,relative_value - CELLS * 2,
- REL_RELATIVE_ARM_3_MASK,2);
- break;
- case RC_INDIRECT_ARM:
- store_address_masked(offset,relative_value - CELLS,
- REL_INDIRECT_ARM_MASK,0);
- break;
- case RC_INDIRECT_ARM_PC:
- store_address_masked(offset,relative_value - CELLS * 2,
- REL_INDIRECT_ARM_MASK,0);
- break;
- default:
- critical_error("Bad rel class",class);
- break;
- }
-}
-
-void update_literal_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
-{
- if(REL_TYPE(rel) == RT_IMMEDIATE)
- {
- CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
- F_ARRAY *literals = untag_object(compiled->literals);
- F_FIXNUM absolute_value = array_nth(literals,index);
- store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
- }
-}
-
-/* Update pointers to literals from compiled code. */
-void update_literal_references(F_CODE_BLOCK *compiled)
-{
- iterate_relocations(compiled,update_literal_references_step);
- flush_icache_for(compiled);
-}
-
-/* Copy all literals referenced from a code block to newspace. Only for
-aging and nursery collections */
-void copy_literal_references(F_CODE_BLOCK *compiled)
-{
- if(collecting_gen >= compiled->block.last_scan)
- {
- if(collecting_accumulation_gen_p())
- compiled->block.last_scan = collecting_gen;
- else
- compiled->block.last_scan = collecting_gen + 1;
-
- /* initialize chase pointer */
- CELL scan = newspace->here;
-
- copy_handle(&compiled->literals);
- copy_handle(&compiled->relocation);
-
- /* do some tracing so that all reachable literals are now
- at their final address */
- copy_reachable_objects(scan,&newspace->here);
-
- update_literal_references(compiled);
- }
-}
-
-CELL object_xt(CELL obj)
-{
- if(type_of(obj) == WORD_TYPE)
- return (CELL)untag_word(obj)->xt;
- else
- return (CELL)untag_quotation(obj)->xt;
-}
-
-void update_word_references_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
-{
- if(REL_TYPE(rel) == RT_XT)
- {
- CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
- F_ARRAY *literals = untag_object(compiled->literals);
- CELL xt = object_xt(array_nth(literals,index));
- store_address_in_code_block(REL_CLASS(rel),offset,xt);
- }
-}
-
-/* Relocate new code blocks completely; updating references to literals,
-dlsyms, and words. For all other words in the code heap, we only need
-to update references to other words, without worrying about literals
-or dlsyms. */
-void update_word_references(F_CODE_BLOCK *compiled)
-{
- if(compiled->block.needs_fixup)
- relocate_code_block(compiled);
- else
- {
- iterate_relocations(compiled,update_word_references_step);
- flush_icache_for(compiled);
- }
-}
-
-/* Update references to words. This is done after a new code block
-is added to the heap. */
-
-/* Mark all literals referenced from a word XT. Only for tenured
-collections */
-void mark_code_block(F_CODE_BLOCK *compiled)
-{
- mark_block(&compiled->block);
-
- copy_handle(&compiled->literals);
- copy_handle(&compiled->relocation);
-}
-
-void mark_stack_frame_step(F_STACK_FRAME *frame)
-{
- mark_code_block(frame_code(frame));
-}
-
-/* Mark code blocks executing in currently active stack frames. */
-void mark_active_blocks(F_CONTEXT *stacks)
-{
- if(collecting_gen == TENURED)
- {
- CELL top = (CELL)stacks->callstack_top;
- CELL bottom = (CELL)stacks->callstack_bottom;
-
- iterate_callstack(top,bottom,mark_stack_frame_step);
- }
-}
-
-void mark_object_code_block(CELL scan)
-{
- F_WORD *word;
- F_QUOTATION *quot;
- F_CALLSTACK *stack;
-
- switch(object_type(scan))
- {
- case WORD_TYPE:
- word = (F_WORD *)scan;
- mark_code_block(word->code);
- if(word->profiling)
- mark_code_block(word->profiling);
- break;
- case QUOTATION_TYPE:
- quot = (F_QUOTATION *)scan;
- if(quot->compiledp != F)
- mark_code_block(quot->code);
- break;
- case CALLSTACK_TYPE:
- stack = (F_CALLSTACK *)scan;
- iterate_callstack_object(stack,mark_stack_frame_step);
- break;
- }
-}
-
-/* References to undefined symbols are patched up to call this function on
-image load */
-void undefined_symbol(void)
-{
- general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
-}
-
-/* Look up an external library symbol referenced by a compiled code block */
-void *get_rel_symbol(F_ARRAY *literals, CELL index)
-{
- CELL symbol = array_nth(literals,index);
- CELL library = array_nth(literals,index + 1);
-
- F_DLL *dll = (library == F ? NULL : untag_dll(library));
-
- if(dll != NULL && !dll->dll)
- return undefined_symbol;
-
- if(type_of(symbol) == BYTE_ARRAY_TYPE)
- {
- F_SYMBOL *name = alien_offset(symbol);
- void *sym = ffi_dlsym(dll,name);
-
- if(sym)
- return sym;
- }
- else if(type_of(symbol) == ARRAY_TYPE)
- {
- CELL i;
- F_ARRAY *names = untag_object(symbol);
- for(i = 0; i < array_capacity(names); i++)
- {
- F_SYMBOL *name = alien_offset(array_nth(names,i));
- void *sym = ffi_dlsym(dll,name);
-
- if(sym)
- return sym;
- }
- }
-
- return undefined_symbol;
-}
-
-/* Compute an address to store at a relocation */
-void relocate_code_block_step(F_REL rel, CELL index, F_CODE_BLOCK *compiled)
-{
- CELL offset = REL_OFFSET(rel) + (CELL)(compiled + 1);
- F_ARRAY *literals = untag_object(compiled->literals);
- F_FIXNUM absolute_value;
-
- switch(REL_TYPE(rel))
- {
- case RT_PRIMITIVE:
- absolute_value = (CELL)primitives[to_fixnum(array_nth(literals,index))];
- break;
- case RT_DLSYM:
- absolute_value = (CELL)get_rel_symbol(literals,index);
- break;
- case RT_IMMEDIATE:
- absolute_value = array_nth(literals,index);
- break;
- case RT_XT:
- absolute_value = object_xt(array_nth(literals,index));
- break;
- case RT_HERE:
- absolute_value = offset + (short)to_fixnum(array_nth(literals,index));
- break;
- case RT_THIS:
- absolute_value = (CELL)(compiled + 1);
- break;
- case RT_STACK_CHAIN:
- absolute_value = (CELL)&stack_chain;
- break;
- default:
- critical_error("Bad rel type",rel);
- return; /* Can't happen */
- }
-
- store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
-}
-
-/* Perform all fixups on a code block */
-void relocate_code_block(F_CODE_BLOCK *compiled)
-{
- compiled->block.last_scan = NURSERY;
- compiled->block.needs_fixup = false;
- iterate_relocations(compiled,relocate_code_block_step);
- flush_icache_for(compiled);
-}
-
-/* Fixup labels. This is done at compile time, not image load time */
-void fixup_labels(F_ARRAY *labels, CELL code_format, F_CODE_BLOCK *compiled)
-{
- CELL i;
- CELL size = array_capacity(labels);
-
- for(i = 0; i < size; i += 3)
- {
- CELL class = to_fixnum(array_nth(labels,i));
- CELL offset = to_fixnum(array_nth(labels,i + 1));
- CELL target = to_fixnum(array_nth(labels,i + 2));
-
- store_address_in_code_block(class,
- offset + (CELL)(compiled + 1),
- target + (CELL)(compiled + 1));
- }
-}
-
-/* Write a sequence of integers to memory, with 'format' bytes per integer */
-void deposit_integers(CELL here, F_ARRAY *array, CELL format)
-{
- CELL count = array_capacity(array);
- CELL i;
-
- for(i = 0; i < count; i++)
- {
- F_FIXNUM value = to_fixnum(array_nth(array,i));
- if(format == 1)
- bput(here + i,value);
- else if(format == sizeof(unsigned int))
- *(unsigned int *)(here + format * i) = value;
- else if(format == sizeof(CELL))
- *(CELL *)(here + format * i) = value;
- else
- critical_error("Bad format in deposit_integers()",format);
- }
-}
-
-CELL compiled_code_format(void)
-{
- return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
-}
-
-/* Might GC */
-F_CODE_BLOCK *allot_code_block(CELL size)
-{
- F_BLOCK *block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
-
- /* If allocation failed, do a code GC */
- if(block == NULL)
- {
- gc();
- block = heap_allot(&code_heap,size + sizeof(F_CODE_BLOCK));
-
- /* Insufficient room even after code GC, give up */
- if(block == NULL)
- {
- CELL used, total_free, max_free;
- heap_usage(&code_heap,&used,&total_free,&max_free);
-
- print_string("Code heap stats:\n");
- print_string("Used: "); print_cell(used); nl();
- print_string("Total free space: "); print_cell(total_free); nl();
- print_string("Largest free block: "); print_cell(max_free); nl();
- fatal_error("Out of memory in add-compiled-block",0);
- }
- }
-
- return (F_CODE_BLOCK *)block;
-}
-
-/* Might GC */
-F_CODE_BLOCK *add_code_block(
- CELL type,
- F_ARRAY *code,
- F_ARRAY *labels,
- CELL relocation,
- CELL literals)
-{
- CELL code_format = compiled_code_format();
- CELL code_length = align8(array_capacity(code) * code_format);
-
- REGISTER_ROOT(literals);
- REGISTER_ROOT(relocation);
- REGISTER_UNTAGGED(code);
- REGISTER_UNTAGGED(labels);
-
- F_CODE_BLOCK *compiled = allot_code_block(code_length);
-
- UNREGISTER_UNTAGGED(labels);
- UNREGISTER_UNTAGGED(code);
- UNREGISTER_ROOT(relocation);
- UNREGISTER_ROOT(literals);
-
- /* slight space optimization */
- if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_object(literals)) == 0)
- literals = F;
-
- /* compiled header */
- compiled->block.type = type;
- compiled->block.last_scan = NURSERY;
- compiled->block.needs_fixup = true;
- compiled->literals = literals;
- compiled->relocation = relocation;
-
- /* code */
- deposit_integers((CELL)(compiled + 1),code,code_format);
-
- /* fixup labels */
- if(labels) fixup_labels(labels,code_format,compiled);
-
- /* next time we do a minor GC, we have to scan the code heap for
- literals */
- last_code_heap_scan = NURSERY;
-
- return compiled;
-}
diff --git a/vm/code_block.cpp b/vm/code_block.cpp
new file mode 100644
index 0000000000..5ebb162f7e
--- /dev/null
+++ b/vm/code_block.cpp
@@ -0,0 +1,505 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+void flush_icache_for(code_block *block)
+{
+ flush_icache((cell)block,block->block.size);
+}
+
+void iterate_relocations(code_block *compiled, relocation_iterator iter)
+{
+ if(compiled->relocation != F)
+ {
+ byte_array *relocation = untag<byte_array>(compiled->relocation);
+
+ cell index = stack_traces_p() ? 1 : 0;
+
+ cell length = array_capacity(relocation) / sizeof(relocation_entry);
+ for(cell i = 0; i < length; i++)
+ {
+ relocation_entry rel = relocation->data<relocation_entry>()[i];
+
+ iter(rel,index,compiled);
+
+ switch(REL_TYPE(rel))
+ {
+ case RT_PRIMITIVE:
+ case RT_XT:
+ case RT_XT_DIRECT:
+ case RT_IMMEDIATE:
+ case RT_HERE:
+ case RT_UNTAGGED:
+ index++;
+ break;
+ case RT_DLSYM:
+ index += 2;
+ break;
+ case RT_THIS:
+ case RT_STACK_CHAIN:
+ break;
+ default:
+ critical_error("Bad rel type",rel);
+ return; /* Can't happen */
+ }
+ }
+ }
+}
+
+/* Store a 32-bit value into a PowerPC LIS/ORI sequence */
+static void store_address_2_2(cell *ptr, cell value)
+{
+ ptr[-1] = ((ptr[-1] & ~0xffff) | ((value >> 16) & 0xffff));
+ ptr[ 0] = ((ptr[ 0] & ~0xffff) | (value & 0xffff));
+}
+
+/* Store a value into a bitfield of a PowerPC instruction */
+static void store_address_masked(cell *ptr, fixnum value, cell mask, fixnum shift)
+{
+ /* This is unaccurate but good enough */
+ fixnum test = (fixnum)mask >> 1;
+ if(value <= -test || value >= test)
+ critical_error("Value does not fit inside relocation",0);
+
+ *ptr = ((*ptr & ~mask) | ((value >> shift) & mask));
+}
+
+/* Perform a fixup on a code block */
+void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
+{
+ fixnum relative_value = absolute_value - offset;
+
+ switch(klass)
+ {
+ case RC_ABSOLUTE_CELL:
+ *(cell *)offset = absolute_value;
+ break;
+ case RC_ABSOLUTE:
+ *(u32*)offset = absolute_value;
+ break;
+ case RC_RELATIVE:
+ *(u32*)offset = relative_value - sizeof(u32);
+ break;
+ case RC_ABSOLUTE_PPC_2_2:
+ store_address_2_2((cell *)offset,absolute_value);
+ break;
+ case RC_RELATIVE_PPC_2:
+ store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
+ break;
+ case RC_RELATIVE_PPC_3:
+ store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
+ break;
+ case RC_RELATIVE_ARM_3:
+ store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
+ REL_RELATIVE_ARM_3_MASK,2);
+ break;
+ case RC_INDIRECT_ARM:
+ store_address_masked((cell *)offset,relative_value - sizeof(cell),
+ REL_INDIRECT_ARM_MASK,0);
+ break;
+ case RC_INDIRECT_ARM_PC:
+ store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
+ REL_INDIRECT_ARM_MASK,0);
+ break;
+ default:
+ critical_error("Bad rel class",klass);
+ break;
+ }
+}
+
+void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
+{
+ if(REL_TYPE(rel) == RT_IMMEDIATE)
+ {
+ cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+ array *literals = untag<array>(compiled->literals);
+ fixnum absolute_value = array_nth(literals,index);
+ store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+ }
+}
+
+/* Update pointers to literals from compiled code. */
+void update_literal_references(code_block *compiled)
+{
+ if(!compiled->block.needs_fixup)
+ {
+ iterate_relocations(compiled,update_literal_references_step);
+ flush_icache_for(compiled);
+ }
+}
+
+/* Copy all literals referenced from a code block to newspace. Only for
+aging and nursery collections */
+void copy_literal_references(code_block *compiled)
+{
+ if(collecting_gen >= compiled->block.last_scan)
+ {
+ if(collecting_accumulation_gen_p())
+ compiled->block.last_scan = collecting_gen;
+ else
+ compiled->block.last_scan = collecting_gen + 1;
+
+ /* initialize chase pointer */
+ cell scan = newspace->here;
+
+ copy_handle(&compiled->literals);
+ copy_handle(&compiled->relocation);
+
+ /* do some tracing so that all reachable literals are now
+ at their final address */
+ copy_reachable_objects(scan,&newspace->here);
+
+ update_literal_references(compiled);
+ }
+}
+
+void *object_xt(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case WORD_TYPE:
+ return untag<word>(obj)->xt;
+ case QUOTATION_TYPE:
+ return untag<quotation>(obj)->xt;
+ default:
+ critical_error("Expected word or quotation",obj);
+ return NULL;
+ }
+}
+
+void *word_direct_xt(word *w)
+{
+ cell tagged_quot = w->direct_entry_def;
+ if(tagged_quot == F || max_pic_size == 0)
+ return w->xt;
+ else
+ {
+ quotation *quot = untag<quotation>(tagged_quot);
+ if(quot->compiledp == F)
+ return w->xt;
+ else
+ return quot->xt;
+ }
+}
+
+void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
+{
+ relocation_type type = REL_TYPE(rel);
+ if(type == RT_XT || type == RT_XT_DIRECT)
+ {
+ cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+ array *literals = untag<array>(compiled->literals);
+ cell obj = array_nth(literals,index);
+
+ void *xt;
+ if(type == RT_XT)
+ xt = object_xt(obj);
+ else
+ xt = word_direct_xt(untag<word>(obj));
+
+ store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt);
+ }
+}
+
+/* Relocate new code blocks completely; updating references to literals,
+dlsyms, and words. For all other words in the code heap, we only need
+to update references to other words, without worrying about literals
+or dlsyms. */
+void update_word_references(code_block *compiled)
+{
+ if(compiled->block.needs_fixup)
+ relocate_code_block(compiled);
+ /* update_word_references() is always applied to every block in
+ the code heap. Since it resets all call sites to point to
+ their canonical XT (cold entry point for non-tail calls,
+ standard entry point for tail calls), it means that no PICs
+ are referenced after this is done. So instead of polluting
+ the code heap with dead PICs that will be freed on the next
+ GC, we add them to the free list immediately. */
+ else if(compiled->block.type == PIC_TYPE)
+ {
+ fflush(stdout);
+ heap_free(&code,&compiled->block);
+ }
+ else
+ {
+ iterate_relocations(compiled,update_word_references_step);
+ flush_icache_for(compiled);
+ }
+}
+
+void update_literal_and_word_references(code_block *compiled)
+{
+ update_literal_references(compiled);
+ update_word_references(compiled);
+}
+
+static void check_code_address(cell address)
+{
+#ifdef FACTOR_DEBUG
+ assert(address >= code.seg->start && address < code.seg->end);
+#endif
+}
+
+/* Update references to words. This is done after a new code block
+is added to the heap. */
+
+/* Mark all literals referenced from a word XT. Only for tenured
+collections */
+void mark_code_block(code_block *compiled)
+{
+ check_code_address((cell)compiled);
+
+ mark_block(&compiled->block);
+
+ copy_handle(&compiled->literals);
+ copy_handle(&compiled->relocation);
+}
+
+void mark_stack_frame_step(stack_frame *frame)
+{
+ mark_code_block(frame_code(frame));
+}
+
+/* Mark code blocks executing in currently active stack frames. */
+void mark_active_blocks(context *stacks)
+{
+ if(collecting_gen == TENURED)
+ {
+ cell top = (cell)stacks->callstack_top;
+ cell bottom = (cell)stacks->callstack_bottom;
+
+ iterate_callstack(top,bottom,mark_stack_frame_step);
+ }
+}
+
+void mark_object_code_block(object *object)
+{
+ switch(object->h.hi_tag())
+ {
+ case WORD_TYPE:
+ {
+ word *w = (word *)object;
+ if(w->code)
+ mark_code_block(w->code);
+ if(w->profiling)
+ mark_code_block(w->profiling);
+ break;
+ }
+ case QUOTATION_TYPE:
+ {
+ quotation *q = (quotation *)object;
+ if(q->compiledp != F)
+ mark_code_block(q->code);
+ break;
+ }
+ case CALLSTACK_TYPE:
+ {
+ callstack *stack = (callstack *)object;
+ iterate_callstack_object(stack,mark_stack_frame_step);
+ break;
+ }
+ }
+}
+
+/* References to undefined symbols are patched up to call this function on
+image load */
+void undefined_symbol(void)
+{
+ general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
+}
+
+/* Look up an external library symbol referenced by a compiled code block */
+void *get_rel_symbol(array *literals, cell index)
+{
+ cell symbol = array_nth(literals,index);
+ cell library = array_nth(literals,index + 1);
+
+ dll *d = (library == F ? NULL : untag<dll>(library));
+
+ if(d != NULL && !d->dll)
+ return (void *)undefined_symbol;
+
+ switch(tagged<object>(symbol).type())
+ {
+ case BYTE_ARRAY_TYPE:
+ {
+ symbol_char *name = alien_offset(symbol);
+ void *sym = ffi_dlsym(d,name);
+
+ if(sym)
+ return sym;
+ else
+ {
+ printf("%s\n",name);
+ return (void *)undefined_symbol;
+ }
+ }
+ case ARRAY_TYPE:
+ {
+ cell i;
+ array *names = untag<array>(symbol);
+ for(i = 0; i < array_capacity(names); i++)
+ {
+ symbol_char *name = alien_offset(array_nth(names,i));
+ void *sym = ffi_dlsym(d,name);
+
+ if(sym)
+ return sym;
+ }
+ return (void *)undefined_symbol;
+ }
+ default:
+ critical_error("Bad symbol specifier",symbol);
+ return (void *)undefined_symbol;
+ }
+}
+
+/* Compute an address to store at a relocation */
+void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled)
+{
+#ifdef FACTOR_DEBUG
+ tagged<array>(compiled->literals).untag_check();
+ tagged<byte_array>(compiled->relocation).untag_check();
+#endif
+
+ cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+ array *literals = untag<array>(compiled->literals);
+ fixnum absolute_value;
+
+ switch(REL_TYPE(rel))
+ {
+ case RT_PRIMITIVE:
+ absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))];
+ break;
+ case RT_DLSYM:
+ absolute_value = (cell)get_rel_symbol(literals,index);
+ break;
+ case RT_IMMEDIATE:
+ absolute_value = array_nth(literals,index);
+ break;
+ case RT_XT:
+ absolute_value = (cell)object_xt(array_nth(literals,index));
+ break;
+ case RT_XT_DIRECT:
+ absolute_value = (cell)word_direct_xt(untag<word>(array_nth(literals,index)));
+ break;
+ case RT_HERE:
+ absolute_value = offset + (short)untag_fixnum(array_nth(literals,index));
+ break;
+ case RT_THIS:
+ absolute_value = (cell)(compiled + 1);
+ break;
+ case RT_STACK_CHAIN:
+ absolute_value = (cell)&stack_chain;
+ break;
+ case RT_UNTAGGED:
+ absolute_value = untag_fixnum(array_nth(literals,index));
+ break;
+ default:
+ critical_error("Bad rel type",rel);
+ return; /* Can't happen */
+ }
+
+ store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+}
+
+/* Perform all fixups on a code block */
+void relocate_code_block(code_block *compiled)
+{
+ compiled->block.last_scan = NURSERY;
+ compiled->block.needs_fixup = false;
+ iterate_relocations(compiled,relocate_code_block_step);
+ flush_icache_for(compiled);
+}
+
+/* Fixup labels. This is done at compile time, not image load time */
+void fixup_labels(array *labels, code_block *compiled)
+{
+ cell i;
+ cell size = array_capacity(labels);
+
+ for(i = 0; i < size; i += 3)
+ {
+ cell klass = untag_fixnum(array_nth(labels,i));
+ cell offset = untag_fixnum(array_nth(labels,i + 1));
+ cell target = untag_fixnum(array_nth(labels,i + 2));
+
+ store_address_in_code_block(klass,
+ offset + (cell)(compiled + 1),
+ target + (cell)(compiled + 1));
+ }
+}
+
+/* Might GC */
+code_block *allot_code_block(cell size)
+{
+ heap_block *block = heap_allot(&code,size + sizeof(code_block));
+
+ /* If allocation failed, do a code GC */
+ if(block == NULL)
+ {
+ gc();
+ block = heap_allot(&code,size + sizeof(code_block));
+
+ /* Insufficient room even after code GC, give up */
+ if(block == NULL)
+ {
+ cell used, total_free, max_free;
+ heap_usage(&code,&used,&total_free,&max_free);
+
+ print_string("Code heap stats:\n");
+ print_string("Used: "); print_cell(used); nl();
+ print_string("Total free space: "); print_cell(total_free); nl();
+ print_string("Largest free block: "); print_cell(max_free); nl();
+ fatal_error("Out of memory in add-compiled-block",0);
+ }
+ }
+
+ return (code_block *)block;
+}
+
+/* Might GC */
+code_block *add_code_block(
+ cell type,
+ cell code_,
+ cell labels_,
+ cell relocation_,
+ cell literals_)
+{
+ gc_root<byte_array> code(code_);
+ gc_root<object> labels(labels_);
+ gc_root<byte_array> relocation(relocation_);
+ gc_root<array> literals(literals_);
+
+ cell code_length = align8(array_capacity(code.untagged()));
+ code_block *compiled = allot_code_block(code_length);
+
+ /* compiled header */
+ compiled->block.type = type;
+ compiled->block.last_scan = NURSERY;
+ compiled->block.needs_fixup = true;
+ compiled->relocation = relocation.value();
+
+ /* slight space optimization */
+ if(literals.type() == ARRAY_TYPE && array_capacity(literals.untagged()) == 0)
+ compiled->literals = F;
+ else
+ compiled->literals = literals.value();
+
+ /* code */
+ memcpy(compiled + 1,code.untagged() + 1,code_length);
+
+ /* fixup labels */
+ if(labels.value() != F)
+ fixup_labels(labels.as<array>().untagged(),compiled);
+
+ /* next time we do a minor GC, we have to scan the code heap for
+ literals */
+ last_code_heap_scan = NURSERY;
+
+ return compiled;
+}
+
+}
diff --git a/vm/code_block.h b/vm/code_block.h
deleted file mode 100644
index cb8ebf5e19..0000000000
--- a/vm/code_block.h
+++ /dev/null
@@ -1,88 +0,0 @@
-typedef enum {
- /* arg is a primitive number */
- RT_PRIMITIVE,
- /* arg is a literal table index, holding an array pair (symbol/dll) */
- RT_DLSYM,
- /* a pointer to a compiled word reference */
- RT_DISPATCH,
- /* a compiled word reference */
- RT_XT,
- /* current offset */
- RT_HERE,
- /* current code block */
- RT_THIS,
- /* immediate literal */
- RT_IMMEDIATE,
- /* address of stack_chain var */
- RT_STACK_CHAIN
-} F_RELTYPE;
-
-typedef enum {
- /* absolute address in a 64-bit location */
- RC_ABSOLUTE_CELL,
- /* absolute address in a 32-bit location */
- RC_ABSOLUTE,
- /* relative address in a 32-bit location */
- RC_RELATIVE,
- /* relative address in a PowerPC LIS/ORI sequence */
- RC_ABSOLUTE_PPC_2_2,
- /* relative address in a PowerPC LWZ/STW/BC instruction */
- RC_RELATIVE_PPC_2,
- /* relative address in a PowerPC B/BL instruction */
- RC_RELATIVE_PPC_3,
- /* relative address in an ARM B/BL instruction */
- RC_RELATIVE_ARM_3,
- /* pointer to address in an ARM LDR/STR instruction */
- RC_INDIRECT_ARM,
- /* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
- RC_INDIRECT_ARM_PC
-} F_RELCLASS;
-
-#define REL_RELATIVE_PPC_2_MASK 0xfffc
-#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
-#define REL_INDIRECT_ARM_MASK 0xfff
-#define REL_RELATIVE_ARM_3_MASK 0xffffff
-
-/* code relocation table consists of a table of entries for each fixup */
-typedef u32 F_REL;
-#define REL_TYPE(r) (((r) & 0xf0000000) >> 28)
-#define REL_CLASS(r) (((r) & 0x0f000000) >> 24)
-#define REL_OFFSET(r) ((r) & 0x00ffffff)
-
-void flush_icache_for(F_CODE_BLOCK *compiled);
-
-typedef void (*RELOCATION_ITERATOR)(F_REL rel, CELL index, F_CODE_BLOCK *compiled);
-
-void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter);
-
-void store_address_in_code_block(CELL class, CELL offset, F_FIXNUM absolute_value);
-
-void relocate_code_block(F_CODE_BLOCK *compiled);
-
-void update_literal_references(F_CODE_BLOCK *compiled);
-
-void copy_literal_references(F_CODE_BLOCK *compiled);
-
-void update_word_references(F_CODE_BLOCK *compiled);
-
-void mark_code_block(F_CODE_BLOCK *compiled);
-
-void mark_active_blocks(F_CONTEXT *stacks);
-
-void mark_object_code_block(CELL scan);
-
-void relocate_code_block(F_CODE_BLOCK *relocating);
-
-CELL compiled_code_format(void);
-
-INLINE bool stack_traces_p(void)
-{
- return userenv[STACK_TRACES_ENV] != F;
-}
-
-F_CODE_BLOCK *add_code_block(
- CELL type,
- F_ARRAY *code,
- F_ARRAY *labels,
- CELL relocation,
- CELL literals);
diff --git a/vm/code_block.hpp b/vm/code_block.hpp
new file mode 100644
index 0000000000..9689ea5419
--- /dev/null
+++ b/vm/code_block.hpp
@@ -0,0 +1,92 @@
+namespace factor
+{
+
+enum relocation_type {
+ /* arg is a primitive number */
+ RT_PRIMITIVE,
+ /* arg is a literal table index, holding an array pair (symbol/dll) */
+ RT_DLSYM,
+ /* a pointer to a compiled word reference */
+ RT_DISPATCH,
+ /* a word's general entry point XT */
+ RT_XT,
+ /* a word's direct entry point XT */
+ RT_XT_DIRECT,
+ /* current offset */
+ RT_HERE,
+ /* current code block */
+ RT_THIS,
+ /* immediate literal */
+ RT_IMMEDIATE,
+ /* address of stack_chain var */
+ RT_STACK_CHAIN,
+ /* untagged fixnum literal */
+ RT_UNTAGGED,
+};
+
+enum relocation_class {
+ /* absolute address in a 64-bit location */
+ RC_ABSOLUTE_CELL,
+ /* absolute address in a 32-bit location */
+ RC_ABSOLUTE,
+ /* relative address in a 32-bit location */
+ RC_RELATIVE,
+ /* relative address in a PowerPC LIS/ORI sequence */
+ RC_ABSOLUTE_PPC_2_2,
+ /* relative address in a PowerPC LWZ/STW/BC instruction */
+ RC_RELATIVE_PPC_2,
+ /* relative address in a PowerPC B/BL instruction */
+ RC_RELATIVE_PPC_3,
+ /* relative address in an ARM B/BL instruction */
+ RC_RELATIVE_ARM_3,
+ /* pointer to address in an ARM LDR/STR instruction */
+ RC_INDIRECT_ARM,
+ /* pointer to address in an ARM LDR/STR instruction offset by 8 bytes */
+ RC_INDIRECT_ARM_PC
+};
+
+#define REL_RELATIVE_PPC_2_MASK 0xfffc
+#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
+#define REL_INDIRECT_ARM_MASK 0xfff
+#define REL_RELATIVE_ARM_3_MASK 0xffffff
+
+/* code relocation table consists of a table of entries for each fixup */
+typedef u32 relocation_entry;
+#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28)
+#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24)
+#define REL_OFFSET(r) ((r) & 0x00ffffff)
+
+void flush_icache_for(code_block *compiled);
+
+typedef void (*relocation_iterator)(relocation_entry rel, cell index, code_block *compiled);
+
+void iterate_relocations(code_block *compiled, relocation_iterator iter);
+
+void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value);
+
+void relocate_code_block(code_block *compiled);
+
+void update_literal_references(code_block *compiled);
+
+void copy_literal_references(code_block *compiled);
+
+void update_word_references(code_block *compiled);
+
+void update_literal_and_word_references(code_block *compiled);
+
+void mark_code_block(code_block *compiled);
+
+void mark_active_blocks(context *stacks);
+
+void mark_object_code_block(object *scan);
+
+void relocate_code_block(code_block *relocating);
+
+inline static bool stack_traces_p(void)
+{
+ return userenv[STACK_TRACES_ENV] != F;
+}
+
+code_block *add_code_block(cell type, cell code, cell labels, cell relocation, cell literals);
+
+}
diff --git a/vm/code_gc.c b/vm/code_gc.c
deleted file mode 100755
index c3c5bc9a10..0000000000
--- a/vm/code_gc.c
+++ /dev/null
@@ -1,280 +0,0 @@
-#include "master.h"
-
-/* This malloc-style heap code is reasonably generic. Maybe in the future, it
-will be used for the data heap too, if we ever get incremental
-mark/sweep/compact GC. */
-void new_heap(F_HEAP *heap, CELL size)
-{
- heap->segment = alloc_segment(align_page(size));
- if(!heap->segment)
- fatal_error("Out of memory in new_heap",size);
- heap->free_list = NULL;
-}
-
-/* If there is no previous block, next_free becomes the head of the free list,
-else its linked in */
-INLINE void update_free_list(F_HEAP *heap, F_FREE_BLOCK *prev, F_FREE_BLOCK *next_free)
-{
- if(prev)
- prev->next_free = next_free;
- else
- heap->free_list = next_free;
-}
-
-/* Called after reading the code heap from the image file, and after code GC.
-
-In the former case, we must add a large free block from compiling.base + size to
-compiling.limit. */
-void build_free_list(F_HEAP *heap, CELL size)
-{
- F_BLOCK *prev = NULL;
- F_FREE_BLOCK *prev_free = NULL;
- F_BLOCK *scan = first_block(heap);
- F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size);
-
- /* Add all free blocks to the free list */
- while(scan && scan < (F_BLOCK *)end)
- {
- switch(scan->status)
- {
- case B_FREE:
- update_free_list(heap,prev_free,(F_FREE_BLOCK *)scan);
- prev_free = (F_FREE_BLOCK *)scan;
- break;
- case B_ALLOCATED:
- break;
- default:
- critical_error("Invalid scan->status",(CELL)scan);
- break;
- }
-
- prev = scan;
- scan = next_block(heap,scan);
- }
-
- /* If there is room at the end of the heap, add a free block. This
- branch is only taken after loading a new image, not after code GC */
- if((CELL)(end + 1) <= heap->segment->end)
- {
- end->block.status = B_FREE;
- end->block.size = heap->segment->end - (CELL)end;
- end->next_free = NULL;
-
- /* add final free block */
- update_free_list(heap,prev_free,end);
- }
- /* This branch is taken if the newly loaded image fits exactly, or
- after code GC */
- else
- {
- /* even if there's no room at the end of the heap for a new
- free block, we might have to jigger it up by a few bytes in
- case prev + prev->size */
- if(prev)
- prev->size = heap->segment->end - (CELL)prev;
-
- /* this is the last free block */
- update_free_list(heap,prev_free,NULL);
- }
-
-}
-
-/* Allocate a block of memory from the mark and sweep GC heap */
-F_BLOCK *heap_allot(F_HEAP *heap, CELL size)
-{
- F_FREE_BLOCK *prev = NULL;
- F_FREE_BLOCK *scan = heap->free_list;
-
- size = (size + 31) & ~31;
-
- while(scan)
- {
- if(scan->block.status != B_FREE)
- critical_error("Invalid block in free list",(CELL)scan);
-
- if(scan->block.size < size)
- {
- prev = scan;
- scan = scan->next_free;
- continue;
- }
-
- /* we found a candidate block */
- F_FREE_BLOCK *next_free;
-
- if(scan->block.size - size <= sizeof(F_BLOCK) * 2)
- {
- /* too small to be split */
- next_free = scan->next_free;
- }
- else
- {
- /* split the block in two */
- F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + size);
- split->block.status = B_FREE;
- split->block.size = scan->block.size - size;
- split->next_free = scan->next_free;
- scan->block.size = size;
- next_free = split;
- }
-
- /* update the free list */
- update_free_list(heap,prev,next_free);
-
- /* this is our new block */
- scan->block.status = B_ALLOCATED;
- return &scan->block;
- }
-
- return NULL;
-}
-
-void mark_block(F_BLOCK *block)
-{
- /* If already marked, do nothing */
- switch(block->status)
- {
- case B_MARKED:
- return;
- case B_ALLOCATED:
- block->status = B_MARKED;
- break;
- default:
- critical_error("Marking the wrong block",(CELL)block);
- break;
- }
-}
-
-/* If in the middle of code GC, we have to grow the heap, data GC restarts from
-scratch, so we have to unmark any marked blocks. */
-void unmark_marked(F_HEAP *heap)
-{
- F_BLOCK *scan = first_block(heap);
-
- while(scan)
- {
- if(scan->status == B_MARKED)
- scan->status = B_ALLOCATED;
-
- scan = next_block(heap,scan);
- }
-}
-
-/* After code GC, all referenced code blocks have status set to B_MARKED, so any
-which are allocated and not marked can be reclaimed. */
-void free_unmarked(F_HEAP *heap)
-{
- F_BLOCK *prev = NULL;
- F_BLOCK *scan = first_block(heap);
-
- while(scan)
- {
- switch(scan->status)
- {
- case B_ALLOCATED:
- if(prev && prev->status == B_FREE)
- prev->size += scan->size;
- else
- {
- scan->status = B_FREE;
- prev = scan;
- }
- break;
- case B_FREE:
- if(prev && prev->status == B_FREE)
- prev->size += scan->size;
- break;
- case B_MARKED:
- scan->status = B_ALLOCATED;
- prev = scan;
- break;
- default:
- critical_error("Invalid scan->status",(CELL)scan);
- }
-
- scan = next_block(heap,scan);
- }
-
- build_free_list(heap,heap->segment->size);
-}
-
-/* Compute total sum of sizes of free blocks, and size of largest free block */
-void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free)
-{
- *used = 0;
- *total_free = 0;
- *max_free = 0;
-
- F_BLOCK *scan = first_block(heap);
-
- while(scan)
- {
- switch(scan->status)
- {
- case B_ALLOCATED:
- *used += scan->size;
- break;
- case B_FREE:
- *total_free += scan->size;
- if(scan->size > *max_free)
- *max_free = scan->size;
- break;
- default:
- critical_error("Invalid scan->status",(CELL)scan);
- }
-
- scan = next_block(heap,scan);
- }
-}
-
-/* The size of the heap, not including the last block if it's free */
-CELL heap_size(F_HEAP *heap)
-{
- F_BLOCK *scan = first_block(heap);
-
- while(next_block(heap,scan) != NULL)
- scan = next_block(heap,scan);
-
- /* this is the last block in the heap, and it is free */
- if(scan->status == B_FREE)
- return (CELL)scan - heap->segment->start;
- /* otherwise the last block is allocated */
- else
- return heap->segment->size;
-}
-
-/* Compute where each block is going to go, after compaction */
-CELL compute_heap_forwarding(F_HEAP *heap)
-{
- F_BLOCK *scan = first_block(heap);
- CELL address = (CELL)first_block(heap);
-
- while(scan)
- {
- if(scan->status == B_ALLOCATED)
- {
- scan->forwarding = (F_BLOCK *)address;
- address += scan->size;
- }
- else if(scan->status == B_MARKED)
- critical_error("Why is the block marked?",0);
-
- scan = next_block(heap,scan);
- }
-
- return address - heap->segment->start;
-}
-
-void compact_heap(F_HEAP *heap)
-{
- F_BLOCK *scan = first_block(heap);
-
- while(scan)
- {
- F_BLOCK *next = next_block(heap,scan);
-
- if(scan->status == B_ALLOCATED && scan != scan->forwarding)
- memcpy(scan->forwarding,scan,scan->size);
- scan = next;
- }
-}
diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp
new file mode 100755
index 0000000000..b86d08cf52
--- /dev/null
+++ b/vm/code_gc.cpp
@@ -0,0 +1,341 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+static void clear_free_list(heap *heap)
+{
+ memset(&heap->free,0,sizeof(heap_free_list));
+}
+
+/* This malloc-style heap code is reasonably generic. Maybe in the future, it
+will be used for the data heap too, if we ever get incremental
+mark/sweep/compact GC. */
+void new_heap(heap *heap, cell size)
+{
+ heap->seg = alloc_segment(align_page(size));
+ if(!heap->seg)
+ fatal_error("Out of memory in new_heap",size);
+
+ clear_free_list(heap);
+}
+
+static void add_to_free_list(heap *heap, free_heap_block *block)
+{
+ if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ {
+ int index = block->block.size / BLOCK_SIZE_INCREMENT;
+ block->next_free = heap->free.small_blocks[index];
+ heap->free.small_blocks[index] = block;
+ }
+ else
+ {
+ block->next_free = heap->free.large_blocks;
+ heap->free.large_blocks = block;
+ }
+}
+
+/* Called after reading the code heap from the image file, and after code GC.
+
+In the former case, we must add a large free block from compiling.base + size to
+compiling.limit. */
+void build_free_list(heap *heap, cell size)
+{
+ heap_block *prev = NULL;
+
+ clear_free_list(heap);
+
+ size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+
+ heap_block *scan = first_block(heap);
+ free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
+
+ /* Add all free blocks to the free list */
+ while(scan && scan < (heap_block *)end)
+ {
+ switch(scan->status)
+ {
+ case B_FREE:
+ add_to_free_list(heap,(free_heap_block *)scan);
+ break;
+ case B_ALLOCATED:
+ break;
+ default:
+ critical_error("Invalid scan->status",(cell)scan);
+ break;
+ }
+
+ prev = scan;
+ scan = next_block(heap,scan);
+ }
+
+ /* If there is room at the end of the heap, add a free block. This
+ branch is only taken after loading a new image, not after code GC */
+ if((cell)(end + 1) <= heap->seg->end)
+ {
+ end->block.status = B_FREE;
+ end->block.size = heap->seg->end - (cell)end;
+
+ /* add final free block */
+ add_to_free_list(heap,end);
+ }
+ /* This branch is taken if the newly loaded image fits exactly, or
+ after code GC */
+ else
+ {
+ /* even if there's no room at the end of the heap for a new
+ free block, we might have to jigger it up by a few bytes in
+ case prev + prev->size */
+ if(prev) prev->size = heap->seg->end - (cell)prev;
+ }
+
+}
+
+static void assert_free_block(free_heap_block *block)
+{
+ if(block->block.status != B_FREE)
+ critical_error("Invalid block in free list",(cell)block);
+}
+
+static free_heap_block *find_free_block(heap *heap, cell size)
+{
+ cell attempt = size;
+
+ while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ {
+ int index = attempt / BLOCK_SIZE_INCREMENT;
+ free_heap_block *block = heap->free.small_blocks[index];
+ if(block)
+ {
+ assert_free_block(block);
+ heap->free.small_blocks[index] = block->next_free;
+ return block;
+ }
+
+ attempt *= 2;
+ }
+
+ free_heap_block *prev = NULL;
+ free_heap_block *block = heap->free.large_blocks;
+
+ while(block)
+ {
+ assert_free_block(block);
+ if(block->block.size >= size)
+ {
+ if(prev)
+ prev->next_free = block->next_free;
+ else
+ heap->free.large_blocks = block->next_free;
+ return block;
+ }
+
+ prev = block;
+ block = block->next_free;
+ }
+
+ return NULL;
+}
+
+static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size)
+{
+ if(block->block.size != size )
+ {
+ /* split the block in two */
+ free_heap_block *split = (free_heap_block *)((cell)block + size);
+ split->block.status = B_FREE;
+ split->block.size = block->block.size - size;
+ split->next_free = block->next_free;
+ block->block.size = size;
+ add_to_free_list(heap,split);
+ }
+
+ return block;
+}
+
+/* Allocate a block of memory from the mark and sweep GC heap */
+heap_block *heap_allot(heap *heap, cell size)
+{
+ size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+
+ free_heap_block *block = find_free_block(heap,size);
+ if(block)
+ {
+ block = split_free_block(heap,block,size);
+
+ block->block.status = B_ALLOCATED;
+ return &block->block;
+ }
+ else
+ return NULL;
+}
+
+/* Deallocates a block manually */
+void heap_free(heap *heap, heap_block *block)
+{
+ block->status = B_FREE;
+ add_to_free_list(heap,(free_heap_block *)block);
+}
+
+void mark_block(heap_block *block)
+{
+ /* If already marked, do nothing */
+ switch(block->status)
+ {
+ case B_MARKED:
+ return;
+ case B_ALLOCATED:
+ block->status = B_MARKED;
+ break;
+ default:
+ critical_error("Marking the wrong block",(cell)block);
+ break;
+ }
+}
+
+/* If in the middle of code GC, we have to grow the heap, data GC restarts from
+scratch, so we have to unmark any marked blocks. */
+void unmark_marked(heap *heap)
+{
+ heap_block *scan = first_block(heap);
+
+ while(scan)
+ {
+ if(scan->status == B_MARKED)
+ scan->status = B_ALLOCATED;
+
+ scan = next_block(heap,scan);
+ }
+}
+
+/* After code GC, all referenced code blocks have status set to B_MARKED, so any
+which are allocated and not marked can be reclaimed. */
+void free_unmarked(heap *heap, heap_iterator iter)
+{
+ clear_free_list(heap);
+
+ heap_block *prev = NULL;
+ heap_block *scan = first_block(heap);
+
+ while(scan)
+ {
+ switch(scan->status)
+ {
+ case B_ALLOCATED:
+ if(secure_gc)
+ memset(scan + 1,0,scan->size - sizeof(heap_block));
+
+ if(prev && prev->status == B_FREE)
+ prev->size += scan->size;
+ else
+ {
+ scan->status = B_FREE;
+ prev = scan;
+ }
+ break;
+ case B_FREE:
+ if(prev && prev->status == B_FREE)
+ prev->size += scan->size;
+ else
+ prev = scan;
+ break;
+ case B_MARKED:
+ if(prev && prev->status == B_FREE)
+ add_to_free_list(heap,(free_heap_block *)prev);
+ scan->status = B_ALLOCATED;
+ prev = scan;
+ iter(scan);
+ break;
+ default:
+ critical_error("Invalid scan->status",(cell)scan);
+ }
+
+ scan = next_block(heap,scan);
+ }
+
+ if(prev && prev->status == B_FREE)
+ add_to_free_list(heap,(free_heap_block *)prev);
+}
+
+/* Compute total sum of sizes of free blocks, and size of largest free block */
+void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free)
+{
+ *used = 0;
+ *total_free = 0;
+ *max_free = 0;
+
+ heap_block *scan = first_block(heap);
+
+ while(scan)
+ {
+ switch(scan->status)
+ {
+ case B_ALLOCATED:
+ *used += scan->size;
+ break;
+ case B_FREE:
+ *total_free += scan->size;
+ if(scan->size > *max_free)
+ *max_free = scan->size;
+ break;
+ default:
+ critical_error("Invalid scan->status",(cell)scan);
+ }
+
+ scan = next_block(heap,scan);
+ }
+}
+
+/* The size of the heap, not including the last block if it's free */
+cell heap_size(heap *heap)
+{
+ heap_block *scan = first_block(heap);
+
+ while(next_block(heap,scan) != NULL)
+ scan = next_block(heap,scan);
+
+ /* this is the last block in the heap, and it is free */
+ if(scan->status == B_FREE)
+ return (cell)scan - heap->seg->start;
+ /* otherwise the last block is allocated */
+ else
+ return heap->seg->size;
+}
+
+/* Compute where each block is going to go, after compaction */
+cell compute_heap_forwarding(heap *heap)
+{
+ heap_block *scan = first_block(heap);
+ cell address = (cell)first_block(heap);
+
+ while(scan)
+ {
+ if(scan->status == B_ALLOCATED)
+ {
+ scan->forwarding = (heap_block *)address;
+ address += scan->size;
+ }
+ else if(scan->status == B_MARKED)
+ critical_error("Why is the block marked?",0);
+
+ scan = next_block(heap,scan);
+ }
+
+ return address - heap->seg->start;
+}
+
+void compact_heap(heap *heap)
+{
+ heap_block *scan = first_block(heap);
+
+ while(scan)
+ {
+ heap_block *next = next_block(heap,scan);
+
+ if(scan->status == B_ALLOCATED && scan != scan->forwarding)
+ memcpy(scan->forwarding,scan,scan->size);
+ scan = next;
+ }
+}
+
+}
diff --git a/vm/code_gc.h b/vm/code_gc.h
deleted file mode 100644
index cc2c42f120..0000000000
--- a/vm/code_gc.h
+++ /dev/null
@@ -1,34 +0,0 @@
-typedef struct {
- F_SEGMENT *segment;
- F_FREE_BLOCK *free_list;
-} F_HEAP;
-
-void new_heap(F_HEAP *heap, CELL size);
-void build_free_list(F_HEAP *heap, CELL size);
-F_BLOCK *heap_allot(F_HEAP *heap, CELL size);
-void mark_block(F_BLOCK *block);
-void unmark_marked(F_HEAP *heap);
-void free_unmarked(F_HEAP *heap);
-void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free);
-CELL heap_size(F_HEAP *heap);
-CELL compute_heap_forwarding(F_HEAP *heap);
-void compact_heap(F_HEAP *heap);
-
-INLINE F_BLOCK *next_block(F_HEAP *heap, F_BLOCK *block)
-{
- CELL next = ((CELL)block + block->size);
- if(next == heap->segment->end)
- return NULL;
- else
- return (F_BLOCK *)next;
-}
-
-INLINE F_BLOCK *first_block(F_HEAP *heap)
-{
- return (F_BLOCK *)heap->segment->start;
-}
-
-INLINE F_BLOCK *last_block(F_HEAP *heap)
-{
- return (F_BLOCK *)heap->segment->end;
-}
diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp
new file mode 100755
index 0000000000..3879d3c8e8
--- /dev/null
+++ b/vm/code_gc.hpp
@@ -0,0 +1,50 @@
+namespace factor
+{
+
+#define FREE_LIST_COUNT 16
+#define BLOCK_SIZE_INCREMENT 32
+
+struct heap_free_list {
+ free_heap_block *small_blocks[FREE_LIST_COUNT];
+ free_heap_block *large_blocks;
+};
+
+struct heap {
+ segment *seg;
+ heap_free_list free;
+};
+
+typedef void (*heap_iterator)(heap_block *compiled);
+
+void new_heap(heap *h, cell size);
+void build_free_list(heap *h, cell size);
+heap_block *heap_allot(heap *h, cell size);
+void heap_free(heap *h, heap_block *block);
+void mark_block(heap_block *block);
+void unmark_marked(heap *heap);
+void free_unmarked(heap *heap, heap_iterator iter);
+void heap_usage(heap *h, cell *used, cell *total_free, cell *max_free);
+cell heap_size(heap *h);
+cell compute_heap_forwarding(heap *h);
+void compact_heap(heap *h);
+
+inline static heap_block *next_block(heap *h, heap_block *block)
+{
+ cell next = ((cell)block + block->size);
+ if(next == h->seg->end)
+ return NULL;
+ else
+ return (heap_block *)next;
+}
+
+inline static heap_block *first_block(heap *h)
+{
+ return (heap_block *)h->seg->start;
+}
+
+inline static heap_block *last_block(heap *h)
+{
+ return (heap_block *)h->seg->end;
+}
+
+}
diff --git a/vm/code_heap.c b/vm/code_heap.c
deleted file mode 100755
index 65a28c6de3..0000000000
--- a/vm/code_heap.c
+++ /dev/null
@@ -1,236 +0,0 @@
-#include "master.h"
-
-/* Allocate a code heap during startup */
-void init_code_heap(CELL size)
-{
- new_heap(&code_heap,size);
-}
-
-bool in_code_heap_p(CELL ptr)
-{
- return (ptr >= code_heap.segment->start
- && ptr <= code_heap.segment->end);
-}
-
-void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled)
-{
- if(compiled->block.type != WORD_TYPE)
- critical_error("bad param to set_word_xt",(CELL)compiled);
-
- word->code = compiled;
- word->optimizedp = T;
-}
-
-/* Allocates memory */
-void default_word_code(F_WORD *word, bool relocate)
-{
- REGISTER_UNTAGGED(word);
- jit_compile(word->def,relocate);
- UNREGISTER_UNTAGGED(word);
-
- word->code = untag_quotation(word->def)->code;
- word->optimizedp = F;
-}
-
-/* Apply a function to every code block */
-void iterate_code_heap(CODE_HEAP_ITERATOR iter)
-{
- F_BLOCK *scan = first_block(&code_heap);
-
- while(scan)
- {
- if(scan->status != B_FREE)
- iter((F_CODE_BLOCK *)scan);
- scan = next_block(&code_heap,scan);
- }
-}
-
-/* Copy literals referenced from all code blocks to newspace. Only for
-aging and nursery collections */
-void copy_code_heap_roots(void)
-{
- iterate_code_heap(copy_literal_references);
-}
-
-/* Update literals referenced from all code blocks. Only for tenured
-collections, done at the end. */
-void update_code_heap_roots(void)
-{
- iterate_code_heap(update_literal_references);
-}
-
-/* Update pointers to words referenced from all code blocks. Only after
-defining a new word. */
-void update_code_heap_words(void)
-{
- iterate_code_heap(update_word_references);
-}
-
-void primitive_modify_code_heap(void)
-{
- F_ARRAY *alist = untag_array(dpop());
-
- CELL count = untag_fixnum_fast(alist->capacity);
- if(count == 0)
- return;
-
- CELL i;
- for(i = 0; i < count; i++)
- {
- F_ARRAY *pair = untag_array(array_nth(alist,i));
-
- F_WORD *word = untag_word(array_nth(pair,0));
-
- CELL data = array_nth(pair,1);
-
- if(data == F)
- {
- REGISTER_UNTAGGED(alist);
- REGISTER_UNTAGGED(word);
- default_word_code(word,false);
- UNREGISTER_UNTAGGED(word);
- UNREGISTER_UNTAGGED(alist);
- }
- else
- {
- F_ARRAY *compiled_code = untag_array(data);
-
- F_ARRAY *literals = untag_array(array_nth(compiled_code,0));
- CELL relocation = array_nth(compiled_code,1);
- F_ARRAY *labels = untag_array(array_nth(compiled_code,2));
- F_ARRAY *code = untag_array(array_nth(compiled_code,3));
-
- REGISTER_UNTAGGED(alist);
- REGISTER_UNTAGGED(word);
-
- F_CODE_BLOCK *compiled = add_code_block(
- WORD_TYPE,
- code,
- labels,
- relocation,
- tag_object(literals));
-
- UNREGISTER_UNTAGGED(word);
- UNREGISTER_UNTAGGED(alist);
-
- set_word_code(word,compiled);
- }
-
- REGISTER_UNTAGGED(alist);
- update_word_xt(word);
- UNREGISTER_UNTAGGED(alist);
- }
-
- update_code_heap_words();
-}
-
-/* Push the free space and total size of the code heap */
-void primitive_code_room(void)
-{
- CELL used, total_free, max_free;
- heap_usage(&code_heap,&used,&total_free,&max_free);
- dpush(tag_fixnum((code_heap.segment->size) / 1024));
- dpush(tag_fixnum(used / 1024));
- dpush(tag_fixnum(total_free / 1024));
- dpush(tag_fixnum(max_free / 1024));
-}
-
-F_CODE_BLOCK *forward_xt(F_CODE_BLOCK *compiled)
-{
- return (F_CODE_BLOCK *)compiled->block.forwarding;
-}
-
-void forward_frame_xt(F_STACK_FRAME *frame)
-{
- CELL offset = (CELL)FRAME_RETURN_ADDRESS(frame) - (CELL)frame_code(frame);
- F_CODE_BLOCK *forwarded = forward_xt(frame_code(frame));
- frame->xt = (XT)(forwarded + 1);
- FRAME_RETURN_ADDRESS(frame) = (XT)((CELL)forwarded + offset);
-}
-
-void forward_object_xts(void)
-{
- begin_scan();
-
- CELL obj;
-
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
-
- word->code = forward_xt(word->code);
- if(word->profiling)
- word->profiling = forward_xt(word->profiling);
- }
- else if(type_of(obj) == QUOTATION_TYPE)
- {
- F_QUOTATION *quot = untag_object(obj);
-
- if(quot->compiledp != F)
- quot->code = forward_xt(quot->code);
- }
- else if(type_of(obj) == CALLSTACK_TYPE)
- {
- F_CALLSTACK *stack = untag_object(obj);
- iterate_callstack_object(stack,forward_frame_xt);
- }
- }
-
- /* End the heap scan */
- gc_off = false;
-}
-
-/* Set the XT fields now that the heap has been compacted */
-void fixup_object_xts(void)
-{
- begin_scan();
-
- CELL obj;
-
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
- update_word_xt(word);
- }
- else if(type_of(obj) == QUOTATION_TYPE)
- {
- F_QUOTATION *quot = untag_object(obj);
-
- if(quot->compiledp != F)
- set_quot_xt(quot,quot->code);
- }
- }
-
- /* End the heap scan */
- gc_off = false;
-}
-
-/* Move all free space to the end of the code heap. This is not very efficient,
-since it makes several passes over the code and data heaps, but we only ever
-do this before saving a deployed image and exiting, so performaance is not
-critical here */
-void compact_code_heap(void)
-{
- /* Free all unreachable code blocks */
- gc();
-
- /* Figure out where the code heap blocks are going to end up */
- CELL size = compute_heap_forwarding(&code_heap);
-
- /* Update word and quotation code pointers */
- forward_object_xts();
-
- /* Actually perform the compaction */
- compact_heap(&code_heap);
-
- /* Update word and quotation XTs */
- fixup_object_xts();
-
- /* Now update the free list; there will be a single free block at
- the end */
- build_free_list(&code_heap,size);
-}
diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp
new file mode 100755
index 0000000000..5dca29b420
--- /dev/null
+++ b/vm/code_heap.cpp
@@ -0,0 +1,234 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+heap code;
+
+/* Allocate a code heap during startup */
+void init_code_heap(cell size)
+{
+ new_heap(&code,size);
+}
+
+bool in_code_heap_p(cell ptr)
+{
+ return (ptr >= code.seg->start && ptr <= code.seg->end);
+}
+
+/* Compile a word definition with the non-optimizing compiler. Allocates memory */
+void jit_compile_word(cell word_, cell def_, bool relocate)
+{
+ gc_root<word> word(word_);
+ gc_root<quotation> def(def_);
+
+ jit_compile(def.value(),relocate);
+
+ word->code = def->code;
+
+ if(word->direct_entry_def != F)
+ jit_compile(word->direct_entry_def,relocate);
+}
+
+/* Apply a function to every code block */
+void iterate_code_heap(code_heap_iterator iter)
+{
+ heap_block *scan = first_block(&code);
+
+ while(scan)
+ {
+ if(scan->status != B_FREE)
+ iter((code_block *)scan);
+ scan = next_block(&code,scan);
+ }
+}
+
+/* Copy literals referenced from all code blocks to newspace. Only for
+aging and nursery collections */
+void copy_code_heap_roots(void)
+{
+ iterate_code_heap(copy_literal_references);
+}
+
+/* Update pointers to words referenced from all code blocks. Only after
+defining a new word. */
+void update_code_heap_words(void)
+{
+ iterate_code_heap(update_word_references);
+}
+
+PRIMITIVE(modify_code_heap)
+{
+ gc_root<array> alist(dpop());
+
+ cell count = array_capacity(alist.untagged());
+
+ if(count == 0)
+ return;
+
+ cell i;
+ for(i = 0; i < count; i++)
+ {
+ gc_root<array> pair(array_nth(alist.untagged(),i));
+
+ gc_root<word> word(array_nth(pair.untagged(),0));
+ gc_root<object> data(array_nth(pair.untagged(),1));
+
+ switch(data.type())
+ {
+ case QUOTATION_TYPE:
+ jit_compile_word(word.value(),data.value(),false);
+ break;
+ case ARRAY_TYPE:
+ {
+ array *compiled_data = data.as<array>().untagged();
+ cell literals = array_nth(compiled_data,0);
+ cell relocation = array_nth(compiled_data,1);
+ cell labels = array_nth(compiled_data,2);
+ cell code = array_nth(compiled_data,3);
+
+ code_block *compiled = add_code_block(
+ WORD_TYPE,
+ code,
+ labels,
+ relocation,
+ literals);
+
+ word->code = compiled;
+ }
+ break;
+ default:
+ critical_error("Expected a quotation or an array",data.value());
+ break;
+ }
+
+ update_word_xt(word.value());
+ }
+
+ update_code_heap_words();
+}
+
+/* Push the free space and total size of the code heap */
+PRIMITIVE(code_room)
+{
+ cell used, total_free, max_free;
+ heap_usage(&code,&used,&total_free,&max_free);
+ dpush(tag_fixnum(code.seg->size / 1024));
+ dpush(tag_fixnum(used / 1024));
+ dpush(tag_fixnum(total_free / 1024));
+ dpush(tag_fixnum(max_free / 1024));
+}
+
+code_block *forward_xt(code_block *compiled)
+{
+ return (code_block *)compiled->block.forwarding;
+}
+
+void forward_frame_xt(stack_frame *frame)
+{
+ cell offset = (cell)FRAME_RETURN_ADDRESS(frame) - (cell)frame_code(frame);
+ code_block *forwarded = forward_xt(frame_code(frame));
+ frame->xt = forwarded->xt();
+ FRAME_RETURN_ADDRESS(frame) = (void *)((cell)forwarded + offset);
+}
+
+void forward_object_xts(void)
+{
+ begin_scan();
+
+ cell obj;
+
+ while((obj = next_object()) != F)
+ {
+ switch(tagged<object>(obj).type())
+ {
+ case WORD_TYPE:
+ {
+ word *w = untag<word>(obj);
+
+ if(w->code)
+ w->code = forward_xt(w->code);
+ if(w->profiling)
+ w->profiling = forward_xt(w->profiling);
+ }
+ break;
+ case QUOTATION_TYPE:
+ {
+ quotation *quot = untag<quotation>(obj);
+
+ if(quot->compiledp != F)
+ quot->code = forward_xt(quot->code);
+ }
+ break;
+ case CALLSTACK_TYPE:
+ {
+ callstack *stack = untag<callstack>(obj);
+ iterate_callstack_object(stack,forward_frame_xt);
+ }
+ break;
+ default:
+ break;
+ }
+ }
+
+ /* End the heap scan */
+ gc_off = false;
+}
+
+/* Set the XT fields now that the heap has been compacted */
+void fixup_object_xts(void)
+{
+ begin_scan();
+
+ cell obj;
+
+ while((obj = next_object()) != F)
+ {
+ switch(tagged<object>(obj).type())
+ {
+ case WORD_TYPE:
+ update_word_xt(obj);
+ break;
+ case QUOTATION_TYPE:
+ {
+ quotation *quot = untag<quotation>(obj);
+ if(quot->compiledp != F)
+ set_quot_xt(quot,quot->code);
+ break;
+ }
+ default:
+ break;
+ }
+ }
+
+ /* End the heap scan */
+ gc_off = false;
+}
+
+/* Move all free space to the end of the code heap. This is not very efficient,
+since it makes several passes over the code and data heaps, but we only ever
+do this before saving a deployed image and exiting, so performaance is not
+critical here */
+void compact_code_heap(void)
+{
+ /* Free all unreachable code blocks */
+ gc();
+
+ /* Figure out where the code heap blocks are going to end up */
+ cell size = compute_heap_forwarding(&code);
+
+ /* Update word and quotation code pointers */
+ forward_object_xts();
+
+ /* Actually perform the compaction */
+ compact_heap(&code);
+
+ /* Update word and quotation XTs */
+ fixup_object_xts();
+
+ /* Now update the free list; there will be a single free block at
+ the end */
+ build_free_list(&code,size);
+}
+
+}
diff --git a/vm/code_heap.h b/vm/code_heap.h
deleted file mode 100755
index 4f52819547..0000000000
--- a/vm/code_heap.h
+++ /dev/null
@@ -1,24 +0,0 @@
-/* compiled code */
-F_HEAP code_heap;
-
-void init_code_heap(CELL size);
-
-bool in_code_heap_p(CELL ptr);
-
-void default_word_code(F_WORD *word, bool relocate);
-
-void set_word_code(F_WORD *word, F_CODE_BLOCK *compiled);
-
-typedef void (*CODE_HEAP_ITERATOR)(F_CODE_BLOCK *compiled);
-
-void iterate_code_heap(CODE_HEAP_ITERATOR iter);
-
-void copy_code_heap_roots(void);
-
-void update_code_heap_roots(void);
-
-void primitive_modify_code_heap(void);
-
-void primitive_code_room(void);
-
-void compact_code_heap(void);
diff --git a/vm/code_heap.hpp b/vm/code_heap.hpp
new file mode 100755
index 0000000000..056a6a88c6
--- /dev/null
+++ b/vm/code_heap.hpp
@@ -0,0 +1,32 @@
+namespace factor
+{
+
+/* compiled code */
+extern heap code;
+
+void init_code_heap(cell size);
+
+bool in_code_heap_p(cell ptr);
+
+void jit_compile_word(cell word, cell def, bool relocate);
+
+typedef void (*code_heap_iterator)(code_block *compiled);
+
+void iterate_code_heap(code_heap_iterator iter);
+
+void copy_code_heap_roots(void);
+
+PRIMITIVE(modify_code_heap);
+
+PRIMITIVE(code_room);
+
+void compact_code_heap(void);
+
+inline static void check_code_pointer(cell ptr)
+{
+#ifdef FACTOR_DEBUG
+ assert(in_code_heap_p(ptr));
+#endif
+}
+
+}
diff --git a/vm/contexts.cpp b/vm/contexts.cpp
new file mode 100644
index 0000000000..66570abc31
--- /dev/null
+++ b/vm/contexts.cpp
@@ -0,0 +1,192 @@
+#include "master.hpp"
+
+factor::context *stack_chain;
+
+namespace factor
+{
+
+cell ds_size, rs_size;
+context *unused_contexts;
+
+void reset_datastack(void)
+{
+ ds = ds_bot - sizeof(cell);
+}
+
+void reset_retainstack(void)
+{
+ rs = rs_bot - sizeof(cell);
+}
+
+#define RESERVED (64 * sizeof(cell))
+
+void fix_stacks(void)
+{
+ if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
+ if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
+}
+
+/* called before entry into foreign C code. Note that ds and rs might
+be stored in registers, so callbacks must save and restore the correct values */
+void save_stacks(void)
+{
+ if(stack_chain)
+ {
+ stack_chain->datastack = ds;
+ stack_chain->retainstack = rs;
+ }
+}
+
+context *alloc_context(void)
+{
+ context *new_context;
+
+ if(unused_contexts)
+ {
+ new_context = unused_contexts;
+ unused_contexts = unused_contexts->next;
+ }
+ else
+ {
+ new_context = (context *)safe_malloc(sizeof(context));
+ new_context->datastack_region = alloc_segment(ds_size);
+ new_context->retainstack_region = alloc_segment(rs_size);
+ }
+
+ return new_context;
+}
+
+void dealloc_context(context *old_context)
+{
+ old_context->next = unused_contexts;
+ unused_contexts = old_context;
+}
+
+/* called on entry into a compiled callback */
+void nest_stacks(void)
+{
+ context *new_context = alloc_context();
+
+ new_context->callstack_bottom = (stack_frame *)-1;
+ new_context->callstack_top = (stack_frame *)-1;
+
+ /* note that these register values are not necessarily valid stack
+ pointers. they are merely saved non-volatile registers, and are
+ restored in unnest_stacks(). consider this scenario:
+ - factor code calls C function
+ - C function saves ds/cs registers (since they're non-volatile)
+ - C function clobbers them
+ - C function calls Factor callback
+ - Factor callback returns
+ - C function restores registers
+ - C function returns to Factor code */
+ new_context->datastack_save = ds;
+ new_context->retainstack_save = rs;
+
+ /* save per-callback userenv */
+ new_context->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
+ new_context->catchstack_save = userenv[CATCHSTACK_ENV];
+
+ new_context->next = stack_chain;
+ stack_chain = new_context;
+
+ reset_datastack();
+ reset_retainstack();
+}
+
+/* called when leaving a compiled callback */
+void unnest_stacks(void)
+{
+ ds = stack_chain->datastack_save;
+ rs = stack_chain->retainstack_save;
+
+ /* restore per-callback userenv */
+ userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save;
+ userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save;
+
+ context *old_stacks = stack_chain;
+ stack_chain = old_stacks->next;
+ dealloc_context(old_stacks);
+}
+
+/* called on startup */
+void init_stacks(cell ds_size_, cell rs_size_)
+{
+ ds_size = ds_size_;
+ rs_size = rs_size_;
+ stack_chain = NULL;
+ unused_contexts = NULL;
+}
+
+bool stack_to_array(cell bottom, cell top)
+{
+ fixnum depth = (fixnum)(top - bottom + sizeof(cell));
+
+ if(depth < 0)
+ return false;
+ else
+ {
+ array *a = allot_array_internal<array>(depth / sizeof(cell));
+ memcpy(a + 1,(void*)bottom,depth);
+ dpush(tag<array>(a));
+ return true;
+ }
+}
+
+PRIMITIVE(datastack)
+{
+ if(!stack_to_array(ds_bot,ds))
+ general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
+}
+
+PRIMITIVE(retainstack)
+{
+ if(!stack_to_array(rs_bot,rs))
+ general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
+}
+
+/* returns pointer to top of stack */
+cell array_to_stack(array *array, cell bottom)
+{
+ cell depth = array_capacity(array) * sizeof(cell);
+ memcpy((void*)bottom,array + 1,depth);
+ return bottom + depth - sizeof(cell);
+}
+
+PRIMITIVE(set_datastack)
+{
+ ds = array_to_stack(untag_check<array>(dpop()),ds_bot);
+}
+
+PRIMITIVE(set_retainstack)
+{
+ rs = array_to_stack(untag_check<array>(dpop()),rs_bot);
+}
+
+/* Used to implement call( */
+PRIMITIVE(check_datastack)
+{
+ fixnum out = to_fixnum(dpop());
+ fixnum in = to_fixnum(dpop());
+ fixnum height = out - in;
+ array *saved_datastack = untag_check<array>(dpop());
+ fixnum saved_height = array_capacity(saved_datastack);
+ fixnum current_height = (ds - ds_bot + sizeof(cell)) / sizeof(cell);
+ if(current_height - height != saved_height)
+ dpush(F);
+ else
+ {
+ fixnum i;
+ for(i = 0; i < saved_height - in; i++)
+ {
+ if(((cell *)ds_bot)[i] != array_nth(saved_datastack,i))
+ {
+ dpush(F);
+ return;
+ }
+ }
+ dpush(T);
+ }
+}
+
+}
diff --git a/vm/contexts.hpp b/vm/contexts.hpp
new file mode 100644
index 0000000000..13af17f2f0
--- /dev/null
+++ b/vm/contexts.hpp
@@ -0,0 +1,66 @@
+namespace factor
+{
+
+/* Assembly code makes assumptions about the layout of this struct:
+ - callstack_top field is 0
+ - callstack_bottom field is 1
+ - datastack field is 2
+ - retainstack field is 3 */
+struct context {
+ /* C stack pointer on entry */
+ stack_frame *callstack_top;
+ stack_frame *callstack_bottom;
+
+ /* current datastack top pointer */
+ cell datastack;
+
+ /* current retain stack top pointer */
+ cell retainstack;
+
+ /* saved contents of ds register on entry to callback */
+ cell datastack_save;
+
+ /* saved contents of rs register on entry to callback */
+ cell retainstack_save;
+
+ /* memory region holding current datastack */
+ segment *datastack_region;
+
+ /* memory region holding current retain stack */
+ segment *retainstack_region;
+
+ /* saved userenv slots on entry to callback */
+ cell catchstack_save;
+ cell current_callback_save;
+
+ context *next;
+};
+
+extern cell ds_size, rs_size;
+
+#define ds_bot (stack_chain->datastack_region->start)
+#define ds_top (stack_chain->datastack_region->end)
+#define rs_bot (stack_chain->retainstack_region->start)
+#define rs_top (stack_chain->retainstack_region->end)
+
+DEFPUSHPOP(d,ds)
+DEFPUSHPOP(r,rs)
+
+void reset_datastack(void);
+void reset_retainstack(void);
+void fix_stacks(void);
+void init_stacks(cell ds_size, cell rs_size);
+
+PRIMITIVE(datastack);
+PRIMITIVE(retainstack);
+PRIMITIVE(set_datastack);
+PRIMITIVE(set_retainstack);
+PRIMITIVE(check_datastack);
+
+VM_C_API void save_stacks(void);
+VM_C_API void nest_stacks(void);
+VM_C_API void unnest_stacks(void);
+
+}
+
+VM_C_API factor::context *stack_chain;
diff --git a/vm/cpu-arm.h b/vm/cpu-arm.h
deleted file mode 100755
index e6ea0a1158..0000000000
--- a/vm/cpu-arm.h
+++ /dev/null
@@ -1,13 +0,0 @@
-#define FACTOR_CPU_STRING "arm"
-
-register CELL ds asm("r5");
-register CELL rs asm("r6");
-
-#define F_FASTCALL
-
-#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
-
-void c_to_factor(CELL quot);
-void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
-void throw_impl(CELL quot, F_STACK_FRAME *rewind);
-void lazy_jit_compile(CELL quot);
diff --git a/vm/cpu-arm.hpp b/vm/cpu-arm.hpp
new file mode 100755
index 0000000000..235677b274
--- /dev/null
+++ b/vm/cpu-arm.hpp
@@ -0,0 +1,16 @@
+namespace factor
+{
+
+#define FACTOR_CPU_STRING "arm"
+
+register cell ds asm("r5");
+register cell rs asm("r6");
+
+#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
+
+void c_to_factor(cell quot);
+void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy);
+void throw_impl(cell quot, stack_frame *rewind);
+void lazy_jit_compile(cell quot);
+
+}
diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S
index 8b3141218b..5e77c004aa 100755
--- a/vm/cpu-ppc.S
+++ b/vm/cpu-ppc.S
@@ -45,7 +45,7 @@ multiply_overflow:
/* Note that the XT is passed to the quotation in r11 */
#define CALL_OR_JUMP_QUOT \
- lwz r11,17(r3) /* load quotation-xt slot */ XX \
+ lwz r11,14(r3) /* load quotation-xt slot */ XX \
#define CALL_QUOT \
CALL_OR_JUMP_QUOT XX \
diff --git a/vm/cpu-ppc.h b/vm/cpu-ppc.h
deleted file mode 100755
index 298e21aa7d..0000000000
--- a/vm/cpu-ppc.h
+++ /dev/null
@@ -1,12 +0,0 @@
-#define FACTOR_CPU_STRING "ppc"
-#define F_FASTCALL
-
-register CELL ds asm("r29");
-register CELL rs asm("r30");
-
-void c_to_factor(CELL quot);
-void undefined(CELL word);
-void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
-void throw_impl(CELL quot, F_STACK_FRAME *rewind);
-void lazy_jit_compile(CELL quot);
-void flush_icache(CELL start, CELL len);
diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp
new file mode 100755
index 0000000000..7e8ae05fac
--- /dev/null
+++ b/vm/cpu-ppc.hpp
@@ -0,0 +1,17 @@
+namespace factor
+{
+
+#define FACTOR_CPU_STRING "ppc"
+#define VM_ASM_API
+
+register cell ds asm("r29");
+register cell rs asm("r30");
+
+void c_to_factor(cell quot);
+void undefined(cell word);
+void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy);
+void throw_impl(cell quot, stack_frame *rewind);
+void lazy_jit_compile(cell quot);
+void flush_icache(cell start, cell len);
+
+}
diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S
index 7a8e579c62..3c0db36935 100755
--- a/vm/cpu-x86.32.S
+++ b/vm/cpu-x86.32.S
@@ -29,7 +29,8 @@ and the callstack top is passed in EDX */
pop %ebp ; \
pop %ebx
-#define QUOT_XT_OFFSET 17
+#define QUOT_XT_OFFSET 16
+#define WORD_XT_OFFSET 30
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
@@ -59,6 +60,14 @@ DEF(bool,check_sse2,(void)):
mov %edx,%eax
ret
+DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
+ mov (%esp),%eax
+ sub $8,%esp
+ push %eax
+ call MANGLE(inline_cache_miss)
+ add $12,%esp
+ jmp *%eax
+
#include "cpu-x86.S"
#ifdef WINDOWS
diff --git a/vm/cpu-x86.32.h b/vm/cpu-x86.32.h
deleted file mode 100755
index 21f07cf2b4..0000000000
--- a/vm/cpu-x86.32.h
+++ /dev/null
@@ -1,6 +0,0 @@
-#define FACTOR_CPU_STRING "x86.32"
-
-register CELL ds asm("esi");
-register CELL rs asm("edi");
-
-#define F_FASTCALL __attribute__ ((regparm (2)))
diff --git a/vm/cpu-x86.32.hpp b/vm/cpu-x86.32.hpp
new file mode 100755
index 0000000000..6b6328aa4f
--- /dev/null
+++ b/vm/cpu-x86.32.hpp
@@ -0,0 +1,11 @@
+namespace factor
+{
+
+#define FACTOR_CPU_STRING "x86.32"
+
+register cell ds asm("esi");
+register cell rs asm("edi");
+
+#define VM_ASM_API extern "C" __attribute__ ((regparm (2)))
+
+}
diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S
index 8cf8fb9ae7..a110bf1d51 100644
--- a/vm/cpu-x86.64.S
+++ b/vm/cpu-x86.64.S
@@ -61,7 +61,8 @@
#endif
-#define QUOT_XT_OFFSET 37
+#define QUOT_XT_OFFSET 36
+#define WORD_XT_OFFSET 66
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
@@ -72,4 +73,11 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
call *ARG3 /* call memcpy */
ret /* return _with new stack_ */
+DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
+ mov (%rsp),ARG0
+ sub $STACK_PADDING,%rsp
+ call MANGLE(inline_cache_miss)
+ add $STACK_PADDING,%rsp
+ jmp *%rax
+
#include "cpu-x86.S"
diff --git a/vm/cpu-x86.64.h b/vm/cpu-x86.64.h
deleted file mode 100644
index 6412355129..0000000000
--- a/vm/cpu-x86.64.h
+++ /dev/null
@@ -1,6 +0,0 @@
-#define FACTOR_CPU_STRING "x86.64"
-
-register CELL ds asm("r14");
-register CELL rs asm("r15");
-
-#define F_FASTCALL
diff --git a/vm/cpu-x86.64.hpp b/vm/cpu-x86.64.hpp
new file mode 100644
index 0000000000..be71a78aa8
--- /dev/null
+++ b/vm/cpu-x86.64.hpp
@@ -0,0 +1,11 @@
+namespace factor
+{
+
+#define FACTOR_CPU_STRING "x86.64"
+
+register cell ds asm("r14");
+register cell rs asm("r15");
+
+#define VM_ASM_API extern "C"
+
+}
diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S
index 7a0d738fe0..e83bb0fd7d 100755
--- a/vm/cpu-x86.S
+++ b/vm/cpu-x86.S
@@ -60,7 +60,7 @@ DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
mov ARG1,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0)
-DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
+DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)):
mov STACK_REG,ARG1 /* Save stack pointer */
sub $STACK_PADDING,STACK_REG
call MANGLE(lazy_jit_compile_impl)
diff --git a/vm/cpu-x86.h b/vm/cpu-x86.h
deleted file mode 100755
index 3b08479e4b..0000000000
--- a/vm/cpu-x86.h
+++ /dev/null
@@ -1,9 +0,0 @@
-#define FRAME_RETURN_ADDRESS(frame) *(XT *)(frame_successor(frame) + 1)
-
-INLINE void flush_icache(CELL start, CELL len) {}
-
-F_FASTCALL void c_to_factor(CELL quot);
-F_FASTCALL void throw_impl(CELL quot, F_STACK_FRAME *rewind_to);
-F_FASTCALL void lazy_jit_compile(CELL quot);
-
-void set_callstack(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, void *memcpy);
diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp
new file mode 100755
index 0000000000..c0b4651811
--- /dev/null
+++ b/vm/cpu-x86.hpp
@@ -0,0 +1,44 @@
+#include <assert.h>
+
+namespace factor
+{
+
+#define FRAME_RETURN_ADDRESS(frame) *(void **)(frame_successor(frame) + 1)
+
+inline static void flush_icache(cell start, cell len) {}
+
+inline static void check_call_site(cell return_address)
+{
+ /* An x86 CALL instruction looks like so:
+ |e8|..|..|..|..|
+ where the ... are a PC-relative jump address.
+ The return_address points to right after the
+ instruction. */
+#ifdef FACTOR_DEBUG
+ assert(*(unsigned char *)(return_address - 5) == 0xe8);
+#endif
+}
+
+inline static void *get_call_target(cell return_address)
+{
+ check_call_site(return_address);
+ return (void *)(*(int *)(return_address - 4) + return_address);
+}
+
+inline static void set_call_target(cell return_address, void *target)
+{
+ check_call_site(return_address);
+ *(int *)(return_address - 4) = ((cell)target - return_address);
+}
+
+/* Defined in assembly */
+VM_ASM_API void c_to_factor(cell quot);
+VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to);
+VM_ASM_API void lazy_jit_compile(cell quot);
+
+VM_C_API void set_callstack(stack_frame *to,
+ stack_frame *from,
+ cell length,
+ void *(*memcpy)(void*,const void*, size_t));
+
+}
diff --git a/vm/data_gc.c b/vm/data_gc.c
deleted file mode 100755
index a91eff6783..0000000000
--- a/vm/data_gc.c
+++ /dev/null
@@ -1,586 +0,0 @@
-#include "master.h"
-
-/* Scan all the objects in the card */
-void copy_card(F_CARD *ptr, CELL gen, CELL here)
-{
- CELL card_scan = (CELL)CARD_TO_ADDR(ptr) + CARD_OFFSET(ptr);
- CELL card_end = (CELL)CARD_TO_ADDR(ptr + 1);
-
- if(here < card_end)
- card_end = here;
-
- copy_reachable_objects(card_scan,&card_end);
-
- cards_scanned++;
-}
-
-void copy_card_deck(F_DECK *deck, CELL gen, F_CARD mask, F_CARD unmask)
-{
- F_CARD *first_card = DECK_TO_CARD(deck);
- F_CARD *last_card = DECK_TO_CARD(deck + 1);
-
- CELL here = data_heap->generations[gen].here;
-
- u32 *quad_ptr;
- u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
-
- for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
- {
- if(*quad_ptr & quad_mask)
- {
- F_CARD *ptr = (F_CARD *)quad_ptr;
-
- int card;
- for(card = 0; card < 4; card++)
- {
- if(ptr[card] & mask)
- {
- copy_card(&ptr[card],gen,here);
- ptr[card] &= ~unmask;
- }
- }
- }
- }
-
- decks_scanned++;
-}
-
-/* Copy all newspace objects referenced from marked cards to the destination */
-void copy_gen_cards(CELL gen)
-{
- F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[gen].start);
- F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[gen].end);
-
- F_CARD mask, unmask;
-
- /* if we are collecting the nursery, we care about old->nursery pointers
- but not old->aging pointers */
- if(collecting_gen == NURSERY)
- {
- mask = CARD_POINTS_TO_NURSERY;
-
- /* after the collection, no old->nursery pointers remain
- anywhere, but old->aging pointers might remain in tenured
- space */
- if(gen == TENURED)
- unmask = CARD_POINTS_TO_NURSERY;
- /* after the collection, all cards in aging space can be
- cleared */
- else if(HAVE_AGING_P && gen == AGING)
- unmask = CARD_MARK_MASK;
- else
- {
- critical_error("bug in copy_gen_cards",gen);
- return;
- }
- }
- /* if we are collecting aging space into tenured space, we care about
- all old->nursery and old->aging pointers. no old->aging pointers can
- remain */
- else if(HAVE_AGING_P && collecting_gen == AGING)
- {
- if(collecting_aging_again)
- {
- mask = CARD_POINTS_TO_AGING;
- unmask = CARD_MARK_MASK;
- }
- /* after we collect aging space into the aging semispace, no
- old->nursery pointers remain but tenured space might still have
- pointers to aging space. */
- else
- {
- mask = CARD_POINTS_TO_AGING;
- unmask = CARD_POINTS_TO_NURSERY;
- }
- }
- else
- {
- critical_error("bug in copy_gen_cards",gen);
- return;
- }
-
- F_DECK *ptr;
-
- for(ptr = first_deck; ptr < last_deck; ptr++)
- {
- if(*ptr & mask)
- {
- copy_card_deck(ptr,gen,mask,unmask);
- *ptr &= ~unmask;
- }
- }
-}
-
-/* Scan cards in all generations older than the one being collected, copying
-old->new references */
-void copy_cards(void)
-{
- int i;
- for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
- copy_gen_cards(i);
-}
-
-/* Copy all tagged pointers in a range of memory */
-void copy_stack_elements(F_SEGMENT *region, CELL top)
-{
- CELL ptr = region->start;
-
- for(; ptr <= top; ptr += CELLS)
- copy_handle((CELL*)ptr);
-}
-
-void copy_registered_locals(void)
-{
- CELL ptr = gc_locals_region->start;
-
- for(; ptr <= gc_locals; ptr += CELLS)
- copy_handle(*(CELL **)ptr);
-}
-
-/* Copy roots over at the start of GC, namely various constants, stacks,
-the user environment and extra roots registered with REGISTER_ROOT */
-void copy_roots(void)
-{
- copy_handle(&T);
- copy_handle(&bignum_zero);
- copy_handle(&bignum_pos_one);
- copy_handle(&bignum_neg_one);
-
- copy_registered_locals();
- copy_stack_elements(extra_roots_region,extra_roots);
-
- save_stacks();
- F_CONTEXT *stacks = stack_chain;
-
- while(stacks)
- {
- copy_stack_elements(stacks->datastack_region,stacks->datastack);
- copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
-
- copy_handle(&stacks->catchstack_save);
- copy_handle(&stacks->current_callback_save);
-
- mark_active_blocks(stacks);
-
- stacks = stacks->next;
- }
-
- int i;
- for(i = 0; i < USER_ENV; i++)
- copy_handle(&userenv[i]);
-}
-
-/* Given a pointer to oldspace, copy it to newspace */
-INLINE void *copy_untagged_object(void *pointer, CELL size)
-{
- if(newspace->here + size >= newspace->end)
- longjmp(gc_jmp,1);
- allot_barrier(newspace->here);
- void *newpointer = allot_zone(newspace,size);
-
- F_GC_STATS *s = &gc_stats[collecting_gen];
- s->object_count++;
- s->bytes_copied += size;
-
- memcpy(newpointer,pointer,size);
- return newpointer;
-}
-
-INLINE void forward_object(CELL pointer, CELL newpointer)
-{
- if(pointer != newpointer)
- put(UNTAG(pointer),RETAG(newpointer,GC_COLLECTED));
-}
-
-INLINE CELL copy_object_impl(CELL pointer)
-{
- CELL newpointer = (CELL)copy_untagged_object(
- (void*)UNTAG(pointer),
- object_size(pointer));
- forward_object(pointer,newpointer);
- return newpointer;
-}
-
-/* Follow a chain of forwarding pointers */
-CELL resolve_forwarding(CELL untagged, CELL tag)
-{
- CELL header = get(untagged);
- /* another forwarding pointer */
- if(TAG(header) == GC_COLLECTED)
- return resolve_forwarding(UNTAG(header),tag);
- /* we've found the destination */
- else
- {
- CELL pointer = RETAG(untagged,tag);
- if(should_copy(untagged))
- pointer = RETAG(copy_object_impl(pointer),tag);
- return pointer;
- }
-}
-
-/* Given a pointer to a tagged pointer to oldspace, copy it to newspace.
-If the object has already been copied, return the forwarding
-pointer address without copying anything; otherwise, install
-a new forwarding pointer. */
-INLINE CELL copy_object(CELL pointer)
-{
- CELL tag = TAG(pointer);
- CELL header = get(UNTAG(pointer));
-
- if(TAG(header) == GC_COLLECTED)
- return resolve_forwarding(UNTAG(header),tag);
- else
- return RETAG(copy_object_impl(pointer),tag);
-}
-
-void copy_handle(CELL *handle)
-{
- CELL pointer = *handle;
-
- if(!immediate_p(pointer) && should_copy(pointer))
- *handle = copy_object(pointer);
-}
-
-CELL copy_next_from_nursery(CELL scan)
-{
- CELL *obj = (CELL *)scan;
- CELL *end = (CELL *)(scan + binary_payload_start(scan));
-
- if(obj != end)
- {
- obj++;
-
- CELL nursery_start = nursery.start;
- CELL nursery_end = nursery.end;
-
- for(; obj < end; obj++)
- {
- CELL pointer = *obj;
-
- if(!immediate_p(pointer)
- && (pointer >= nursery_start && pointer < nursery_end))
- *obj = copy_object(pointer);
- }
- }
-
- return scan + untagged_object_size(scan);
-}
-
-CELL copy_next_from_aging(CELL scan)
-{
- CELL *obj = (CELL *)scan;
- CELL *end = (CELL *)(scan + binary_payload_start(scan));
-
- if(obj != end)
- {
- obj++;
-
- CELL tenured_start = data_heap->generations[TENURED].start;
- CELL tenured_end = data_heap->generations[TENURED].end;
-
- CELL newspace_start = newspace->start;
- CELL newspace_end = newspace->end;
-
- for(; obj < end; obj++)
- {
- CELL pointer = *obj;
-
- if(!immediate_p(pointer)
- && !(pointer >= newspace_start && pointer < newspace_end)
- && !(pointer >= tenured_start && pointer < tenured_end))
- *obj = copy_object(pointer);
- }
- }
-
- return scan + untagged_object_size(scan);
-}
-
-CELL copy_next_from_tenured(CELL scan)
-{
- CELL *obj = (CELL *)scan;
- CELL *end = (CELL *)(scan + binary_payload_start(scan));
-
- if(obj != end)
- {
- obj++;
-
- CELL newspace_start = newspace->start;
- CELL newspace_end = newspace->end;
-
- for(; obj < end; obj++)
- {
- CELL pointer = *obj;
-
- if(!immediate_p(pointer) && !(pointer >= newspace_start && pointer < newspace_end))
- *obj = copy_object(pointer);
- }
- }
-
- mark_object_code_block(scan);
-
- return scan + untagged_object_size(scan);
-}
-
-void copy_reachable_objects(CELL scan, CELL *end)
-{
- if(HAVE_NURSERY_P && collecting_gen == NURSERY)
- {
- while(scan < *end)
- scan = copy_next_from_nursery(scan);
- }
- else if(HAVE_AGING_P && collecting_gen == AGING)
- {
- while(scan < *end)
- scan = copy_next_from_aging(scan);
- }
- else if(collecting_gen == TENURED)
- {
- while(scan < *end)
- scan = copy_next_from_tenured(scan);
- }
-}
-
-/* Prepare to start copying reachable objects into an unused zone */
-void begin_gc(CELL requested_bytes)
-{
- if(growing_data_heap)
- {
- if(collecting_gen != TENURED)
- critical_error("Invalid parameters to begin_gc",0);
-
- old_data_heap = data_heap;
- set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
- newspace = &data_heap->generations[TENURED];
- }
- else if(collecting_accumulation_gen_p())
- {
- /* when collecting one of these generations, rotate it
- with the semispace */
- F_ZONE z = data_heap->generations[collecting_gen];
- data_heap->generations[collecting_gen] = data_heap->semispaces[collecting_gen];
- data_heap->semispaces[collecting_gen] = z;
- reset_generation(collecting_gen);
- newspace = &data_heap->generations[collecting_gen];
- clear_cards(collecting_gen,collecting_gen);
- clear_decks(collecting_gen,collecting_gen);
- clear_allot_markers(collecting_gen,collecting_gen);
- }
- else
- {
- /* when collecting a younger generation, we copy
- reachable objects to the next oldest generation,
- so we set the newspace so the next generation. */
- newspace = &data_heap->generations[collecting_gen + 1];
- }
-}
-
-void end_gc(CELL gc_elapsed)
-{
- F_GC_STATS *s = &gc_stats[collecting_gen];
-
- s->collections++;
- s->gc_time += gc_elapsed;
- if(s->max_gc_time < gc_elapsed)
- s->max_gc_time = gc_elapsed;
-
- if(growing_data_heap)
- {
- dealloc_data_heap(old_data_heap);
- old_data_heap = NULL;
- growing_data_heap = false;
- }
-
- if(collecting_accumulation_gen_p())
- {
- /* all younger generations except are now empty.
- if collecting_gen == NURSERY here, we only have 1 generation;
- old-school Cheney collector */
- if(collecting_gen != NURSERY)
- reset_generations(NURSERY,collecting_gen - 1);
- }
- else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
- {
- nursery.here = nursery.start;
- }
- else
- {
- /* all generations up to and including the one
- collected are now empty */
- reset_generations(NURSERY,collecting_gen);
- }
-
- if(collecting_gen == TENURED)
- {
- /* now that all reachable code blocks have been marked,
- deallocate the rest */
- free_unmarked(&code_heap);
- }
-
- collecting_aging_again = false;
-}
-
-/* Collect gen and all younger generations.
-If growing_data_heap_ is true, we must grow the data heap to such a size that
-an allocation of requested_bytes won't fail */
-void garbage_collection(CELL gen,
- bool growing_data_heap_,
- CELL requested_bytes)
-{
- if(gc_off)
- {
- critical_error("GC disabled",gen);
- return;
- }
-
- s64 start = current_micros();
-
- performing_gc = true;
- growing_data_heap = growing_data_heap_;
- collecting_gen = gen;
-
- /* we come back here if a generation is full */
- if(setjmp(gc_jmp))
- {
- /* We have no older generations we can try collecting, so we
- resort to growing the data heap */
- if(collecting_gen == TENURED)
- {
- growing_data_heap = true;
-
- /* see the comment in unmark_marked() */
- unmark_marked(&code_heap);
- }
- /* we try collecting AGING space twice before going on to
- collect TENURED */
- else if(HAVE_AGING_P
- && collecting_gen == AGING
- && !collecting_aging_again)
- {
- collecting_aging_again = true;
- }
- /* Collect the next oldest generation */
- else
- {
- collecting_gen++;
- }
- }
-
- begin_gc(requested_bytes);
-
- /* initialize chase pointer */
- CELL scan = newspace->here;
-
- /* collect objects referenced from stacks and environment */
- copy_roots();
- /* collect objects referenced from older generations */
- copy_cards();
- /* do some tracing */
- copy_reachable_objects(scan,&newspace->here);
-
- /* don't scan code heap unless it has pointers to this
- generation or younger */
- if(collecting_gen >= last_code_heap_scan)
- {
- code_heap_scans++;
-
- if(collecting_gen == TENURED)
- update_code_heap_roots();
- else
- copy_code_heap_roots();
-
- if(collecting_accumulation_gen_p())
- last_code_heap_scan = collecting_gen;
- else
- last_code_heap_scan = collecting_gen + 1;
- }
-
- CELL gc_elapsed = (current_micros() - start);
-
- end_gc(gc_elapsed);
-
- performing_gc = false;
-}
-
-void gc(void)
-{
- garbage_collection(TENURED,false,0);
-}
-
-void minor_gc(void)
-{
- garbage_collection(NURSERY,false,0);
-}
-
-void primitive_gc(void)
-{
- gc();
-}
-
-void primitive_gc_stats(void)
-{
- GROWABLE_ARRAY(stats);
-
- CELL i;
- u64 total_gc_time = 0;
-
- for(i = 0; i < MAX_GEN_COUNT; i++)
- {
- F_GC_STATS *s = &gc_stats[i];
- GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->gc_time)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->max_gc_time)));
- GROWABLE_ARRAY_ADD(stats,allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
- GROWABLE_ARRAY_ADD(stats,allot_cell(s->object_count));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(s->bytes_copied)));
-
- total_gc_time += s->gc_time;
- }
-
- GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(total_gc_time)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
- GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
-
- GROWABLE_ARRAY_TRIM(stats);
- dpush(stats);
-}
-
-void clear_gc_stats(void)
-{
- int i;
- for(i = 0; i < MAX_GEN_COUNT; i++)
- memset(&gc_stats[i],0,sizeof(F_GC_STATS));
-
- cards_scanned = 0;
- decks_scanned = 0;
- code_heap_scans = 0;
-}
-
-void primitive_clear_gc_stats(void)
-{
- clear_gc_stats();
-}
-
-void primitive_become(void)
-{
- F_ARRAY *new_objects = untag_array(dpop());
- F_ARRAY *old_objects = untag_array(dpop());
-
- CELL capacity = array_capacity(new_objects);
- if(capacity != array_capacity(old_objects))
- critical_error("bad parameters to become",0);
-
- CELL i;
-
- for(i = 0; i < capacity; i++)
- {
- CELL old_obj = array_nth(old_objects,i);
- CELL new_obj = array_nth(new_objects,i);
-
- forward_object(old_obj,new_obj);
- }
-
- gc();
-
- compile_all_words();
-}
diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp
new file mode 100755
index 0000000000..e26edc9721
--- /dev/null
+++ b/vm/data_gc.cpp
@@ -0,0 +1,689 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+/* used during garbage collection only */
+zone *newspace;
+bool performing_gc;
+bool performing_compaction;
+cell collecting_gen;
+
+/* if true, we collecting AGING space for the second time, so if it is still
+full, we go on to collect TENURED */
+bool collecting_aging_again;
+
+/* in case a generation fills up in the middle of a gc, we jump back
+up to try collecting the next generation. */
+jmp_buf gc_jmp;
+
+gc_stats stats[MAX_GEN_COUNT];
+u64 cards_scanned;
+u64 decks_scanned;
+u64 card_scan_time;
+cell code_heap_scans;
+
+/* What generation was being collected when copy_code_heap_roots() was last
+called? Until the next call to add_code_block(), future
+collections of younger generations don't have to touch the code
+heap. */
+cell last_code_heap_scan;
+
+/* sometimes we grow the heap */
+bool growing_data_heap;
+data_heap *old_data_heap;
+
+void init_data_gc(void)
+{
+ performing_gc = false;
+ last_code_heap_scan = NURSERY;
+ collecting_aging_again = false;
+}
+
+/* Given a pointer to oldspace, copy it to newspace */
+static object *copy_untagged_object_impl(object *pointer, cell size)
+{
+ if(newspace->here + size >= newspace->end)
+ longjmp(gc_jmp,1);
+ object *newpointer = allot_zone(newspace,size);
+
+ gc_stats *s = &stats[collecting_gen];
+ s->object_count++;
+ s->bytes_copied += size;
+
+ memcpy(newpointer,pointer,size);
+ return newpointer;
+}
+
+static object *copy_object_impl(object *untagged)
+{
+ object *newpointer = copy_untagged_object_impl(untagged,untagged_object_size(untagged));
+ untagged->h.forward_to(newpointer);
+ return newpointer;
+}
+
+static bool should_copy_p(object *untagged)
+{
+ if(in_zone(newspace,untagged))
+ return false;
+ if(collecting_gen == TENURED)
+ return true;
+ else if(HAVE_AGING_P && collecting_gen == AGING)
+ return !in_zone(&data->generations[TENURED],untagged);
+ else if(collecting_gen == NURSERY)
+ return in_zone(&nursery,untagged);
+ else
+ {
+ critical_error("Bug in should_copy_p",(cell)untagged);
+ return false;
+ }
+}
+
+/* Follow a chain of forwarding pointers */
+static object *resolve_forwarding(object *untagged)
+{
+ check_data_pointer(untagged);
+
+ /* is there another forwarding pointer? */
+ if(untagged->h.forwarding_pointer_p())
+ return resolve_forwarding(untagged->h.forwarding_pointer());
+ /* we've found the destination */
+ else
+ {
+ untagged->h.check_header();
+ if(should_copy_p(untagged))
+ return copy_object_impl(untagged);
+ else
+ return untagged;
+ }
+}
+
+template <typename T> static T *copy_untagged_object(T *untagged)
+{
+ check_data_pointer(untagged);
+
+ if(untagged->h.forwarding_pointer_p())
+ untagged = (T *)resolve_forwarding(untagged->h.forwarding_pointer());
+ else
+ {
+ untagged->h.check_header();
+ untagged = (T *)copy_object_impl(untagged);
+ }
+
+ return untagged;
+}
+
+static cell copy_object(cell pointer)
+{
+ return RETAG(copy_untagged_object(untag<object>(pointer)),TAG(pointer));
+}
+
+void copy_handle(cell *handle)
+{
+ cell pointer = *handle;
+
+ if(!immediate_p(pointer))
+ {
+ object *obj = untag<object>(pointer);
+ check_data_pointer(obj);
+ if(should_copy_p(obj))
+ *handle = copy_object(pointer);
+ }
+}
+
+/* Scan all the objects in the card */
+static void copy_card(card *ptr, cell gen, cell here)
+{
+ cell card_scan = card_to_addr(ptr) + card_offset(ptr);
+ cell card_end = card_to_addr(ptr + 1);
+
+ if(here < card_end)
+ card_end = here;
+
+ copy_reachable_objects(card_scan,&card_end);
+
+ cards_scanned++;
+}
+
+static void copy_card_deck(card_deck *deck, cell gen, card mask, card unmask)
+{
+ card *first_card = deck_to_card(deck);
+ card *last_card = deck_to_card(deck + 1);
+
+ cell here = data->generations[gen].here;
+
+ u32 *quad_ptr;
+ u32 quad_mask = mask | (mask << 8) | (mask << 16) | (mask << 24);
+
+ for(quad_ptr = (u32 *)first_card; quad_ptr < (u32 *)last_card; quad_ptr++)
+ {
+ if(*quad_ptr & quad_mask)
+ {
+ card *ptr = (card *)quad_ptr;
+
+ int card;
+ for(card = 0; card < 4; card++)
+ {
+ if(ptr[card] & mask)
+ {
+ copy_card(&ptr[card],gen,here);
+ ptr[card] &= ~unmask;
+ }
+ }
+ }
+ }
+
+ decks_scanned++;
+}
+
+/* Copy all newspace objects referenced from marked cards to the destination */
+static void copy_gen_cards(cell gen)
+{
+ card_deck *first_deck = addr_to_deck(data->generations[gen].start);
+ card_deck *last_deck = addr_to_deck(data->generations[gen].end);
+
+ card mask, unmask;
+
+ /* if we are collecting the nursery, we care about old->nursery pointers
+ but not old->aging pointers */
+ if(collecting_gen == NURSERY)
+ {
+ mask = CARD_POINTS_TO_NURSERY;
+
+ /* after the collection, no old->nursery pointers remain
+ anywhere, but old->aging pointers might remain in tenured
+ space */
+ if(gen == TENURED)
+ unmask = CARD_POINTS_TO_NURSERY;
+ /* after the collection, all cards in aging space can be
+ cleared */
+ else if(HAVE_AGING_P && gen == AGING)
+ unmask = CARD_MARK_MASK;
+ else
+ {
+ critical_error("bug in copy_gen_cards",gen);
+ return;
+ }
+ }
+ /* if we are collecting aging space into tenured space, we care about
+ all old->nursery and old->aging pointers. no old->aging pointers can
+ remain */
+ else if(HAVE_AGING_P && collecting_gen == AGING)
+ {
+ if(collecting_aging_again)
+ {
+ mask = CARD_POINTS_TO_AGING;
+ unmask = CARD_MARK_MASK;
+ }
+ /* after we collect aging space into the aging semispace, no
+ old->nursery pointers remain but tenured space might still have
+ pointers to aging space. */
+ else
+ {
+ mask = CARD_POINTS_TO_AGING;
+ unmask = CARD_POINTS_TO_NURSERY;
+ }
+ }
+ else
+ {
+ critical_error("bug in copy_gen_cards",gen);
+ return;
+ }
+
+ card_deck *ptr;
+
+ for(ptr = first_deck; ptr < last_deck; ptr++)
+ {
+ if(*ptr & mask)
+ {
+ copy_card_deck(ptr,gen,mask,unmask);
+ *ptr &= ~unmask;
+ }
+ }
+}
+
+/* Scan cards in all generations older than the one being collected, copying
+old->new references */
+static void copy_cards(void)
+{
+ u64 start = current_micros();
+
+ cell i;
+ for(i = collecting_gen + 1; i < data->gen_count; i++)
+ copy_gen_cards(i);
+
+ card_scan_time += (current_micros() - start);
+}
+
+/* Copy all tagged pointers in a range of memory */
+static void copy_stack_elements(segment *region, cell top)
+{
+ cell ptr = region->start;
+
+ for(; ptr <= top; ptr += sizeof(cell))
+ copy_handle((cell*)ptr);
+}
+
+static void copy_registered_locals(void)
+{
+ cell scan = gc_locals_region->start;
+
+ for(; scan <= gc_locals; scan += sizeof(cell))
+ copy_handle(*(cell **)scan);
+}
+
+static void copy_registered_bignums(void)
+{
+ cell scan = gc_bignums_region->start;
+
+ for(; scan <= gc_bignums; scan += sizeof(cell))
+ {
+ bignum **handle = *(bignum ***)scan;
+ bignum *pointer = *handle;
+
+ if(pointer)
+ {
+ check_data_pointer(pointer);
+ if(should_copy_p(pointer))
+ *handle = copy_untagged_object(pointer);
+#ifdef FACTOR_DEBUG
+ assert((*handle)->h.hi_tag() == BIGNUM_TYPE);
+#endif
+ }
+ }
+}
+
+/* Copy roots over at the start of GC, namely various constants, stacks,
+the user environment and extra roots registered by local_roots.hpp */
+static void copy_roots(void)
+{
+ copy_handle(&T);
+ copy_handle(&bignum_zero);
+ copy_handle(&bignum_pos_one);
+ copy_handle(&bignum_neg_one);
+
+ copy_registered_locals();
+ copy_registered_bignums();
+
+ if(!performing_compaction)
+ {
+ save_stacks();
+ context *stacks = stack_chain;
+
+ while(stacks)
+ {
+ copy_stack_elements(stacks->datastack_region,stacks->datastack);
+ copy_stack_elements(stacks->retainstack_region,stacks->retainstack);
+
+ copy_handle(&stacks->catchstack_save);
+ copy_handle(&stacks->current_callback_save);
+
+ mark_active_blocks(stacks);
+
+ stacks = stacks->next;
+ }
+ }
+
+ int i;
+ for(i = 0; i < USER_ENV; i++)
+ copy_handle(&userenv[i]);
+}
+
+static cell copy_next_from_nursery(cell scan)
+{
+ cell *obj = (cell *)scan;
+ cell *end = (cell *)(scan + binary_payload_start((object *)scan));
+
+ if(obj != end)
+ {
+ obj++;
+
+ cell nursery_start = nursery.start;
+ cell nursery_end = nursery.end;
+
+ for(; obj < end; obj++)
+ {
+ cell pointer = *obj;
+
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer((object *)pointer);
+ if(pointer >= nursery_start && pointer < nursery_end)
+ *obj = copy_object(pointer);
+ }
+ }
+ }
+
+ return scan + untagged_object_size((object *)scan);
+}
+
+static cell copy_next_from_aging(cell scan)
+{
+ cell *obj = (cell *)scan;
+ cell *end = (cell *)(scan + binary_payload_start((object *)scan));
+
+ if(obj != end)
+ {
+ obj++;
+
+ cell tenured_start = data->generations[TENURED].start;
+ cell tenured_end = data->generations[TENURED].end;
+
+ cell newspace_start = newspace->start;
+ cell newspace_end = newspace->end;
+
+ for(; obj < end; obj++)
+ {
+ cell pointer = *obj;
+
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer((object *)pointer);
+ if(!(pointer >= newspace_start && pointer < newspace_end)
+ && !(pointer >= tenured_start && pointer < tenured_end))
+ *obj = copy_object(pointer);
+ }
+ }
+ }
+
+ return scan + untagged_object_size((object *)scan);
+}
+
+static cell copy_next_from_tenured(cell scan)
+{
+ cell *obj = (cell *)scan;
+ cell *end = (cell *)(scan + binary_payload_start((object *)scan));
+
+ if(obj != end)
+ {
+ obj++;
+
+ cell newspace_start = newspace->start;
+ cell newspace_end = newspace->end;
+
+ for(; obj < end; obj++)
+ {
+ cell pointer = *obj;
+
+ if(!immediate_p(pointer))
+ {
+ check_data_pointer((object *)pointer);
+ if(!(pointer >= newspace_start && pointer < newspace_end))
+ *obj = copy_object(pointer);
+ }
+ }
+ }
+
+ mark_object_code_block((object *)scan);
+
+ return scan + untagged_object_size((object *)scan);
+}
+
+void copy_reachable_objects(cell scan, cell *end)
+{
+ if(collecting_gen == NURSERY)
+ {
+ while(scan < *end)
+ scan = copy_next_from_nursery(scan);
+ }
+ else if(HAVE_AGING_P && collecting_gen == AGING)
+ {
+ while(scan < *end)
+ scan = copy_next_from_aging(scan);
+ }
+ else if(collecting_gen == TENURED)
+ {
+ while(scan < *end)
+ scan = copy_next_from_tenured(scan);
+ }
+}
+
+/* Prepare to start copying reachable objects into an unused zone */
+static void begin_gc(cell requested_bytes)
+{
+ if(growing_data_heap)
+ {
+ if(collecting_gen != TENURED)
+ critical_error("Invalid parameters to begin_gc",0);
+
+ old_data_heap = data;
+ set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
+ newspace = &data->generations[TENURED];
+ }
+ else if(collecting_accumulation_gen_p())
+ {
+ /* when collecting one of these generations, rotate it
+ with the semispace */
+ zone z = data->generations[collecting_gen];
+ data->generations[collecting_gen] = data->semispaces[collecting_gen];
+ data->semispaces[collecting_gen] = z;
+ reset_generation(collecting_gen);
+ newspace = &data->generations[collecting_gen];
+ clear_cards(collecting_gen,collecting_gen);
+ clear_decks(collecting_gen,collecting_gen);
+ clear_allot_markers(collecting_gen,collecting_gen);
+ }
+ else
+ {
+ /* when collecting a younger generation, we copy
+ reachable objects to the next oldest generation,
+ so we set the newspace so the next generation. */
+ newspace = &data->generations[collecting_gen + 1];
+ }
+}
+
+static void end_gc(cell gc_elapsed)
+{
+ gc_stats *s = &stats[collecting_gen];
+
+ s->collections++;
+ s->gc_time += gc_elapsed;
+ if(s->max_gc_time < gc_elapsed)
+ s->max_gc_time = gc_elapsed;
+
+ if(growing_data_heap)
+ {
+ dealloc_data_heap(old_data_heap);
+ old_data_heap = NULL;
+ growing_data_heap = false;
+ }
+
+ if(collecting_accumulation_gen_p())
+ {
+ /* all younger generations except are now empty.
+ if collecting_gen == NURSERY here, we only have 1 generation;
+ old-school Cheney collector */
+ if(collecting_gen != NURSERY)
+ reset_generations(NURSERY,collecting_gen - 1);
+ }
+ else if(collecting_gen == NURSERY)
+ {
+ nursery.here = nursery.start;
+ }
+ else
+ {
+ /* all generations up to and including the one
+ collected are now empty */
+ reset_generations(NURSERY,collecting_gen);
+ }
+
+ collecting_aging_again = false;
+}
+
+/* Collect gen and all younger generations.
+If growing_data_heap_ is true, we must grow the data heap to such a size that
+an allocation of requested_bytes won't fail */
+void garbage_collection(cell gen,
+ bool growing_data_heap_,
+ cell requested_bytes)
+{
+ if(gc_off)
+ {
+ critical_error("GC disabled",gen);
+ return;
+ }
+
+ u64 start = current_micros();
+
+ performing_gc = true;
+ growing_data_heap = growing_data_heap_;
+ collecting_gen = gen;
+
+ /* we come back here if a generation is full */
+ if(setjmp(gc_jmp))
+ {
+ /* We have no older generations we can try collecting, so we
+ resort to growing the data heap */
+ if(collecting_gen == TENURED)
+ {
+ growing_data_heap = true;
+
+ /* see the comment in unmark_marked() */
+ unmark_marked(&code);
+ }
+ /* we try collecting AGING space twice before going on to
+ collect TENURED */
+ else if(HAVE_AGING_P
+ && collecting_gen == AGING
+ && !collecting_aging_again)
+ {
+ collecting_aging_again = true;
+ }
+ /* Collect the next oldest generation */
+ else
+ {
+ collecting_gen++;
+ }
+ }
+
+ begin_gc(requested_bytes);
+
+ /* initialize chase pointer */
+ cell scan = newspace->here;
+
+ /* collect objects referenced from stacks and environment */
+ copy_roots();
+ /* collect objects referenced from older generations */
+ copy_cards();
+
+ /* do some tracing */
+ copy_reachable_objects(scan,&newspace->here);
+
+ /* don't scan code heap unless it has pointers to this
+ generation or younger */
+ if(collecting_gen >= last_code_heap_scan)
+ {
+ code_heap_scans++;
+
+ if(collecting_gen == TENURED)
+ free_unmarked(&code,(heap_iterator)update_literal_and_word_references);
+ else
+ copy_code_heap_roots();
+
+ if(collecting_accumulation_gen_p())
+ last_code_heap_scan = collecting_gen;
+ else
+ last_code_heap_scan = collecting_gen + 1;
+ }
+
+ cell gc_elapsed = (current_micros() - start);
+
+ end_gc(gc_elapsed);
+
+ performing_gc = false;
+}
+
+void gc(void)
+{
+ garbage_collection(TENURED,false,0);
+}
+
+PRIMITIVE(gc)
+{
+ gc();
+}
+
+PRIMITIVE(gc_stats)
+{
+ growable_array result;
+
+ cell i;
+ u64 total_gc_time = 0;
+
+ for(i = 0; i < MAX_GEN_COUNT; i++)
+ {
+ gc_stats *s = &stats[i];
+ result.add(allot_cell(s->collections));
+ result.add(tag<bignum>(long_long_to_bignum(s->gc_time)));
+ result.add(tag<bignum>(long_long_to_bignum(s->max_gc_time)));
+ result.add(allot_cell(s->collections == 0 ? 0 : s->gc_time / s->collections));
+ result.add(allot_cell(s->object_count));
+ result.add(tag<bignum>(long_long_to_bignum(s->bytes_copied)));
+
+ total_gc_time += s->gc_time;
+ }
+
+ result.add(tag<bignum>(ulong_long_to_bignum(total_gc_time)));
+ result.add(tag<bignum>(ulong_long_to_bignum(cards_scanned)));
+ result.add(tag<bignum>(ulong_long_to_bignum(decks_scanned)));
+ result.add(tag<bignum>(ulong_long_to_bignum(card_scan_time)));
+ result.add(allot_cell(code_heap_scans));
+
+ result.trim();
+ dpush(result.elements.value());
+}
+
+void clear_gc_stats(void)
+{
+ int i;
+ for(i = 0; i < MAX_GEN_COUNT; i++)
+ memset(&stats[i],0,sizeof(gc_stats));
+
+ cards_scanned = 0;
+ decks_scanned = 0;
+ card_scan_time = 0;
+ code_heap_scans = 0;
+}
+
+PRIMITIVE(clear_gc_stats)
+{
+ clear_gc_stats();
+}
+
+/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
+ to coalesce equal but distinct quotations and wrappers. */
+PRIMITIVE(become)
+{
+ array *new_objects = untag_check<array>(dpop());
+ array *old_objects = untag_check<array>(dpop());
+
+ cell capacity = array_capacity(new_objects);
+ if(capacity != array_capacity(old_objects))
+ critical_error("bad parameters to become",0);
+
+ cell i;
+
+ for(i = 0; i < capacity; i++)
+ {
+ tagged<object> old_obj(array_nth(old_objects,i));
+ tagged<object> new_obj(array_nth(new_objects,i));
+
+ if(old_obj != new_obj)
+ old_obj->h.forward_to(new_obj.untagged());
+ }
+
+ gc();
+
+ /* If a word's definition quotation was in old_objects and the
+ quotation in new_objects is not compiled, we might leak memory
+ by referencing the old quotation unless we recompile all
+ unoptimized words. */
+ compile_all_words();
+}
+
+VM_C_API void minor_gc(void)
+{
+ garbage_collection(NURSERY,false,0);
+}
+
+}
diff --git a/vm/data_gc.h b/vm/data_gc.h
deleted file mode 100755
index 354c9398a5..0000000000
--- a/vm/data_gc.h
+++ /dev/null
@@ -1,138 +0,0 @@
-void gc(void);
-DLLEXPORT void minor_gc(void);
-
-/* used during garbage collection only */
-
-F_ZONE *newspace;
-bool performing_gc;
-CELL collecting_gen;
-
-/* if true, we collecting AGING space for the second time, so if it is still
-full, we go on to collect TENURED */
-bool collecting_aging_again;
-
-/* in case a generation fills up in the middle of a gc, we jump back
-up to try collecting the next generation. */
-jmp_buf gc_jmp;
-
-/* statistics */
-typedef struct {
- CELL collections;
- u64 gc_time;
- u64 max_gc_time;
- CELL object_count;
- u64 bytes_copied;
-} F_GC_STATS;
-
-F_GC_STATS gc_stats[MAX_GEN_COUNT];
-u64 cards_scanned;
-u64 decks_scanned;
-CELL code_heap_scans;
-
-/* What generation was being collected when copy_code_heap_roots() was last
-called? Until the next call to add_code_block(), future
-collections of younger generations don't have to touch the code
-heap. */
-CELL last_code_heap_scan;
-
-/* sometimes we grow the heap */
-bool growing_data_heap;
-F_DATA_HEAP *old_data_heap;
-
-INLINE bool collecting_accumulation_gen_p(void)
-{
- return ((HAVE_AGING_P
- && collecting_gen == AGING
- && !collecting_aging_again)
- || collecting_gen == TENURED);
-}
-
-/* test if the pointer is in generation being collected, or a younger one. */
-INLINE bool should_copy(CELL untagged)
-{
- if(in_zone(newspace,untagged))
- return false;
- if(collecting_gen == TENURED)
- return true;
- else if(HAVE_AGING_P && collecting_gen == AGING)
- return !in_zone(&data_heap->generations[TENURED],untagged);
- else if(HAVE_NURSERY_P && collecting_gen == NURSERY)
- return in_zone(&nursery,untagged);
- else
- {
- critical_error("Bug in should_copy",untagged);
- return false;
- }
-}
-
-void copy_handle(CELL *handle);
-
-void garbage_collection(volatile CELL gen,
- bool growing_data_heap_,
- CELL requested_bytes);
-
-/* We leave this many bytes free at the top of the nursery so that inline
-allocation (which does not call GC because of possible roots in volatile
-registers) does not run out of memory */
-#define ALLOT_BUFFER_ZONE 1024
-
-/*
- * It is up to the caller to fill in the object's fields in a meaningful
- * fashion!
- */
-INLINE void *allot_object(CELL type, CELL a)
-{
- CELL *object;
-
- if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a)
- {
- /* If there is insufficient room, collect the nursery */
- if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end)
- garbage_collection(NURSERY,false,0);
-
- CELL h = nursery.here;
- nursery.here = h + align8(a);
- object = (void*)h;
- }
- /* If the object is bigger than the nursery, allocate it in
- tenured space */
- else
- {
- F_ZONE *tenured = &data_heap->generations[TENURED];
-
- /* If tenured space does not have enough room, collect */
- if(tenured->here + a > tenured->end)
- {
- gc();
- tenured = &data_heap->generations[TENURED];
- }
-
- /* If it still won't fit, grow the heap */
- if(tenured->here + a > tenured->end)
- {
- garbage_collection(TENURED,true,a);
- tenured = &data_heap->generations[TENURED];
- }
-
- object = allot_zone(tenured,a);
-
- /* We have to do this */
- allot_barrier((CELL)object);
-
- /* Allows initialization code to store old->new pointers
- without hitting the write barrier in the common case of
- a nursery allocation */
- write_barrier((CELL)object);
- }
-
- *object = tag_header(type);
- return object;
-}
-
-void copy_reachable_objects(CELL scan, CELL *end);
-
-void primitive_gc(void);
-void primitive_gc_stats(void);
-void clear_gc_stats(void);
-void primitive_clear_gc_stats(void);
-void primitive_become(void);
diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp
new file mode 100755
index 0000000000..2869179394
--- /dev/null
+++ b/vm/data_gc.hpp
@@ -0,0 +1,148 @@
+namespace factor
+{
+
+/* statistics */
+struct gc_stats {
+ cell collections;
+ u64 gc_time;
+ u64 max_gc_time;
+ cell object_count;
+ u64 bytes_copied;
+};
+
+extern zone *newspace;
+
+extern bool performing_compaction;
+extern cell collecting_gen;
+extern bool collecting_aging_again;
+
+extern cell last_code_heap_scan;
+
+void init_data_gc(void);
+
+void gc(void);
+
+inline static bool collecting_accumulation_gen_p(void)
+{
+ return ((HAVE_AGING_P
+ && collecting_gen == AGING
+ && !collecting_aging_again)
+ || collecting_gen == TENURED);
+}
+
+void copy_handle(cell *handle);
+
+void garbage_collection(volatile cell gen,
+ bool growing_data_heap_,
+ cell requested_bytes);
+
+/* We leave this many bytes free at the top of the nursery so that inline
+allocation (which does not call GC because of possible roots in volatile
+registers) does not run out of memory */
+#define ALLOT_BUFFER_ZONE 1024
+
+inline static object *allot_zone(zone *z, cell a)
+{
+ cell h = z->here;
+ z->here = h + align8(a);
+ object *obj = (object *)h;
+ allot_barrier(obj);
+ return obj;
+}
+
+/*
+ * It is up to the caller to fill in the object's fields in a meaningful
+ * fashion!
+ */
+inline static object *allot_object(header header, cell size)
+{
+#ifdef GC_DEBUG
+ if(!gc_off)
+ gc();
+#endif
+
+ object *obj;
+
+ if(nursery.size - ALLOT_BUFFER_ZONE > size)
+ {
+ /* If there is insufficient room, collect the nursery */
+ if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end)
+ garbage_collection(NURSERY,false,0);
+
+ cell h = nursery.here;
+ nursery.here = h + align8(size);
+ obj = (object *)h;
+ }
+ /* If the object is bigger than the nursery, allocate it in
+ tenured space */
+ else
+ {
+ zone *tenured = &data->generations[TENURED];
+
+ /* If tenured space does not have enough room, collect */
+ if(tenured->here + size > tenured->end)
+ {
+ gc();
+ tenured = &data->generations[TENURED];
+ }
+
+ /* If it still won't fit, grow the heap */
+ if(tenured->here + size > tenured->end)
+ {
+ garbage_collection(TENURED,true,size);
+ tenured = &data->generations[TENURED];
+ }
+
+ obj = allot_zone(tenured,size);
+
+ /* Allows initialization code to store old->new pointers
+ without hitting the write barrier in the common case of
+ a nursery allocation */
+ write_barrier(obj);
+ }
+
+ obj->h = header;
+ return obj;
+}
+
+template<typename T> T *allot(cell size)
+{
+ return (T *)allot_object(header(T::type_number),size);
+}
+
+void copy_reachable_objects(cell scan, cell *end);
+
+PRIMITIVE(gc);
+PRIMITIVE(gc_stats);
+void clear_gc_stats(void);
+PRIMITIVE(clear_gc_stats);
+PRIMITIVE(become);
+
+extern bool growing_data_heap;
+
+inline static void check_data_pointer(object *pointer)
+{
+#ifdef FACTOR_DEBUG
+ if(!growing_data_heap)
+ {
+ assert((cell)pointer >= data->seg->start
+ && (cell)pointer < data->seg->end);
+ }
+#endif
+}
+
+inline static void check_tagged_pointer(cell tagged)
+{
+#ifdef FACTOR_DEBUG
+ if(!immediate_p(tagged))
+ {
+ object *obj = untag<object>(tagged);
+ check_data_pointer(obj);
+ obj->h.hi_tag();
+ }
+#endif
+}
+
+VM_C_API void minor_gc(void);
+
+}
diff --git a/vm/data_heap.c b/vm/data_heap.c
deleted file mode 100644
index c5aa42aebe..0000000000
--- a/vm/data_heap.c
+++ /dev/null
@@ -1,371 +0,0 @@
-#include "master.h"
-
-CELL init_zone(F_ZONE *z, CELL size, CELL start)
-{
- z->size = size;
- z->start = z->here = start;
- z->end = start + size;
- return z->end;
-}
-
-void init_card_decks(void)
-{
- CELL start = align(data_heap->segment->start,DECK_SIZE);
- allot_markers_offset = (CELL)data_heap->allot_markers - (start >> CARD_BITS);
- cards_offset = (CELL)data_heap->cards - (start >> CARD_BITS);
- decks_offset = (CELL)data_heap->decks - (start >> DECK_BITS);
-}
-
-F_DATA_HEAP *alloc_data_heap(CELL gens,
- CELL young_size,
- CELL aging_size,
- CELL tenured_size)
-{
- young_size = align(young_size,DECK_SIZE);
- aging_size = align(aging_size,DECK_SIZE);
- tenured_size = align(tenured_size,DECK_SIZE);
-
- F_DATA_HEAP *data_heap = safe_malloc(sizeof(F_DATA_HEAP));
- data_heap->young_size = young_size;
- data_heap->aging_size = aging_size;
- data_heap->tenured_size = tenured_size;
- data_heap->gen_count = gens;
-
- CELL total_size;
- if(data_heap->gen_count == 2)
- total_size = young_size + 2 * tenured_size;
- else if(data_heap->gen_count == 3)
- total_size = young_size + 2 * aging_size + 2 * tenured_size;
- else
- {
- fatal_error("Invalid number of generations",data_heap->gen_count);
- return NULL; /* can't happen */
- }
-
- total_size += DECK_SIZE;
-
- data_heap->segment = alloc_segment(total_size);
-
- data_heap->generations = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
- data_heap->semispaces = safe_malloc(sizeof(F_ZONE) * data_heap->gen_count);
-
- CELL cards_size = total_size >> CARD_BITS;
- data_heap->allot_markers = safe_malloc(cards_size);
- data_heap->allot_markers_end = data_heap->allot_markers + cards_size;
-
- data_heap->cards = safe_malloc(cards_size);
- data_heap->cards_end = data_heap->cards + cards_size;
-
- CELL decks_size = total_size >> DECK_BITS;
- data_heap->decks = safe_malloc(decks_size);
- data_heap->decks_end = data_heap->decks + decks_size;
-
- CELL alloter = align(data_heap->segment->start,DECK_SIZE);
-
- alloter = init_zone(&data_heap->generations[TENURED],tenured_size,alloter);
- alloter = init_zone(&data_heap->semispaces[TENURED],tenured_size,alloter);
-
- if(data_heap->gen_count == 3)
- {
- alloter = init_zone(&data_heap->generations[AGING],aging_size,alloter);
- alloter = init_zone(&data_heap->semispaces[AGING],aging_size,alloter);
- }
-
- if(data_heap->gen_count >= 2)
- {
- alloter = init_zone(&data_heap->generations[NURSERY],young_size,alloter);
- alloter = init_zone(&data_heap->semispaces[NURSERY],0,alloter);
- }
-
- if(data_heap->segment->end - alloter > DECK_SIZE)
- critical_error("Bug in alloc_data_heap",alloter);
-
- return data_heap;
-}
-
-F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes)
-{
- CELL new_tenured_size = (data_heap->tenured_size * 2) + requested_bytes;
-
- return alloc_data_heap(data_heap->gen_count,
- data_heap->young_size,
- data_heap->aging_size,
- new_tenured_size);
-}
-
-void dealloc_data_heap(F_DATA_HEAP *data_heap)
-{
- dealloc_segment(data_heap->segment);
- free(data_heap->generations);
- free(data_heap->semispaces);
- free(data_heap->allot_markers);
- free(data_heap->cards);
- free(data_heap->decks);
- free(data_heap);
-}
-
-void clear_cards(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- F_CARD *first_card = ADDR_TO_CARD(data_heap->generations[to].start);
- F_CARD *last_card = ADDR_TO_CARD(data_heap->generations[from].end);
- memset(first_card,0,last_card - first_card);
-}
-
-void clear_decks(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- F_DECK *first_deck = ADDR_TO_DECK(data_heap->generations[to].start);
- F_DECK *last_deck = ADDR_TO_DECK(data_heap->generations[from].end);
- memset(first_deck,0,last_deck - first_deck);
-}
-
-void clear_allot_markers(CELL from, CELL to)
-{
- /* NOTE: reverse order due to heap layout. */
- F_CARD *first_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[to].start);
- F_CARD *last_card = ADDR_TO_ALLOT_MARKER(data_heap->generations[from].end);
- memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
-}
-
-void reset_generation(CELL i)
-{
- F_ZONE *z = (i == NURSERY ? &nursery : &data_heap->generations[i]);
-
- z->here = z->start;
- if(secure_gc)
- memset((void*)z->start,69,z->size);
-}
-
-/* After garbage collection, any generations which are now empty need to have
-their allocation pointers and cards reset. */
-void reset_generations(CELL from, CELL to)
-{
- CELL i;
- for(i = from; i <= to; i++)
- reset_generation(i);
-
- clear_cards(from,to);
- clear_decks(from,to);
- clear_allot_markers(from,to);
-}
-
-void set_data_heap(F_DATA_HEAP *data_heap_)
-{
- data_heap = data_heap_;
- nursery = data_heap->generations[NURSERY];
- init_card_decks();
- clear_cards(NURSERY,TENURED);
- clear_decks(NURSERY,TENURED);
- clear_allot_markers(NURSERY,TENURED);
-}
-
-void init_data_heap(CELL gens,
- CELL young_size,
- CELL aging_size,
- CELL tenured_size,
- bool secure_gc_)
-{
- set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
-
- gc_locals_region = alloc_segment(getpagesize());
- gc_locals = gc_locals_region->start - CELLS;
-
- extra_roots_region = alloc_segment(getpagesize());
- extra_roots = extra_roots_region->start - CELLS;
-
- secure_gc = secure_gc_;
-}
-
-/* Size of the object pointed to by a tagged pointer */
-CELL object_size(CELL tagged)
-{
- if(immediate_p(tagged))
- return 0;
- else
- return untagged_object_size(UNTAG(tagged));
-}
-
-/* Size of the object pointed to by an untagged pointer */
-CELL untagged_object_size(CELL pointer)
-{
- return align8(unaligned_object_size(pointer));
-}
-
-/* Size of the data area of an object pointed to by an untagged pointer */
-CELL unaligned_object_size(CELL pointer)
-{
- F_TUPLE *tuple;
- F_TUPLE_LAYOUT *layout;
-
- switch(untag_header(get(pointer)))
- {
- case ARRAY_TYPE:
- case BIGNUM_TYPE:
- return array_size(array_capacity((F_ARRAY*)pointer));
- case BYTE_ARRAY_TYPE:
- return byte_array_size(
- byte_array_capacity((F_BYTE_ARRAY*)pointer));
- case STRING_TYPE:
- return string_size(string_capacity((F_STRING*)pointer));
- case TUPLE_TYPE:
- tuple = untag_object(pointer);
- layout = untag_object(tuple->layout);
- return tuple_size(layout);
- case QUOTATION_TYPE:
- return sizeof(F_QUOTATION);
- case WORD_TYPE:
- return sizeof(F_WORD);
- case RATIO_TYPE:
- return sizeof(F_RATIO);
- case FLOAT_TYPE:
- return sizeof(F_FLOAT);
- case COMPLEX_TYPE:
- return sizeof(F_COMPLEX);
- case DLL_TYPE:
- return sizeof(F_DLL);
- case ALIEN_TYPE:
- return sizeof(F_ALIEN);
- case WRAPPER_TYPE:
- return sizeof(F_WRAPPER);
- case CALLSTACK_TYPE:
- return callstack_size(
- untag_fixnum_fast(((F_CALLSTACK *)pointer)->length));
- default:
- critical_error("Invalid header",pointer);
- return -1; /* can't happen */
- }
-}
-
-void primitive_size(void)
-{
- box_unsigned_cell(object_size(dpop()));
-}
-
-/* The number of cells from the start of the object which should be scanned by
-the GC. Some types have a binary payload at the end (string, word, DLL) which
-we ignore. */
-CELL binary_payload_start(CELL pointer)
-{
- F_TUPLE *tuple;
- F_TUPLE_LAYOUT *layout;
-
- switch(untag_header(get(pointer)))
- {
- /* these objects do not refer to other objects at all */
- case FLOAT_TYPE:
- case BYTE_ARRAY_TYPE:
- case BIGNUM_TYPE:
- case CALLSTACK_TYPE:
- return 0;
- /* these objects have some binary data at the end */
- case WORD_TYPE:
- return sizeof(F_WORD) - CELLS * 3;
- case ALIEN_TYPE:
- return CELLS * 3;
- case DLL_TYPE:
- return CELLS * 2;
- case QUOTATION_TYPE:
- return sizeof(F_QUOTATION) - CELLS * 2;
- case STRING_TYPE:
- return sizeof(F_STRING);
- /* everything else consists entirely of pointers */
- case ARRAY_TYPE:
- return array_size(array_capacity((F_ARRAY*)pointer));
- case TUPLE_TYPE:
- tuple = untag_object(pointer);
- layout = untag_object(tuple->layout);
- return tuple_size(layout);
- case RATIO_TYPE:
- return sizeof(F_RATIO);
- case COMPLEX_TYPE:
- return sizeof(F_COMPLEX);
- case WRAPPER_TYPE:
- return sizeof(F_WRAPPER);
- default:
- critical_error("Invalid header",pointer);
- return -1; /* can't happen */
- }
-}
-
-/* Push memory usage statistics in data heap */
-void primitive_data_room(void)
-{
- F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F);
- int gen;
-
- dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10));
- dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10));
-
- for(gen = 0; gen < data_heap->gen_count; gen++)
- {
- F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]);
- set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10));
- set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10));
- }
-
- dpush(tag_object(a));
-}
-
-/* Disables GC and activates next-object ( -- obj ) primitive */
-void begin_scan(void)
-{
- heap_scan_ptr = data_heap->generations[TENURED].start;
- gc_off = true;
-}
-
-void primitive_begin_scan(void)
-{
- begin_scan();
-}
-
-CELL next_object(void)
-{
- if(!gc_off)
- general_error(ERROR_HEAP_SCAN,F,F,NULL);
-
- CELL value = get(heap_scan_ptr);
- CELL obj = heap_scan_ptr;
- CELL type;
-
- if(heap_scan_ptr >= data_heap->generations[TENURED].here)
- return F;
-
- type = untag_header(value);
- heap_scan_ptr += untagged_object_size(heap_scan_ptr);
-
- return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE);
-}
-
-/* Push object at heap scan cursor and advance; pushes f when done */
-void primitive_next_object(void)
-{
- dpush(next_object());
-}
-
-/* Re-enables GC */
-void primitive_end_scan(void)
-{
- gc_off = false;
-}
-
-CELL find_all_words(void)
-{
- GROWABLE_ARRAY(words);
-
- begin_scan();
-
- CELL obj;
- while((obj = next_object()) != F)
- {
- if(type_of(obj) == WORD_TYPE)
- GROWABLE_ARRAY_ADD(words,obj);
- }
-
- /* End heap scan */
- gc_off = false;
-
- GROWABLE_ARRAY_TRIM(words);
-
- return words;
-}
diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp
new file mode 100644
index 0000000000..d83773de9c
--- /dev/null
+++ b/vm/data_heap.cpp
@@ -0,0 +1,371 @@
+#include "master.hpp"
+
+factor::zone nursery;
+
+namespace factor
+{
+
+/* Set by the -securegc command line argument */
+bool secure_gc;
+
+/* new objects are allocated here */
+VM_C_API zone nursery;
+
+/* GC is off during heap walking */
+bool gc_off;
+
+data_heap *data;
+
+cell init_zone(zone *z, cell size, cell start)
+{
+ z->size = size;
+ z->start = z->here = start;
+ z->end = start + size;
+ return z->end;
+}
+
+void init_card_decks(void)
+{
+ cell start = align(data->seg->start,DECK_SIZE);
+ allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS);
+ cards_offset = (cell)data->cards - (start >> CARD_BITS);
+ decks_offset = (cell)data->decks - (start >> DECK_BITS);
+}
+
+data_heap *alloc_data_heap(cell gens,
+ cell young_size,
+ cell aging_size,
+ cell tenured_size)
+{
+ young_size = align(young_size,DECK_SIZE);
+ aging_size = align(aging_size,DECK_SIZE);
+ tenured_size = align(tenured_size,DECK_SIZE);
+
+ data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
+ data->young_size = young_size;
+ data->aging_size = aging_size;
+ data->tenured_size = tenured_size;
+ data->gen_count = gens;
+
+ cell total_size;
+ if(data->gen_count == 2)
+ total_size = young_size + 2 * tenured_size;
+ else if(data->gen_count == 3)
+ total_size = young_size + 2 * aging_size + 2 * tenured_size;
+ else
+ {
+ fatal_error("Invalid number of generations",data->gen_count);
+ return NULL; /* can't happen */
+ }
+
+ total_size += DECK_SIZE;
+
+ data->seg = alloc_segment(total_size);
+
+ data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
+ data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
+
+ cell cards_size = total_size >> CARD_BITS;
+ data->allot_markers = (cell *)safe_malloc(cards_size);
+ data->allot_markers_end = data->allot_markers + cards_size;
+
+ data->cards = (cell *)safe_malloc(cards_size);
+ data->cards_end = data->cards + cards_size;
+
+ cell decks_size = total_size >> DECK_BITS;
+ data->decks = (cell *)safe_malloc(decks_size);
+ data->decks_end = data->decks + decks_size;
+
+ cell alloter = align(data->seg->start,DECK_SIZE);
+
+ alloter = init_zone(&data->generations[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter);
+
+ if(data->gen_count == 3)
+ {
+ alloter = init_zone(&data->generations[AGING],aging_size,alloter);
+ alloter = init_zone(&data->semispaces[AGING],aging_size,alloter);
+ }
+
+ if(data->gen_count >= 2)
+ {
+ alloter = init_zone(&data->generations[NURSERY],young_size,alloter);
+ alloter = init_zone(&data->semispaces[NURSERY],0,alloter);
+ }
+
+ if(data->seg->end - alloter > DECK_SIZE)
+ critical_error("Bug in alloc_data_heap",alloter);
+
+ return data;
+}
+
+data_heap *grow_data_heap(data_heap *data, cell requested_bytes)
+{
+ cell new_tenured_size = (data->tenured_size * 2) + requested_bytes;
+
+ return alloc_data_heap(data->gen_count,
+ data->young_size,
+ data->aging_size,
+ new_tenured_size);
+}
+
+void dealloc_data_heap(data_heap *data)
+{
+ dealloc_segment(data->seg);
+ free(data->generations);
+ free(data->semispaces);
+ free(data->allot_markers);
+ free(data->cards);
+ free(data->decks);
+ free(data);
+}
+
+void clear_cards(cell from, cell to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ card *first_card = addr_to_card(data->generations[to].start);
+ card *last_card = addr_to_card(data->generations[from].end);
+ memset(first_card,0,last_card - first_card);
+}
+
+void clear_decks(cell from, cell to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ card_deck *first_deck = addr_to_deck(data->generations[to].start);
+ card_deck *last_deck = addr_to_deck(data->generations[from].end);
+ memset(first_deck,0,last_deck - first_deck);
+}
+
+void clear_allot_markers(cell from, cell to)
+{
+ /* NOTE: reverse order due to heap layout. */
+ card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
+ card *last_card = addr_to_allot_marker((object *)data->generations[from].end);
+ memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
+}
+
+void reset_generation(cell i)
+{
+ zone *z = (i == NURSERY ? &nursery : &data->generations[i]);
+
+ z->here = z->start;
+ if(secure_gc)
+ memset((void*)z->start,69,z->size);
+}
+
+/* After garbage collection, any generations which are now empty need to have
+their allocation pointers and cards reset. */
+void reset_generations(cell from, cell to)
+{
+ cell i;
+ for(i = from; i <= to; i++)
+ reset_generation(i);
+
+ clear_cards(from,to);
+ clear_decks(from,to);
+ clear_allot_markers(from,to);
+}
+
+void set_data_heap(data_heap *data_)
+{
+ data = data_;
+ nursery = data->generations[NURSERY];
+ init_card_decks();
+ clear_cards(NURSERY,TENURED);
+ clear_decks(NURSERY,TENURED);
+ clear_allot_markers(NURSERY,TENURED);
+}
+
+void init_data_heap(cell gens,
+ cell young_size,
+ cell aging_size,
+ cell tenured_size,
+ bool secure_gc_)
+{
+ set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
+
+ gc_locals_region = alloc_segment(getpagesize());
+ gc_locals = gc_locals_region->start - sizeof(cell);
+
+ gc_bignums_region = alloc_segment(getpagesize());
+ gc_bignums = gc_bignums_region->start - sizeof(cell);
+
+ secure_gc = secure_gc_;
+
+ init_data_gc();
+}
+
+/* Size of the object pointed to by a tagged pointer */
+cell object_size(cell tagged)
+{
+ if(immediate_p(tagged))
+ return 0;
+ else
+ return untagged_object_size(untag<object>(tagged));
+}
+
+/* Size of the object pointed to by an untagged pointer */
+cell untagged_object_size(object *pointer)
+{
+ return align8(unaligned_object_size(pointer));
+}
+
+/* Size of the data area of an object pointed to by an untagged pointer */
+cell unaligned_object_size(object *pointer)
+{
+ switch(pointer->h.hi_tag())
+ {
+ case ARRAY_TYPE:
+ return array_size((array*)pointer);
+ case BIGNUM_TYPE:
+ return array_size((bignum*)pointer);
+ case BYTE_ARRAY_TYPE:
+ return array_size((byte_array*)pointer);
+ case STRING_TYPE:
+ return string_size(string_capacity((string*)pointer));
+ case TUPLE_TYPE:
+ return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
+ case QUOTATION_TYPE:
+ return sizeof(quotation);
+ case WORD_TYPE:
+ return sizeof(word);
+ case FLOAT_TYPE:
+ return sizeof(boxed_float);
+ case DLL_TYPE:
+ return sizeof(dll);
+ case ALIEN_TYPE:
+ return sizeof(alien);
+ case WRAPPER_TYPE:
+ return sizeof(wrapper);
+ case CALLSTACK_TYPE:
+ return callstack_size(untag_fixnum(((callstack *)pointer)->length));
+ default:
+ critical_error("Invalid header",(cell)pointer);
+ return -1; /* can't happen */
+ }
+}
+
+PRIMITIVE(size)
+{
+ box_unsigned_cell(object_size(dpop()));
+}
+
+/* The number of cells from the start of the object which should be scanned by
+the GC. Some types have a binary payload at the end (string, word, DLL) which
+we ignore. */
+cell binary_payload_start(object *pointer)
+{
+ switch(pointer->h.hi_tag())
+ {
+ /* these objects do not refer to other objects at all */
+ case FLOAT_TYPE:
+ case BYTE_ARRAY_TYPE:
+ case BIGNUM_TYPE:
+ case CALLSTACK_TYPE:
+ return 0;
+ /* these objects have some binary data at the end */
+ case WORD_TYPE:
+ return sizeof(word) - sizeof(cell) * 3;
+ case ALIEN_TYPE:
+ return sizeof(cell) * 3;
+ case DLL_TYPE:
+ return sizeof(cell) * 2;
+ case QUOTATION_TYPE:
+ return sizeof(quotation) - sizeof(cell) * 2;
+ case STRING_TYPE:
+ return sizeof(string);
+ /* everything else consists entirely of pointers */
+ case ARRAY_TYPE:
+ return array_size<array>(array_capacity((array*)pointer));
+ case TUPLE_TYPE:
+ return tuple_size(untag<tuple_layout>(((tuple *)pointer)->layout));
+ case WRAPPER_TYPE:
+ return sizeof(wrapper);
+ default:
+ critical_error("Invalid header",(cell)pointer);
+ return -1; /* can't happen */
+ }
+}
+
+/* Push memory usage statistics in data heap */
+PRIMITIVE(data_room)
+{
+ dpush(tag_fixnum((data->cards_end - data->cards) >> 10));
+ dpush(tag_fixnum((data->decks_end - data->decks) >> 10));
+
+ growable_array a;
+
+ cell gen;
+ for(gen = 0; gen < data->gen_count; gen++)
+ {
+ zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]);
+ a.add(tag_fixnum((z->end - z->here) >> 10));
+ a.add(tag_fixnum((z->size) >> 10));
+ }
+
+ a.trim();
+ dpush(a.elements.value());
+}
+
+/* A heap walk allows useful things to be done, like finding all
+references to an object for debugging purposes. */
+cell heap_scan_ptr;
+
+/* Disables GC and activates next-object ( -- obj ) primitive */
+void begin_scan(void)
+{
+ heap_scan_ptr = data->generations[TENURED].start;
+ gc_off = true;
+}
+
+PRIMITIVE(begin_scan)
+{
+ begin_scan();
+}
+
+cell next_object(void)
+{
+ if(!gc_off)
+ general_error(ERROR_HEAP_SCAN,F,F,NULL);
+
+ if(heap_scan_ptr >= data->generations[TENURED].here)
+ return F;
+
+ object *obj = (object *)heap_scan_ptr;
+ heap_scan_ptr += untagged_object_size(obj);
+ return tag_dynamic(obj);
+}
+
+/* Push object at heap scan cursor and advance; pushes f when done */
+PRIMITIVE(next_object)
+{
+ dpush(next_object());
+}
+
+/* Re-enables GC */
+PRIMITIVE(end_scan)
+{
+ gc_off = false;
+}
+
+cell find_all_words(void)
+{
+ growable_array words;
+
+ begin_scan();
+
+ cell obj;
+ while((obj = next_object()) != F)
+ {
+ if(tagged<object>(obj).type_p(WORD_TYPE))
+ words.add(obj);
+ }
+
+ /* End heap scan */
+ gc_off = false;
+
+ words.trim();
+ return words.elements.value();
+}
+
+}
diff --git a/vm/data_heap.h b/vm/data_heap.h
deleted file mode 100644
index a7f44e73f8..0000000000
--- a/vm/data_heap.h
+++ /dev/null
@@ -1,138 +0,0 @@
-/* Set by the -securegc command line argument */
-bool secure_gc;
-
-/* generational copying GC divides memory into zones */
-typedef struct {
- /* allocation pointer is 'here'; its offset is hardcoded in the
- compiler backends*/
- CELL start;
- CELL here;
- CELL size;
- CELL end;
-} F_ZONE;
-
-typedef struct {
- F_SEGMENT *segment;
-
- CELL young_size;
- CELL aging_size;
- CELL tenured_size;
-
- CELL gen_count;
-
- F_ZONE *generations;
- F_ZONE* semispaces;
-
- CELL *allot_markers;
- CELL *allot_markers_end;
-
- CELL *cards;
- CELL *cards_end;
-
- CELL *decks;
- CELL *decks_end;
-} F_DATA_HEAP;
-
-F_DATA_HEAP *data_heap;
-
-/* the 0th generation is where new objects are allocated. */
-#define NURSERY 0
-#define HAVE_NURSERY_P (data_heap->gen_count>1)
-/* where objects hang around */
-#define AGING (data_heap->gen_count-2)
-#define HAVE_AGING_P (data_heap->gen_count>2)
-/* the oldest generation */
-#define TENURED (data_heap->gen_count-1)
-
-#define MIN_GEN_COUNT 1
-#define MAX_GEN_COUNT 3
-
-/* new objects are allocated here */
-DLLEXPORT F_ZONE nursery;
-
-INLINE bool in_zone(F_ZONE *z, CELL pointer)
-{
- return pointer >= z->start && pointer < z->end;
-}
-
-CELL init_zone(F_ZONE *z, CELL size, CELL base);
-
-void init_card_decks(void);
-
-F_DATA_HEAP *grow_data_heap(F_DATA_HEAP *data_heap, CELL requested_bytes);
-
-void dealloc_data_heap(F_DATA_HEAP *data_heap);
-
-void clear_cards(CELL from, CELL to);
-void clear_decks(CELL from, CELL to);
-void clear_allot_markers(CELL from, CELL to);
-void reset_generation(CELL i);
-void reset_generations(CELL from, CELL to);
-
-void set_data_heap(F_DATA_HEAP *data_heap_);
-
-void init_data_heap(CELL gens,
- CELL young_size,
- CELL aging_size,
- CELL tenured_size,
- bool secure_gc_);
-
-/* set up guard pages to check for under/overflow.
-size must be a multiple of the page size */
-F_SEGMENT *alloc_segment(CELL size);
-void dealloc_segment(F_SEGMENT *block);
-
-CELL untagged_object_size(CELL pointer);
-CELL unaligned_object_size(CELL pointer);
-CELL object_size(CELL pointer);
-CELL binary_payload_start(CELL pointer);
-
-void begin_scan(void);
-CELL next_object(void);
-
-void primitive_data_room(void);
-void primitive_size(void);
-
-void primitive_begin_scan(void);
-void primitive_next_object(void);
-void primitive_end_scan(void);
-
-/* A heap walk allows useful things to be done, like finding all
-references to an object for debugging purposes. */
-CELL heap_scan_ptr;
-
-/* GC is off during heap walking */
-bool gc_off;
-
-INLINE bool in_data_heap_p(CELL ptr)
-{
- return (ptr >= data_heap->segment->start
- && ptr <= data_heap->segment->end);
-}
-
-INLINE void *allot_zone(F_ZONE *z, CELL a)
-{
- CELL h = z->here;
- z->here = h + align8(a);
- return (void*)h;
-}
-
-CELL find_all_words(void);
-
-/* Every object has a regular representation in the runtime, which makes GC
-much simpler. Every slot of the object until binary_payload_start is a pointer
-to some other object. */
-INLINE void do_slots(CELL obj, void (* iter)(CELL *))
-{
- CELL scan = obj;
- CELL payload_start = binary_payload_start(obj);
- CELL end = obj + payload_start;
-
- scan += CELLS;
-
- while(scan < end)
- {
- iter((CELL *)scan);
- scan += CELLS;
- }
-}
diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp
new file mode 100644
index 0000000000..bb8b35341e
--- /dev/null
+++ b/vm/data_heap.hpp
@@ -0,0 +1,125 @@
+namespace factor
+{
+
+/* Set by the -securegc command line argument */
+extern bool secure_gc;
+
+/* generational copying GC divides memory into zones */
+struct zone {
+ /* allocation pointer is 'here'; its offset is hardcoded in the
+ compiler backends */
+ cell start;
+ cell here;
+ cell size;
+ cell end;
+};
+
+struct data_heap {
+ segment *seg;
+
+ cell young_size;
+ cell aging_size;
+ cell tenured_size;
+
+ cell gen_count;
+
+ zone *generations;
+ zone *semispaces;
+
+ cell *allot_markers;
+ cell *allot_markers_end;
+
+ cell *cards;
+ cell *cards_end;
+
+ cell *decks;
+ cell *decks_end;
+};
+
+extern data_heap *data;
+
+/* the 0th generation is where new objects are allocated. */
+#define NURSERY 0
+/* where objects hang around */
+#define AGING (data->gen_count-2)
+#define HAVE_AGING_P (data->gen_count>2)
+/* the oldest generation */
+#define TENURED (data->gen_count-1)
+
+#define MIN_GEN_COUNT 1
+#define MAX_GEN_COUNT 3
+
+inline static bool in_zone(zone *z, object *pointer)
+{
+ return (cell)pointer >= z->start && (cell)pointer < z->end;
+}
+
+cell init_zone(zone *z, cell size, cell base);
+
+void init_card_decks(void);
+
+data_heap *grow_data_heap(data_heap *data, cell requested_bytes);
+
+void dealloc_data_heap(data_heap *data);
+
+void clear_cards(cell from, cell to);
+void clear_decks(cell from, cell to);
+void clear_allot_markers(cell from, cell to);
+void reset_generation(cell i);
+void reset_generations(cell from, cell to);
+
+void set_data_heap(data_heap *data_heap_);
+
+void init_data_heap(cell gens,
+ cell young_size,
+ cell aging_size,
+ cell tenured_size,
+ bool secure_gc_);
+
+/* set up guard pages to check for under/overflow.
+size must be a multiple of the page size */
+segment *alloc_segment(cell size);
+void dealloc_segment(segment *block);
+
+cell untagged_object_size(object *pointer);
+cell unaligned_object_size(object *pointer);
+cell binary_payload_start(object *pointer);
+cell object_size(cell tagged);
+
+void begin_scan(void);
+cell next_object(void);
+
+PRIMITIVE(data_room);
+PRIMITIVE(size);
+
+PRIMITIVE(begin_scan);
+PRIMITIVE(next_object);
+PRIMITIVE(end_scan);
+
+/* GC is off during heap walking */
+extern bool gc_off;
+
+cell find_all_words(void);
+
+/* Every object has a regular representation in the runtime, which makes GC
+much simpler. Every slot of the object until binary_payload_start is a pointer
+to some other object. */
+inline static void do_slots(cell obj, void (* iter)(cell *))
+{
+ cell scan = obj;
+ cell payload_start = binary_payload_start((object *)obj);
+ cell end = obj + payload_start;
+
+ scan += sizeof(cell);
+
+ while(scan < end)
+ {
+ iter((cell *)scan);
+ scan += sizeof(cell);
+ }
+}
+
+}
+
+/* new objects are allocated here */
+VM_C_API factor::zone nursery;
diff --git a/vm/debug.c b/vm/debug.cpp
similarity index 64%
rename from vm/debug.c
rename to vm/debug.cpp
index 6f7e883785..3cd05711ad 100755
--- a/vm/debug.c
+++ b/vm/debug.cpp
@@ -1,25 +1,28 @@
-#include "master.h"
+#include "master.hpp"
+namespace factor
+{
+
+static bool fep_disabled;
static bool full_output;
-void print_chars(F_STRING* str)
+void print_chars(string* str)
{
- CELL i;
+ cell i;
for(i = 0; i < string_capacity(str); i++)
putchar(string_nth(str,i));
}
-void print_word(F_WORD* word, CELL nesting)
+void print_word(word* word, cell nesting)
{
-
- if(type_of(word->vocabulary) == STRING_TYPE)
+ if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
{
- print_chars(untag_string(word->vocabulary));
+ print_chars(untag<string>(word->vocabulary));
print_string(":");
}
-
- if(type_of(word->name) == STRING_TYPE)
- print_chars(untag_string(word->name));
+
+ if(tagged<object>(word->name).type_p(STRING_TYPE))
+ print_chars(untag<string>(word->name));
else
{
print_string("#<not a string: ");
@@ -28,17 +31,17 @@ void print_word(F_WORD* word, CELL nesting)
}
}
-void print_factor_string(F_STRING* str)
+void print_factor_string(string* str)
{
putchar('"');
print_chars(str);
putchar('"');
}
-void print_array(F_ARRAY* array, CELL nesting)
+void print_array(array* array, cell nesting)
{
- CELL length = array_capacity(array);
- CELL i;
+ cell length = array_capacity(array);
+ cell i;
bool trimmed;
if(length > 10 && !full_output)
@@ -59,15 +62,15 @@ void print_array(F_ARRAY* array, CELL nesting)
print_string("...");
}
-void print_tuple(F_TUPLE* tuple, CELL nesting)
+void print_tuple(tuple *tuple, cell nesting)
{
- F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
- CELL length = to_fixnum(layout->size);
+ tuple_layout *layout = untag<tuple_layout>(tuple->layout);
+ cell length = to_fixnum(layout->size);
print_string(" ");
- print_nested_obj(layout->class,nesting);
+ print_nested_obj(layout->klass,nesting);
- CELL i;
+ cell i;
bool trimmed;
if(length > 10 && !full_output)
@@ -81,14 +84,14 @@ void print_tuple(F_TUPLE* tuple, CELL nesting)
for(i = 0; i < length; i++)
{
print_string(" ");
- print_nested_obj(tuple_nth(tuple,i),nesting);
+ print_nested_obj(tuple->data()[i],nesting);
}
if(trimmed)
print_string("...");
}
-void print_nested_obj(CELL obj, F_FIXNUM nesting)
+void print_nested_obj(cell obj, fixnum nesting)
{
if(nesting <= 0 && !full_output)
{
@@ -96,54 +99,58 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting)
return;
}
- F_QUOTATION *quot;
+ quotation *quot;
- switch(type_of(obj))
+ switch(tagged<object>(obj).type())
{
case FIXNUM_TYPE:
- print_fixnum(untag_fixnum_fast(obj));
+ print_fixnum(untag_fixnum(obj));
break;
case WORD_TYPE:
- print_word(untag_word(obj),nesting - 1);
+ print_word(untag<word>(obj),nesting - 1);
break;
case STRING_TYPE:
- print_factor_string(untag_string(obj));
+ print_factor_string(untag<string>(obj));
break;
case F_TYPE:
print_string("f");
break;
case TUPLE_TYPE:
print_string("T{");
- print_tuple(untag_object(obj),nesting - 1);
+ print_tuple(untag<tuple>(obj),nesting - 1);
print_string(" }");
break;
case ARRAY_TYPE:
print_string("{");
- print_array(untag_object(obj),nesting - 1);
+ print_array(untag<array>(obj),nesting - 1);
print_string(" }");
break;
case QUOTATION_TYPE:
print_string("[");
- quot = untag_object(obj);
- print_array(untag_object(quot->array),nesting - 1);
+ quot = untag<quotation>(obj);
+ print_array(untag<array>(quot->array),nesting - 1);
print_string(" ]");
break;
default:
- print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj); print_string(">");
+ print_string("#<type ");
+ print_cell(tagged<object>(obj).type());
+ print_string(" @ ");
+ print_cell_hex(obj);
+ print_string(">");
break;
}
}
-void print_obj(CELL obj)
+void print_obj(cell obj)
{
print_nested_obj(obj,10);
}
-void print_objects(CELL start, CELL end)
+void print_objects(cell *start, cell *end)
{
- for(; start <= end; start += CELLS)
+ for(; start <= end; start++)
{
- print_obj(get(start));
+ print_obj(*start);
nl();
}
}
@@ -151,83 +158,52 @@ void print_objects(CELL start, CELL end)
void print_datastack(void)
{
print_string("==== DATA STACK:\n");
- print_objects(ds_bot,ds);
+ print_objects((cell *)ds_bot,(cell *)ds);
}
void print_retainstack(void)
{
print_string("==== RETAIN STACK:\n");
- print_objects(rs_bot,rs);
+ print_objects((cell *)rs_bot,(cell *)rs);
}
-void print_stack_frame(F_STACK_FRAME *frame)
+void print_stack_frame(stack_frame *frame)
{
print_obj(frame_executing(frame));
print_string("\n");
print_obj(frame_scan(frame));
print_string("\n");
- print_cell_hex((CELL)frame_executing(frame));
+ print_cell_hex((cell)frame_executing(frame));
print_string(" ");
- print_cell_hex((CELL)frame->xt);
+ print_cell_hex((cell)frame->xt);
print_string("\n");
}
void print_callstack(void)
{
print_string("==== CALL STACK:\n");
- CELL bottom = (CELL)stack_chain->callstack_bottom;
- CELL top = (CELL)stack_chain->callstack_top;
+ cell bottom = (cell)stack_chain->callstack_bottom;
+ cell top = (cell)stack_chain->callstack_top;
iterate_callstack(top,bottom,print_stack_frame);
}
-void dump_cell(CELL cell)
+void dump_cell(cell x)
{
- print_cell_hex_pad(cell); print_string(": ");
-
- cell = get(cell);
-
- print_cell_hex_pad(cell); print_string(" tag "); print_cell(TAG(cell));
-
- switch(TAG(cell))
- {
- case OBJECT_TYPE:
- case BIGNUM_TYPE:
- case FLOAT_TYPE:
- if(cell == F)
- print_string(" -- F");
- else if(cell < TYPE_COUNT<<TAG_BITS)
- {
- print_string(" -- possible header: ");
- print_cell(cell>>TAG_BITS);
- }
- else if(cell >= data_heap->segment->start
- && cell < data_heap->segment->end)
- {
- CELL header = get(UNTAG(cell));
- CELL type = header>>TAG_BITS;
- print_string(" -- object; ");
- if(TAG(header) == 0 && type < TYPE_COUNT)
- {
- print_string(" type "); print_cell(type);
- }
- else
- print_string(" header corrupt");
- }
- break;
- }
-
+ print_cell_hex_pad(x); print_string(": ");
+ x = *(cell *)x;
+ print_cell_hex_pad(x); print_string(" tag "); print_cell(TAG(x));
nl();
}
-void dump_memory(CELL from, CELL to)
+void dump_memory(cell from, cell to)
{
from = UNTAG(from);
- for(; from <= to; from += CELLS)
+ for(; from <= to; from += sizeof(cell))
dump_cell(from);
}
-void dump_zone(F_ZONE *z)
+void dump_zone(zone *z)
{
print_string("Start="); print_cell(z->start);
print_string(", size="); print_cell(z->size);
@@ -236,39 +212,39 @@ void dump_zone(F_ZONE *z)
void dump_generations(void)
{
- CELL i;
+ cell i;
print_string("Nursery: ");
dump_zone(&nursery);
- for(i = 1; i < data_heap->gen_count; i++)
+ for(i = 1; i < data->gen_count; i++)
{
print_string("Generation "); print_cell(i); print_string(": ");
- dump_zone(&data_heap->generations[i]);
+ dump_zone(&data->generations[i]);
}
- for(i = 0; i < data_heap->gen_count; i++)
+ for(i = 0; i < data->gen_count; i++)
{
print_string("Semispace "); print_cell(i); print_string(": ");
- dump_zone(&data_heap->semispaces[i]);
+ dump_zone(&data->semispaces[i]);
}
print_string("Cards: base=");
- print_cell((CELL)data_heap->cards);
+ print_cell((cell)data->cards);
print_string(", size=");
- print_cell((CELL)(data_heap->cards_end - data_heap->cards));
+ print_cell((cell)(data->cards_end - data->cards));
nl();
}
-void dump_objects(F_FIXNUM type)
+void dump_objects(cell type)
{
gc();
begin_scan();
- CELL obj;
+ cell obj;
while((obj = next_object()) != F)
{
- if(type == -1 || type_of(obj) == type)
+ if(type == TYPE_COUNT || tagged<object>(obj).type_p(type))
{
print_cell_hex_pad(obj);
print_string(" ");
@@ -281,10 +257,10 @@ void dump_objects(F_FIXNUM type)
gc_off = false;
}
-CELL look_for;
-CELL obj;
+cell look_for;
+cell obj;
-void find_data_references_step(CELL *scan)
+void find_data_references_step(cell *scan)
{
if(look_for == *scan)
{
@@ -295,7 +271,7 @@ void find_data_references_step(CELL *scan)
}
}
-void find_data_references(CELL look_for_)
+void find_data_references(cell look_for_)
{
look_for = look_for_;
@@ -311,26 +287,26 @@ void find_data_references(CELL look_for_)
/* Dump all code blocks for debugging */
void dump_code_heap(void)
{
- CELL reloc_size = 0, literal_size = 0;
+ cell reloc_size = 0, literal_size = 0;
- F_BLOCK *scan = first_block(&code_heap);
+ heap_block *scan = first_block(&code);
while(scan)
{
- char *status;
+ const char *status;
switch(scan->status)
{
case B_FREE:
status = "free";
break;
case B_ALLOCATED:
- reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
- literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
+ reloc_size += object_size(((code_block *)scan)->relocation);
+ literal_size += object_size(((code_block *)scan)->literals);
status = "allocated";
break;
case B_MARKED:
- reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
- literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
+ reloc_size += object_size(((code_block *)scan)->relocation);
+ literal_size += object_size(((code_block *)scan)->literals);
status = "marked";
break;
default:
@@ -338,11 +314,11 @@ void dump_code_heap(void)
break;
}
- print_cell_hex((CELL)scan); print_string(" ");
+ print_cell_hex((cell)scan); print_string(" ");
print_cell_hex(scan->size); print_string(" ");
print_string(status); print_string("\n");
- scan = next_block(&code_heap,scan);
+ scan = next_block(&code,scan);
}
print_cell(reloc_size); print_string(" bytes of relocation data\n");
@@ -413,20 +389,20 @@ void factorbug(void)
if(strcmp(cmd,"d") == 0)
{
- CELL addr = read_cell_hex();
- scanf(" ");
- CELL count = read_cell_hex();
+ cell addr = read_cell_hex();
+ if(scanf(" ") < 0) break;
+ cell count = read_cell_hex();
dump_memory(addr,addr+count);
}
else if(strcmp(cmd,"u") == 0)
{
- CELL addr = read_cell_hex();
- CELL count = object_size(addr);
+ cell addr = read_cell_hex();
+ cell count = object_size(addr);
dump_memory(addr,addr+count);
}
else if(strcmp(cmd,".") == 0)
{
- CELL addr = read_cell_hex();
+ cell addr = read_cell_hex();
print_obj(addr);
print_string("\n");
}
@@ -446,20 +422,20 @@ void factorbug(void)
{
int i;
for(i = 0; i < USER_ENV; i++)
- dump_cell((CELL)&userenv[i]);
+ dump_cell((cell)&userenv[i]);
}
else if(strcmp(cmd,"g") == 0)
dump_generations();
else if(strcmp(cmd,"card") == 0)
{
- CELL addr = read_cell_hex();
- print_cell_hex((CELL)ADDR_TO_CARD(addr));
+ cell addr = read_cell_hex();
+ print_cell_hex((cell)addr_to_card(addr));
nl();
}
else if(strcmp(cmd,"addr") == 0)
{
- CELL card = read_cell_hex();
- print_cell_hex((CELL)CARD_TO_ADDR(card));
+ card *ptr = (card *)read_cell_hex();
+ print_cell_hex(card_to_addr(ptr));
nl();
}
else if(strcmp(cmd,"q") == 0)
@@ -469,10 +445,10 @@ void factorbug(void)
else if(strcmp(cmd,"im") == 0)
save_image(STRING_LITERAL("fep.image"));
else if(strcmp(cmd,"data") == 0)
- dump_objects(-1);
+ dump_objects(TYPE_COUNT);
else if(strcmp(cmd,"refs") == 0)
{
- CELL addr = read_cell_hex();
+ cell addr = read_cell_hex();
print_string("Data heap references:\n");
find_data_references(addr);
nl();
@@ -483,7 +459,7 @@ void factorbug(void)
dump_objects(TUPLE_TYPE);
else if(strcmp(cmd,"push") == 0)
{
- CELL addr = read_cell_hex();
+ cell addr = read_cell_hex();
dpush(addr);
}
else if(strcmp(cmd,"code") == 0)
@@ -493,9 +469,11 @@ void factorbug(void)
}
}
-void primitive_die(void)
+PRIMITIVE(die)
{
print_string("The die word was called by the library. Unless you called it yourself,\n");
print_string("you have triggered a bug in Factor. Please report.\n");
factorbug();
}
+
+}
diff --git a/vm/debug.h b/vm/debug.h
deleted file mode 100755
index 594d8ec919..0000000000
--- a/vm/debug.h
+++ /dev/null
@@ -1,9 +0,0 @@
-void print_obj(CELL obj);
-void print_nested_obj(CELL obj, F_FIXNUM nesting);
-void dump_generations(void);
-void factorbug(void);
-void dump_zone(F_ZONE *z);
-
-bool fep_disabled;
-
-void primitive_die(void);
diff --git a/vm/debug.hpp b/vm/debug.hpp
new file mode 100755
index 0000000000..81874bf2ac
--- /dev/null
+++ b/vm/debug.hpp
@@ -0,0 +1,12 @@
+namespace factor
+{
+
+void print_obj(cell obj);
+void print_nested_obj(cell obj, fixnum nesting);
+void dump_generations(void);
+void factorbug(void);
+void dump_zone(zone *z);
+
+PRIMITIVE(die);
+
+}
diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp
new file mode 100644
index 0000000000..bbcf20c57b
--- /dev/null
+++ b/vm/dispatch.cpp
@@ -0,0 +1,211 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+cell megamorphic_cache_hits;
+cell megamorphic_cache_misses;
+
+static cell search_lookup_alist(cell table, cell klass)
+{
+ array *pairs = untag<array>(table);
+ fixnum index = array_capacity(pairs) - 1;
+ while(index >= 0)
+ {
+ array *pair = untag<array>(array_nth(pairs,index));
+ if(array_nth(pair,0) == klass)
+ return array_nth(pair,1);
+ else
+ index--;
+ }
+
+ return F;
+}
+
+static cell search_lookup_hash(cell table, cell klass, cell hashcode)
+{
+ array *buckets = untag<array>(table);
+ cell bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1));
+ if(tagged<object>(bucket).type_p(WORD_TYPE) || bucket == F)
+ return bucket;
+ else
+ return search_lookup_alist(bucket,klass);
+}
+
+static cell nth_superclass(tuple_layout *layout, fixnum echelon)
+{
+ cell *ptr = (cell *)(layout + 1);
+ return ptr[echelon * 2];
+}
+
+static cell nth_hashcode(tuple_layout *layout, fixnum echelon)
+{
+ cell *ptr = (cell *)(layout + 1);
+ return ptr[echelon * 2 + 1];
+}
+
+static cell lookup_tuple_method(cell obj, cell methods)
+{
+ tuple_layout *layout = untag<tuple_layout>(untag<tuple>(obj)->layout);
+
+ array *echelons = untag<array>(methods);
+
+ fixnum echelon = untag_fixnum(layout->echelon);
+ fixnum max_echelon = array_capacity(echelons) - 1;
+ if(echelon > max_echelon) echelon = max_echelon;
+
+ while(echelon >= 0)
+ {
+ cell echelon_methods = array_nth(echelons,echelon);
+
+ if(tagged<object>(echelon_methods).type_p(WORD_TYPE))
+ return echelon_methods;
+ else if(echelon_methods != F)
+ {
+ cell klass = nth_superclass(layout,echelon);
+ cell hashcode = untag_fixnum(nth_hashcode(layout,echelon));
+ cell result = search_lookup_hash(echelon_methods,klass,hashcode);
+ if(result != F)
+ return result;
+ }
+
+ echelon--;
+ }
+
+ critical_error("Cannot find tuple method",methods);
+ return F;
+}
+
+static cell lookup_hi_tag_method(cell obj, cell methods)
+{
+ array *hi_tag_methods = untag<array>(methods);
+ cell tag = untag<object>(obj)->h.hi_tag() - HEADER_TYPE;
+#ifdef FACTOR_DEBUG
+ assert(tag < TYPE_COUNT - HEADER_TYPE);
+#endif
+ return array_nth(hi_tag_methods,tag);
+}
+
+static cell lookup_hairy_method(cell obj, cell methods)
+{
+ cell method = array_nth(untag<array>(methods),TAG(obj));
+ if(tagged<object>(method).type_p(WORD_TYPE))
+ return method;
+ else
+ {
+ switch(TAG(obj))
+ {
+ case TUPLE_TYPE:
+ return lookup_tuple_method(obj,method);
+ break;
+ case OBJECT_TYPE:
+ return lookup_hi_tag_method(obj,method);
+ break;
+ default:
+ critical_error("Bad methods array",methods);
+ return -1;
+ }
+ }
+}
+
+cell lookup_method(cell obj, cell methods)
+{
+ cell tag = TAG(obj);
+ if(tag == TUPLE_TYPE || tag == OBJECT_TYPE)
+ return lookup_hairy_method(obj,methods);
+ else
+ return array_nth(untag<array>(methods),TAG(obj));
+}
+
+PRIMITIVE(lookup_method)
+{
+ cell methods = dpop();
+ cell obj = dpop();
+ dpush(lookup_method(obj,methods));
+}
+
+cell object_class(cell obj)
+{
+ switch(TAG(obj))
+ {
+ case TUPLE_TYPE:
+ return untag<tuple>(obj)->layout;
+ case OBJECT_TYPE:
+ return untag<object>(obj)->h.value;
+ default:
+ return tag_fixnum(TAG(obj));
+ }
+}
+
+static cell method_cache_hashcode(cell klass, array *array)
+{
+ cell capacity = (array_capacity(array) >> 1) - 1;
+ return ((klass >> TAG_BITS) & capacity) << 1;
+}
+
+static void update_method_cache(cell cache, cell klass, cell method)
+{
+ array *cache_elements = untag<array>(cache);
+ cell hashcode = method_cache_hashcode(klass,cache_elements);
+ set_array_nth(cache_elements,hashcode,klass);
+ set_array_nth(cache_elements,hashcode + 1,method);
+}
+
+PRIMITIVE(mega_cache_miss)
+{
+ megamorphic_cache_misses++;
+
+ cell cache = dpop();
+ fixnum index = untag_fixnum(dpop());
+ cell methods = dpop();
+
+ cell object = ((cell *)ds)[-index];
+ cell klass = object_class(object);
+ cell method = lookup_method(object,methods);
+
+ update_method_cache(cache,klass,method);
+
+ dpush(method);
+}
+
+PRIMITIVE(reset_dispatch_stats)
+{
+ megamorphic_cache_hits = megamorphic_cache_misses = 0;
+}
+
+PRIMITIVE(dispatch_stats)
+{
+ growable_array stats;
+ stats.add(allot_cell(megamorphic_cache_hits));
+ stats.add(allot_cell(megamorphic_cache_misses));
+ stats.trim();
+ dpush(stats.elements.value());
+}
+
+void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
+{
+ gc_root<array> methods(methods_);
+ gc_root<array> cache(cache_);
+
+ /* Generate machine code to determine the object's class. */
+ emit_class_lookup(index,PIC_HI_TAG_TUPLE);
+
+ /* Do a cache lookup. */
+ emit_with(userenv[MEGA_LOOKUP],cache.value());
+
+ /* If we end up here, the cache missed. */
+ emit(userenv[JIT_PROLOG]);
+
+ /* Push index, method table and cache on the stack. */
+ push(methods.value());
+ push(tag_fixnum(index));
+ push(cache.value());
+ word_call(userenv[MEGA_MISS_WORD]);
+
+ /* Now the new method has been stored into the cache, and its on
+ the stack. */
+ emit(userenv[JIT_EPILOG]);
+ emit(userenv[JIT_EXECUTE_JUMP]);
+}
+
+}
diff --git a/vm/dispatch.hpp b/vm/dispatch.hpp
new file mode 100644
index 0000000000..f5648c7ebe
--- /dev/null
+++ b/vm/dispatch.hpp
@@ -0,0 +1,18 @@
+namespace factor
+{
+
+cell lookup_method(cell object, cell methods);
+PRIMITIVE(lookup_method);
+
+cell object_class(cell object);
+
+PRIMITIVE(mega_cache_miss);
+
+PRIMITIVE(reset_dispatch_stats);
+PRIMITIVE(dispatch_stats);
+
+void jit_emit_class_lookup(jit *jit, fixnum index, cell type);
+
+void jit_emit_mega_cache_lookup(jit *jit, cell methods, fixnum index, cell cache);
+
+}
diff --git a/vm/errors.c b/vm/errors.cpp
similarity index 70%
rename from vm/errors.c
rename to vm/errors.cpp
index 9b7b7843d2..f2ba355293 100755
--- a/vm/errors.c
+++ b/vm/errors.cpp
@@ -1,4 +1,13 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Global variables used to pass fault handler state from signal handler to
+user-space */
+cell signal_number;
+cell signal_fault_addr;
+stack_frame *signal_callstack_top;
void out_of_memory(void)
{
@@ -7,14 +16,14 @@ void out_of_memory(void)
exit(1);
}
-void fatal_error(char* msg, CELL tagged)
+void fatal_error(const char* msg, cell tagged)
{
print_string("fatal_error: "); print_string(msg);
print_string(": "); print_cell_hex(tagged); nl();
exit(1);
}
-void critical_error(char* msg, CELL tagged)
+void critical_error(const char* msg, cell tagged)
{
print_string("You have triggered a bug in Factor. Please report.\n");
print_string("critical_error: "); print_string(msg);
@@ -22,7 +31,7 @@ void critical_error(char* msg, CELL tagged)
factorbug();
}
-void throw_error(CELL error, F_STACK_FRAME *callstack_top)
+void throw_error(cell error, stack_frame *callstack_top)
{
/* If the error handler is set, we rewind any C stack frames and
pass the error to user-space. */
@@ -32,8 +41,8 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top)
gc_off = false;
/* Reset local roots */
- gc_locals = gc_locals_region->start - CELLS;
- extra_roots = extra_roots_region->start - CELLS;
+ gc_locals = gc_locals_region->start - sizeof(cell);
+ gc_bignums = gc_bignums_region->start - sizeof(cell);
/* If we had an underflow or overflow, stack pointers might be
out of bounds */
@@ -67,14 +76,14 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top)
}
}
-void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2,
- F_STACK_FRAME *callstack_top)
+void general_error(vm_error_type error, cell arg1, cell arg2,
+ stack_frame *callstack_top)
{
throw_error(allot_array_4(userenv[ERROR_ENV],
tag_fixnum(error),arg1,arg2),callstack_top);
}
-void type_error(CELL type, CELL tagged)
+void type_error(cell type, cell tagged)
{
general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
}
@@ -86,7 +95,7 @@ void not_implemented_error(void)
/* Test if 'fault' is in the guard page at the top or bottom (depending on
offset being 0 or -1) of area+area_size */
-bool in_page(CELL fault, CELL area, CELL area_size, int offset)
+bool in_page(cell fault, cell area, cell area_size, int offset)
{
int pagesize = getpagesize();
area += area_size;
@@ -95,7 +104,7 @@ bool in_page(CELL fault, CELL area, CELL area_size, int offset)
return fault >= area && fault <= area + pagesize;
}
-void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
+void memory_protection_error(cell addr, stack_frame *native_stack)
{
if(in_page(addr, ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
@@ -107,26 +116,29 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
else if(in_page(addr, nursery.end, 0, 0))
critical_error("allot_object() missed GC check",0);
- else if(in_page(addr, gc_locals_region->start, 0, -1))
- critical_error("gc locals underflow",0);
- else if(in_page(addr, gc_locals_region->end, 0, 0))
- critical_error("gc locals overflow",0);
- else if(in_page(addr, extra_roots_region->start, 0, -1))
- critical_error("extra roots underflow",0);
- else if(in_page(addr, extra_roots_region->end, 0, 0))
- critical_error("extra roots overflow",0);
else
general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
}
-void signal_error(int signal, F_STACK_FRAME *native_stack)
+void signal_error(int signal, stack_frame *native_stack)
{
general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
}
-void divide_by_zero_error(F_STACK_FRAME *native_stack)
+void divide_by_zero_error(void)
{
- general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack);
+ general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
+}
+
+PRIMITIVE(call_clear)
+{
+ throw_impl(dpop(),stack_chain->callstack_bottom);
+}
+
+/* For testing purposes */
+PRIMITIVE(unimplemented)
+{
+ not_implemented_error();
}
void memory_signal_handler_impl(void)
@@ -134,23 +146,9 @@ void memory_signal_handler_impl(void)
memory_protection_error(signal_fault_addr,signal_callstack_top);
}
-void divide_by_zero_signal_handler_impl(void)
-{
- divide_by_zero_error(signal_callstack_top);
-}
-
void misc_signal_handler_impl(void)
{
signal_error(signal_number,signal_callstack_top);
}
-void primitive_call_clear(void)
-{
- throw_impl(dpop(),stack_chain->callstack_bottom);
-}
-
-/* For testing purposes */
-void primitive_unimplemented(void)
-{
- not_implemented_error();
}
diff --git a/vm/errors.h b/vm/errors.h
deleted file mode 100755
index da3ee8bbe0..0000000000
--- a/vm/errors.h
+++ /dev/null
@@ -1,59 +0,0 @@
-/* Runtime errors */
-typedef enum
-{
- ERROR_EXPIRED = 0,
- ERROR_IO,
- ERROR_NOT_IMPLEMENTED,
- ERROR_TYPE,
- ERROR_DIVIDE_BY_ZERO,
- ERROR_SIGNAL,
- ERROR_ARRAY_SIZE,
- ERROR_C_STRING,
- ERROR_FFI,
- ERROR_HEAP_SCAN,
- ERROR_UNDEFINED_SYMBOL,
- ERROR_DS_UNDERFLOW,
- ERROR_DS_OVERFLOW,
- ERROR_RS_UNDERFLOW,
- ERROR_RS_OVERFLOW,
- ERROR_MEMORY,
-} F_ERRORTYPE;
-
-void out_of_memory(void);
-void fatal_error(char* msg, CELL tagged);
-void critical_error(char* msg, CELL tagged);
-void primitive_die(void);
-
-void throw_error(CELL error, F_STACK_FRAME *native_stack);
-void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2, F_STACK_FRAME *native_stack);
-void divide_by_zero_error(F_STACK_FRAME *native_stack);
-void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack);
-void signal_error(int signal, F_STACK_FRAME *native_stack);
-void type_error(CELL type, CELL tagged);
-void not_implemented_error(void);
-
-void primitive_call_clear(void);
-
-INLINE void type_check(CELL type, CELL tagged)
-{
- if(type_of(tagged) != type) type_error(type,tagged);
-}
-
-#define DEFINE_UNTAG(type,check,name) \
- INLINE type *untag_##name(CELL obj) \
- { \
- type_check(check,obj); \
- return untag_object(obj); \
- }
-
-/* Global variables used to pass fault handler state from signal handler to
-user-space */
-CELL signal_number;
-CELL signal_fault_addr;
-void *signal_callstack_top;
-
-void memory_signal_handler_impl(void);
-void divide_by_zero_signal_handler_impl(void);
-void misc_signal_handler_impl(void);
-
-void primitive_unimplemented(void);
diff --git a/vm/errors.hpp b/vm/errors.hpp
new file mode 100755
index 0000000000..e5968468a5
--- /dev/null
+++ b/vm/errors.hpp
@@ -0,0 +1,51 @@
+namespace factor
+{
+
+/* Runtime errors */
+enum vm_error_type
+{
+ ERROR_EXPIRED = 0,
+ ERROR_IO,
+ ERROR_NOT_IMPLEMENTED,
+ ERROR_TYPE,
+ ERROR_DIVIDE_BY_ZERO,
+ ERROR_SIGNAL,
+ ERROR_ARRAY_SIZE,
+ ERROR_C_STRING,
+ ERROR_FFI,
+ ERROR_HEAP_SCAN,
+ ERROR_UNDEFINED_SYMBOL,
+ ERROR_DS_UNDERFLOW,
+ ERROR_DS_OVERFLOW,
+ ERROR_RS_UNDERFLOW,
+ ERROR_RS_OVERFLOW,
+ ERROR_MEMORY,
+};
+
+void out_of_memory(void);
+void fatal_error(const char* msg, cell tagged);
+void critical_error(const char* msg, cell tagged);
+
+PRIMITIVE(die);
+
+void throw_error(cell error, stack_frame *native_stack);
+void general_error(vm_error_type error, cell arg1, cell arg2, stack_frame *native_stack);
+void divide_by_zero_error(void);
+void memory_protection_error(cell addr, stack_frame *native_stack);
+void signal_error(int signal, stack_frame *native_stack);
+void type_error(cell type, cell tagged);
+void not_implemented_error(void);
+
+PRIMITIVE(call_clear);
+PRIMITIVE(unimplemented);
+
+/* Global variables used to pass fault handler state from signal handler to
+user-space */
+extern cell signal_number;
+extern cell signal_fault_addr;
+extern stack_frame *signal_callstack_top;
+
+void memory_signal_handler_impl(void);
+void misc_signal_handler_impl(void);
+
+}
diff --git a/vm/factor.c b/vm/factor.cpp
similarity index 61%
rename from vm/factor.c
rename to vm/factor.cpp
index 9b5d3de602..b607adba63 100755
--- a/vm/factor.c
+++ b/vm/factor.cpp
@@ -1,14 +1,17 @@
-#include "master.h"
+#include "master.hpp"
-void default_parameters(F_PARAMETERS *p)
+namespace factor
+{
+
+VM_C_API void default_parameters(vm_parameters *p)
{
p->image_path = NULL;
/* We make a wild guess here that if we're running on ARM, we don't
have a lot of memory. */
#ifdef FACTOR_ARM
- p->ds_size = 8 * CELLS;
- p->rs_size = 8 * CELLS;
+ p->ds_size = 8 * sizeof(cell);
+ p->rs_size = 8 * sizeof(cell);
p->gen_count = 2;
p->code_size = 4;
@@ -16,16 +19,18 @@ void default_parameters(F_PARAMETERS *p)
p->aging_size = 1;
p->tenured_size = 6;
#else
- p->ds_size = 32 * CELLS;
- p->rs_size = 32 * CELLS;
+ p->ds_size = 32 * sizeof(cell);
+ p->rs_size = 32 * sizeof(cell);
p->gen_count = 3;
- p->code_size = 8 * CELLS;
- p->young_size = CELLS / 4;
- p->aging_size = CELLS / 2;
- p->tenured_size = 4 * CELLS;
+ p->code_size = 8 * sizeof(cell);
+ p->young_size = sizeof(cell) / 4;
+ p->aging_size = sizeof(cell) / 2;
+ p->tenured_size = 4 * sizeof(cell);
#endif
+ p->max_pic_size = 3;
+
p->secure_gc = false;
p->fep = false;
@@ -38,7 +43,7 @@ void default_parameters(F_PARAMETERS *p)
p->stack_traces = true;
}
-INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
+static bool factor_arg(const vm_char* str, const vm_char* arg, cell* value)
{
int val;
if(SSCANF(str,arg,&val) > 0)
@@ -50,7 +55,7 @@ INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
return false;
}
-void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
+VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
{
default_parameters(p);
p->executable_path = argv[0];
@@ -66,6 +71,7 @@ void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
else if(factor_arg(argv[i],STRING_LITERAL("-aging=%d"),&p->aging_size));
else if(factor_arg(argv[i],STRING_LITERAL("-tenured=%d"),&p->tenured_size));
else if(factor_arg(argv[i],STRING_LITERAL("-codeheap=%d"),&p->code_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-pic=%d"),&p->max_pic_size));
else if(STRCMP(argv[i],STRING_LITERAL("-securegc")) == 0) p->secure_gc = true;
else if(STRCMP(argv[i],STRING_LITERAL("-fep")) == 0) p->fep = true;
else if(STRNCMP(argv[i],STRING_LITERAL("-i="),3) == 0) p->image_path = argv[i] + 3;
@@ -75,7 +81,7 @@ void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
}
/* Do some initialization that we do once only */
-void do_stage1_init(void)
+static void do_stage1_init(void)
{
print_string("*** Stage 2 early init... ");
fflush(stdout);
@@ -87,7 +93,7 @@ void do_stage1_init(void)
fflush(stdout);
}
-void init_factor(F_PARAMETERS *p)
+VM_C_API void init_factor(vm_parameters *p)
{
/* Kilobytes */
p->ds_size = align_page(p->ds_size << 10);
@@ -105,7 +111,7 @@ void init_factor(F_PARAMETERS *p)
/* OS-specific initialization */
early_init();
- const F_CHAR *executable_path = vm_executable_path();
+ const vm_char *executable_path = vm_executable_path();
if(executable_path)
p->executable_path = executable_path;
@@ -118,28 +124,25 @@ void init_factor(F_PARAMETERS *p)
init_stacks(p->ds_size,p->rs_size);
load_image(p);
init_c_io();
+ init_inline_caching(p->max_pic_size);
init_signals();
if(p->console)
open_console();
- stack_chain = NULL;
- profiling_p = false;
- performing_gc = false;
- last_code_heap_scan = NURSERY;
- collecting_aging_again = false;
+ init_profiler();
- userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING));
- userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
- userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
- userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F);
+ userenv[CPU_ENV] = allot_alien(F,(cell)FACTOR_CPU_STRING);
+ userenv[OS_ENV] = allot_alien(F,(cell)FACTOR_OS_STRING);
+ userenv[cell_SIZE_ENV] = tag_fixnum(sizeof(cell));
+ userenv[EXECUTABLE_ENV] = allot_alien(F,(cell)p->executable_path);
userenv[ARGS_ENV] = F;
userenv[EMBEDDED_ENV] = F;
/* We can GC now */
gc_off = false;
- if(!stage2)
+ if(userenv[STAGE2_ENV] == F)
{
userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
do_stage1_init();
@@ -147,23 +150,19 @@ void init_factor(F_PARAMETERS *p)
}
/* May allocate memory */
-void pass_args_to_factor(int argc, F_CHAR **argv)
+VM_C_API void pass_args_to_factor(int argc, vm_char **argv)
{
- F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
+ growable_array args;
int i;
for(i = 1; i < argc; i++)
- {
- REGISTER_UNTAGGED(args);
- CELL arg = tag_object(from_native_string(argv[i]));
- UNREGISTER_UNTAGGED(args);
- set_array_nth(args,i,arg);
- }
+ args.add(allot_alien(F,(cell)argv[i]));
- userenv[ARGS_ENV] = tag_object(args);
+ args.trim();
+ userenv[ARGS_ENV] = args.elements.value();
}
-void start_factor(F_PARAMETERS *p)
+static void start_factor(vm_parameters *p)
{
if(p->fep) factorbug();
@@ -172,15 +171,15 @@ void start_factor(F_PARAMETERS *p)
unnest_stacks();
}
-void start_embedded_factor(F_PARAMETERS *p)
+VM_C_API void start_embedded_factor(vm_parameters *p)
{
userenv[EMBEDDED_ENV] = T;
start_factor(p);
}
-void start_standalone_factor(int argc, F_CHAR **argv)
+VM_C_API void start_standalone_factor(int argc, vm_char **argv)
{
- F_PARAMETERS p;
+ vm_parameters p;
default_parameters(&p);
init_parameters_from_args(&p,argc,argv);
init_factor(&p);
@@ -188,25 +187,27 @@ void start_standalone_factor(int argc, F_CHAR **argv)
start_factor(&p);
}
-char *factor_eval_string(char *string)
+VM_C_API char *factor_eval_string(char *string)
{
- char* (*callback)(char*) = alien_offset(userenv[EVAL_CALLBACK_ENV]);
+ char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
return callback(string);
}
-void factor_eval_free(char *result)
+VM_C_API void factor_eval_free(char *result)
{
free(result);
}
-void factor_yield(void)
+VM_C_API void factor_yield(void)
{
- void (*callback)() = alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]);
callback();
}
-void factor_sleep(long us)
+VM_C_API void factor_sleep(long us)
{
- void (*callback)() = alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
callback(us);
}
+
+}
diff --git a/vm/factor.h b/vm/factor.h
deleted file mode 100644
index a3de31a502..0000000000
--- a/vm/factor.h
+++ /dev/null
@@ -1,11 +0,0 @@
-DLLEXPORT void default_parameters(F_PARAMETERS *p);
-DLLEXPORT void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv);
-DLLEXPORT void init_factor(F_PARAMETERS *p);
-DLLEXPORT void pass_args_to_factor(int argc, F_CHAR **argv);
-DLLEXPORT void start_embedded_factor(F_PARAMETERS *p);
-DLLEXPORT void start_standalone_factor(int argc, F_CHAR **argv);
-
-DLLEXPORT char *factor_eval_string(char *string);
-DLLEXPORT void factor_eval_free(char *result);
-DLLEXPORT void factor_yield(void);
-DLLEXPORT void factor_sleep(long ms);
diff --git a/vm/factor.hpp b/vm/factor.hpp
new file mode 100644
index 0000000000..e9ba920e9f
--- /dev/null
+++ b/vm/factor.hpp
@@ -0,0 +1,16 @@
+namespace factor
+{
+
+VM_C_API void default_parameters(vm_parameters *p);
+VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv);
+VM_C_API void init_factor(vm_parameters *p);
+VM_C_API void pass_args_to_factor(int argc, vm_char **argv);
+VM_C_API void start_embedded_factor(vm_parameters *p);
+VM_C_API void start_standalone_factor(int argc, vm_char **argv);
+
+VM_C_API char *factor_eval_string(char *string);
+VM_C_API void factor_eval_free(char *result);
+VM_C_API void factor_yield(void);
+VM_C_API void factor_sleep(long ms);
+
+}
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
index a5a43cf2ae..680b144140 100755
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -1,8 +1,10 @@
/* This file is linked into the runtime for the sole purpose
* of testing FFI code. */
-#include "master.h"
#include "ffi_test.h"
+#include <assert.h>
+#include <string.h>
+
void ffi_test_0(void)
{
}
@@ -259,7 +261,7 @@ unsigned long long ffi_test_38(unsigned long long x, unsigned long long y)
int ffi_test_39(long a, long b, struct test_struct_13 s)
{
- if(a != b) abort();
+ assert(a == b);
return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
}
diff --git a/vm/ffi_test.h b/vm/ffi_test.h
index f8634b304e..835f9e942f 100755
--- a/vm/ffi_test.h
+++ b/vm/ffi_test.h
@@ -1,96 +1,104 @@
-#if defined(FACTOR_X86)
+#if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
#define F_STDCALL __attribute__((stdcall))
#else
#define F_STDCALL
#endif
-DLLEXPORT void ffi_test_0(void);
-DLLEXPORT int ffi_test_1(void);
-DLLEXPORT int ffi_test_2(int x, int y);
-DLLEXPORT int ffi_test_3(int x, int y, int z, int t);
-DLLEXPORT float ffi_test_4(void);
-DLLEXPORT double ffi_test_5(void);
-DLLEXPORT double ffi_test_6(float x, float y);
-DLLEXPORT double ffi_test_7(double x, double y);
-DLLEXPORT double ffi_test_8(double x, float y, double z, float t, int w);
-DLLEXPORT int ffi_test_9(int a, int b, int c, int d, int e, int f, int g);
-DLLEXPORT int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h);
+#if defined(__APPLE__)
+ #define F_EXPORT __attribute__((visibility("default")))
+#elif defined(WINDOWS)
+ #define F_EXPORT __declspec(dllexport)
+#else
+ #define F_EXPORT
+#endif
+
+F_EXPORT void ffi_test_0(void);
+F_EXPORT int ffi_test_1(void);
+F_EXPORT int ffi_test_2(int x, int y);
+F_EXPORT int ffi_test_3(int x, int y, int z, int t);
+F_EXPORT float ffi_test_4(void);
+F_EXPORT double ffi_test_5(void);
+F_EXPORT double ffi_test_6(float x, float y);
+F_EXPORT double ffi_test_7(double x, double y);
+F_EXPORT double ffi_test_8(double x, float y, double z, float t, int w);
+F_EXPORT int ffi_test_9(int a, int b, int c, int d, int e, int f, int g);
+F_EXPORT int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h);
struct foo { int x, y; };
-DLLEXPORT int ffi_test_11(int a, struct foo b, int c);
+F_EXPORT int ffi_test_11(int a, struct foo b, int c);
struct rect { float x, y, w, h; };
-DLLEXPORT int ffi_test_12(int a, int b, struct rect c, int d, int e, int f);
-DLLEXPORT int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k);
-DLLEXPORT struct foo ffi_test_14(int x, int y);
-DLLEXPORT char *ffi_test_15(char *x, char *y);
+F_EXPORT int ffi_test_12(int a, int b, struct rect c, int d, int e, int f);
+F_EXPORT int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k);
+F_EXPORT struct foo ffi_test_14(int x, int y);
+F_EXPORT char *ffi_test_15(char *x, char *y);
struct bar { long x, y, z; };
-DLLEXPORT struct bar ffi_test_16(long x, long y, long z);
+F_EXPORT struct bar ffi_test_16(long x, long y, long z);
struct tiny { int x; };
-DLLEXPORT struct tiny ffi_test_17(int x);
-DLLEXPORT F_STDCALL int ffi_test_18(int x, int y, int z, int t);
-DLLEXPORT F_STDCALL struct bar ffi_test_19(long x, long y, long z);
-DLLEXPORT void ffi_test_20(double x1, double x2, double x3,
+F_EXPORT struct tiny ffi_test_17(int x);
+F_EXPORT F_STDCALL int ffi_test_18(int x, int y, int z, int t);
+F_EXPORT F_STDCALL struct bar ffi_test_19(long x, long y, long z);
+F_EXPORT void ffi_test_20(double x1, double x2, double x3,
double y1, double y2, double y3,
double z1, double z2, double z3);
-DLLEXPORT long long ffi_test_21(long x, long y);
-DLLEXPORT long ffi_test_22(long x, long long y, long long z);
-DLLEXPORT float ffi_test_23(float x[3], float y[3]);
+F_EXPORT long long ffi_test_21(long x, long y);
+F_EXPORT long ffi_test_22(long x, long long y, long long z);
+F_EXPORT float ffi_test_23(float x[3], float y[3]);
struct test_struct_1 { char x; };
-DLLEXPORT struct test_struct_1 ffi_test_24(void);
+F_EXPORT struct test_struct_1 ffi_test_24(void);
struct test_struct_2 { char x, y; };
-DLLEXPORT struct test_struct_2 ffi_test_25(void);
+F_EXPORT struct test_struct_2 ffi_test_25(void);
struct test_struct_3 { char x, y, z; };
-DLLEXPORT struct test_struct_3 ffi_test_26(void);
+F_EXPORT struct test_struct_3 ffi_test_26(void);
struct test_struct_4 { char x, y, z, a; };
-DLLEXPORT struct test_struct_4 ffi_test_27(void);
+F_EXPORT struct test_struct_4 ffi_test_27(void);
struct test_struct_5 { char x, y, z, a, b; };
-DLLEXPORT struct test_struct_5 ffi_test_28(void);
+F_EXPORT struct test_struct_5 ffi_test_28(void);
struct test_struct_6 { char x, y, z, a, b, c; };
-DLLEXPORT struct test_struct_6 ffi_test_29(void);
+F_EXPORT struct test_struct_6 ffi_test_29(void);
struct test_struct_7 { char x, y, z, a, b, c, d; };
-DLLEXPORT struct test_struct_7 ffi_test_30(void);
-DLLEXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41);
-DLLEXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41);
+F_EXPORT struct test_struct_7 ffi_test_30(void);
+F_EXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41);
+F_EXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41);
struct test_struct_8 { double x; double y; };
-DLLEXPORT double ffi_test_32(struct test_struct_8 x, int y);
+F_EXPORT double ffi_test_32(struct test_struct_8 x, int y);
struct test_struct_9 { float x; float y; };
-DLLEXPORT double ffi_test_33(struct test_struct_9 x, int y);
+F_EXPORT double ffi_test_33(struct test_struct_9 x, int y);
struct test_struct_10 { float x; int y; };
-DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y);
+F_EXPORT double ffi_test_34(struct test_struct_10 x, int y);
struct test_struct_11 { int x; int y; };
-DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y);
+F_EXPORT double ffi_test_35(struct test_struct_11 x, int y);
struct test_struct_12 { int a; double x; };
-DLLEXPORT double ffi_test_36(struct test_struct_12 x);
+F_EXPORT double ffi_test_36(struct test_struct_12 x);
-DLLEXPORT void ffi_test_36_point_5(void);
+F_EXPORT void ffi_test_36_point_5(void);
-DLLEXPORT int ffi_test_37(int (*f)(int, int, int));
+F_EXPORT int ffi_test_37(int (*f)(int, int, int));
-DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);
+F_EXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);
struct test_struct_13 { float x1, x2, x3, x4, x5, x6; };
-DLLEXPORT int ffi_test_39(long a, long b, struct test_struct_13 s);
+F_EXPORT int ffi_test_39(long a, long b, struct test_struct_13 s);
struct test_struct_14 { double x1, x2; };
-DLLEXPORT struct test_struct_14 ffi_test_40(double x1, double x2);
+F_EXPORT struct test_struct_14 ffi_test_40(double x1, double x2);
-DLLEXPORT struct test_struct_12 ffi_test_41(int a, double x);
+F_EXPORT struct test_struct_12 ffi_test_41(int a, double x);
struct test_struct_15 { float x, y; };
-DLLEXPORT struct test_struct_15 ffi_test_42(float x, float y);
+F_EXPORT struct test_struct_15 ffi_test_42(float x, float y);
struct test_struct_16 { float x; int a; };
-DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
+F_EXPORT struct test_struct_16 ffi_test_43(float x, int a);
-DLLEXPORT struct test_struct_14 ffi_test_44();
+F_EXPORT struct test_struct_14 ffi_test_44();
-DLLEXPORT _Complex float ffi_test_45(int x);
+F_EXPORT _Complex float ffi_test_45(int x);
-DLLEXPORT _Complex double ffi_test_46(int x);
+F_EXPORT _Complex double ffi_test_46(int x);
-DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
+F_EXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
diff --git a/vm/float_bits.h b/vm/float_bits.h
deleted file mode 100644
index a60d42f97c..0000000000
--- a/vm/float_bits.h
+++ /dev/null
@@ -1,40 +0,0 @@
-/* Some functions for converting floating point numbers to binary
-representations and vice versa */
-
-typedef union {
- double x;
- u64 y;
-} F_DOUBLE_BITS;
-
-INLINE u64 double_bits(double x)
-{
- F_DOUBLE_BITS b;
- b.x = x;
- return b.y;
-}
-
-INLINE double bits_double(u64 y)
-{
- F_DOUBLE_BITS b;
- b.y = y;
- return b.x;
-}
-
-typedef union {
- float x;
- u32 y;
-} F_FLOAT_BITS;
-
-INLINE u32 float_bits(float x)
-{
- F_FLOAT_BITS b;
- b.x = x;
- return b.y;
-}
-
-INLINE float bits_float(u32 y)
-{
- F_FLOAT_BITS b;
- b.y = y;
- return b.x;
-}
diff --git a/vm/float_bits.hpp b/vm/float_bits.hpp
new file mode 100644
index 0000000000..000bd49482
--- /dev/null
+++ b/vm/float_bits.hpp
@@ -0,0 +1,45 @@
+namespace factor
+{
+
+/* Some functions for converting floating point numbers to binary
+representations and vice versa */
+
+union double_bits_pun {
+ double x;
+ u64 y;
+};
+
+inline static u64 double_bits(double x)
+{
+ double_bits_pun b;
+ b.x = x;
+ return b.y;
+}
+
+inline static double bits_double(u64 y)
+{
+ double_bits_pun b;
+ b.y = y;
+ return b.x;
+}
+
+union float_bits_pun {
+ float x;
+ u32 y;
+};
+
+inline static u32 float_bits(float x)
+{
+ float_bits_pun b;
+ b.x = x;
+ return b.y;
+}
+
+inline static float bits_float(u32 y)
+{
+ float_bits_pun b;
+ b.y = y;
+ return b.x;
+}
+
+}
diff --git a/vm/generic_arrays.hpp b/vm/generic_arrays.hpp
new file mode 100644
index 0000000000..26c8149a10
--- /dev/null
+++ b/vm/generic_arrays.hpp
@@ -0,0 +1,59 @@
+namespace factor
+{
+
+template<typename T> cell array_capacity(T *array)
+{
+#ifdef FACTOR_DEBUG
+ assert(array->h.hi_tag() == T::type_number);
+#endif
+ return array->capacity >> TAG_BITS;
+}
+
+template <typename T> cell array_size(cell capacity)
+{
+ return sizeof(T) + capacity * T::element_size;
+}
+
+template <typename T> cell array_size(T *array)
+{
+ return array_size<T>(array_capacity(array));
+}
+
+template <typename T> T *allot_array_internal(cell capacity)
+{
+ T *array = allot<T>(array_size<T>(capacity));
+ array->capacity = tag_fixnum(capacity);
+ return array;
+}
+
+template <typename T> bool reallot_array_in_place_p(T *array, cell capacity)
+{
+ return in_zone(&nursery,array) && capacity <= array_capacity(array);
+}
+
+template <typename T> T *reallot_array(T *array_, cell capacity)
+{
+ gc_root<T> array(array_);
+
+ if(reallot_array_in_place_p(array.untagged(),capacity))
+ {
+ array->capacity = tag_fixnum(capacity);
+ return array.untagged();
+ }
+ else
+ {
+ cell to_copy = array_capacity(array.untagged());
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ T *new_array = allot_array_internal<T>(capacity);
+
+ memcpy(new_array + 1,array.untagged() + 1,to_copy * T::element_size);
+ memset((char *)(new_array + 1) + to_copy * T::element_size,
+ 0,(capacity - to_copy) * T::element_size);
+
+ return new_array;
+ }
+}
+
+}
diff --git a/vm/image.c b/vm/image.cpp
similarity index 53%
rename from vm/image.c
rename to vm/image.cpp
index 5ce7147200..2aa7727136 100755
--- a/vm/image.c
+++ b/vm/image.cpp
@@ -1,7 +1,10 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
/* Certain special objects in the image are known to the runtime */
-void init_objects(F_HEADER *h)
+static void init_objects(image_header *h)
{
memcpy(userenv,h->userenv,sizeof(userenv));
@@ -9,13 +12,13 @@ void init_objects(F_HEADER *h)
bignum_zero = h->bignum_zero;
bignum_pos_one = h->bignum_pos_one;
bignum_neg_one = h->bignum_neg_one;
-
- stage2 = (userenv[STAGE2_ENV] != F);
}
-INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
+cell data_relocation_base;
+
+static void load_data_heap(FILE *file, image_header *h, vm_parameters *p)
{
- CELL good_size = h->data_size + (1 << 20);
+ cell good_size = h->data_size + (1 << 20);
if(good_size > p->tenured_size)
p->tenured_size = good_size;
@@ -28,11 +31,11 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
clear_gc_stats();
- F_ZONE *tenured = &data_heap->generations[TENURED];
+ zone *tenured = &data->generations[TENURED];
- F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file);
+ fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file);
- if(bytes_read != h->data_size)
+ if((cell)bytes_read != h->data_size)
{
print_string("truncated image: ");
print_fixnum(bytes_read);
@@ -46,9 +49,11 @@ INLINE void load_data_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
data_relocation_base = h->data_relocation_base;
}
-INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
+cell code_relocation_base;
+
+static void load_code_heap(FILE *file, image_header *h, vm_parameters *p)
{
- CELL good_size = h->code_size + (1 << 19);
+ cell good_size = h->code_size + (1 << 19);
if(good_size > p->code_size)
p->code_size = good_size;
@@ -57,7 +62,7 @@ INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
if(h->code_size != 0)
{
- F_FIXNUM bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
+ size_t bytes_read = fread(first_block(&code),1,h->code_size,file);
if(bytes_read != h->code_size)
{
print_string("truncated image: ");
@@ -70,12 +75,239 @@ INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
}
code_relocation_base = h->code_relocation_base;
- build_free_list(&code_heap,h->code_size);
+ build_free_list(&code,h->code_size);
+}
+
+/* Save the current image to disk */
+bool save_image(const vm_char *filename)
+{
+ FILE* file;
+ image_header h;
+
+ file = OPEN_WRITE(filename);
+ if(file == NULL)
+ {
+ print_string("Cannot open image file: "); print_native_string(filename); nl();
+ print_string(strerror(errno)); nl();
+ return false;
+ }
+
+ zone *tenured = &data->generations[TENURED];
+
+ h.magic = IMAGE_MAGIC;
+ h.version = IMAGE_VERSION;
+ h.data_relocation_base = tenured->start;
+ h.data_size = tenured->here - tenured->start;
+ h.code_relocation_base = code.seg->start;
+ h.code_size = heap_size(&code);
+
+ h.t = T;
+ h.bignum_zero = bignum_zero;
+ h.bignum_pos_one = bignum_pos_one;
+ h.bignum_neg_one = bignum_neg_one;
+
+ cell i;
+ for(i = 0; i < USER_ENV; i++)
+ {
+ if(i < FIRST_SAVE_ENV)
+ h.userenv[i] = F;
+ else
+ h.userenv[i] = userenv[i];
+ }
+
+ bool ok = true;
+
+ if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
+ if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
+ if(fwrite(first_block(&code),h.code_size,1,file) != 1) ok = false;
+ if(fclose(file)) ok = false;
+
+ if(!ok)
+ {
+ print_string("save-image failed: "); print_string(strerror(errno)); nl();
+ }
+
+ return ok;
+}
+
+PRIMITIVE(save_image)
+{
+ /* do a full GC to push everything into tenured space */
+ gc();
+
+ gc_root<byte_array> path(dpop());
+ path.untag_check();
+ save_image((vm_char *)(path.untagged() + 1));
+}
+
+PRIMITIVE(save_image_and_exit)
+{
+ /* We unbox this before doing anything else. This is the only point
+ where we might throw an error, so we have to throw an error here since
+ later steps destroy the current image. */
+ gc_root<byte_array> path(dpop());
+ path.untag_check();
+
+ /* strip out userenv data which is set on startup anyway */
+ cell i;
+ for(i = 0; i < FIRST_SAVE_ENV; i++)
+ userenv[i] = F;
+
+ for(i = LAST_SAVE_ENV + 1; i < STACK_TRACES_ENV; i++)
+ userenv[i] = F;
+
+ /* do a full GC + code heap compaction */
+ performing_compaction = true;
+ compact_code_heap();
+ performing_compaction = false;
+
+ /* Save the image */
+ if(save_image((vm_char *)(path.untagged() + 1)))
+ exit(0);
+ else
+ exit(1);
+}
+
+static void data_fixup(cell *cell)
+{
+ if(immediate_p(*cell))
+ return;
+
+ zone *tenured = &data->generations[TENURED];
+ *cell += (tenured->start - data_relocation_base);
+}
+
+template <typename T> void code_fixup(T **handle)
+{
+ T *ptr = *handle;
+ T *new_ptr = (T *)(((cell)ptr) + (code.seg->start - code_relocation_base));
+ *handle = new_ptr;
+}
+
+static void fixup_word(word *word)
+{
+ if(word->code)
+ code_fixup(&word->code);
+ if(word->profiling)
+ code_fixup(&word->profiling);
+ code_fixup(&word->xt);
+}
+
+static void fixup_quotation(quotation *quot)
+{
+ if(quot->compiledp == F)
+ quot->xt = (void *)lazy_jit_compile;
+ else
+ {
+ code_fixup("->xt);
+ code_fixup("->code);
+ }
+}
+
+static void fixup_alien(alien *d)
+{
+ d->expired = T;
+}
+
+static void fixup_stack_frame(stack_frame *frame)
+{
+ code_fixup(&frame->xt);
+ code_fixup(&FRAME_RETURN_ADDRESS(frame));
+}
+
+static void fixup_callstack_object(callstack *stack)
+{
+ iterate_callstack_object(stack,fixup_stack_frame);
+}
+
+/* Initialize an object in a newly-loaded image */
+static void relocate_object(object *object)
+{
+ cell hi_tag = object->h.hi_tag();
+
+ /* Tuple relocation is a bit trickier; we have to fix up the
+ layout object before we can get the tuple size, so do_slots is
+ out of the question */
+ if(hi_tag == TUPLE_TYPE)
+ {
+ tuple *t = (tuple *)object;
+ data_fixup(&t->layout);
+
+ cell *scan = t->data();
+ cell *end = (cell *)((cell)object + untagged_object_size(object));
+
+ for(; scan < end; scan++)
+ data_fixup(scan);
+ }
+ else
+ {
+ do_slots((cell)object,data_fixup);
+
+ switch(hi_tag)
+ {
+ case WORD_TYPE:
+ fixup_word((word *)object);
+ break;
+ case QUOTATION_TYPE:
+ fixup_quotation((quotation *)object);
+ break;
+ case DLL_TYPE:
+ ffi_dlopen((dll *)object);
+ break;
+ case ALIEN_TYPE:
+ fixup_alien((alien *)object);
+ break;
+ case CALLSTACK_TYPE:
+ fixup_callstack_object((callstack *)object);
+ break;
+ }
+ }
+}
+
+/* Since the image might have been saved with a different base address than
+where it is loaded, we need to fix up pointers in the image. */
+void relocate_data()
+{
+ cell relocating;
+
+ cell i;
+ for(i = 0; i < USER_ENV; i++)
+ data_fixup(&userenv[i]);
+
+ data_fixup(&T);
+ data_fixup(&bignum_zero);
+ data_fixup(&bignum_pos_one);
+ data_fixup(&bignum_neg_one);
+
+ zone *tenured = &data->generations[TENURED];
+
+ for(relocating = tenured->start;
+ relocating < tenured->here;
+ relocating += untagged_object_size((object *)relocating))
+ {
+ object *obj = (object *)relocating;
+ allot_barrier(obj);
+ relocate_object(obj);
+ }
+}
+
+static void fixup_code_block(code_block *compiled)
+{
+ /* relocate literal table data */
+ data_fixup(&compiled->relocation);
+ data_fixup(&compiled->literals);
+
+ relocate_code_block(compiled);
+}
+
+void relocate_code()
+{
+ iterate_code_heap(fixup_code_block);
}
/* Read an image file from disk, only done once during startup */
/* This function also initializes the data and code heaps */
-void load_image(F_PARAMETERS *p)
+void load_image(vm_parameters *p)
{
FILE *file = OPEN_READ(p->image_path);
if(file == NULL)
@@ -85,8 +317,9 @@ void load_image(F_PARAMETERS *p)
exit(1);
}
- F_HEADER h;
- fread(&h,sizeof(F_HEADER),1,file);
+ image_header h;
+ if(fread(&h,sizeof(image_header),1,file) != 1)
+ fatal_error("Cannot read image header",0);
if(h.magic != IMAGE_MAGIC)
fatal_error("Bad image: magic number check failed",h.magic);
@@ -105,224 +338,7 @@ void load_image(F_PARAMETERS *p)
relocate_code();
/* Store image path name */
- userenv[IMAGE_ENV] = tag_object(from_native_string(p->image_path));
+ userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path);
}
-/* Save the current image to disk */
-bool save_image(const F_CHAR *filename)
-{
- FILE* file;
- F_HEADER h;
-
- file = OPEN_WRITE(filename);
- if(file == NULL)
- {
- print_string("Cannot open image file: "); print_native_string(filename); nl();
- print_string(strerror(errno)); nl();
- return false;
- }
-
- F_ZONE *tenured = &data_heap->generations[TENURED];
-
- h.magic = IMAGE_MAGIC;
- h.version = IMAGE_VERSION;
- h.data_relocation_base = tenured->start;
- h.data_size = tenured->here - tenured->start;
- h.code_relocation_base = code_heap.segment->start;
- h.code_size = heap_size(&code_heap);
-
- h.t = T;
- h.bignum_zero = bignum_zero;
- h.bignum_pos_one = bignum_pos_one;
- h.bignum_neg_one = bignum_neg_one;
-
- CELL i;
- for(i = 0; i < USER_ENV; i++)
- {
- if(i < FIRST_SAVE_ENV)
- h.userenv[i] = F;
- else
- h.userenv[i] = userenv[i];
- }
-
- fwrite(&h,sizeof(F_HEADER),1,file);
-
- if(fwrite((void*)tenured->start,h.data_size,1,file) != 1)
- {
- print_string("Save data heap failed: "); print_string(strerror(errno)); nl();
- return false;
- }
-
- if(fwrite(first_block(&code_heap),h.code_size,1,file) != 1)
- {
- print_string("Save code heap failed: "); print_string(strerror(errno)); nl();
- return false;
- }
-
- if(fclose(file))
- {
- print_string("Failed to close image file: "); print_string(strerror(errno)); nl();
- return false;
- }
-
- return true;
-}
-
-void primitive_save_image(void)
-{
- /* do a full GC to push everything into tenured space */
- gc();
-
- save_image(unbox_native_string());
-}
-
-void primitive_save_image_and_exit(void)
-{
- /* We unbox this before doing anything else. This is the only point
- where we might throw an error, so we have to throw an error here since
- later steps destroy the current image. */
- F_CHAR *path = unbox_native_string();
-
- REGISTER_C_STRING(path);
-
- /* strip out userenv data which is set on startup anyway */
- CELL i;
- for(i = 0; i < FIRST_SAVE_ENV; i++)
- userenv[i] = F;
-
- for(i = LAST_SAVE_ENV + 1; i < USER_ENV; i++)
- userenv[i] = F;
-
- /* do a full GC + code heap compaction */
- compact_code_heap();
-
- UNREGISTER_C_STRING(path);
-
- /* Save the image */
- if(save_image(path))
- exit(0);
- else
- exit(1);
-}
-
-void fixup_word(F_WORD *word)
-{
- if(stage2)
- {
- code_fixup((CELL)&word->code);
- if(word->profiling) code_fixup((CELL)&word->profiling);
- code_fixup((CELL)&word->xt);
- }
-}
-
-void fixup_quotation(F_QUOTATION *quot)
-{
- if(quot->compiledp == F)
- quot->xt = lazy_jit_compile;
- else
- {
- code_fixup((CELL)"->xt);
- code_fixup((CELL)"->code);
- }
-}
-
-void fixup_alien(F_ALIEN *d)
-{
- d->expired = T;
-}
-
-void fixup_stack_frame(F_STACK_FRAME *frame)
-{
- code_fixup((CELL)&frame->xt);
- code_fixup((CELL)&FRAME_RETURN_ADDRESS(frame));
-}
-
-void fixup_callstack_object(F_CALLSTACK *stack)
-{
- iterate_callstack_object(stack,fixup_stack_frame);
-}
-
-/* Initialize an object in a newly-loaded image */
-void relocate_object(CELL relocating)
-{
- /* Tuple relocation is a bit trickier; we have to fix up the
- fixup object before we can get the tuple size, so do_slots is
- out of the question */
- if(untag_header(get(relocating)) == TUPLE_TYPE)
- {
- data_fixup((CELL *)relocating + 1);
-
- CELL scan = relocating + 2 * CELLS;
- CELL size = untagged_object_size(relocating);
- CELL end = relocating + size;
-
- while(scan < end)
- {
- data_fixup((CELL *)scan);
- scan += CELLS;
- }
- }
- else
- {
- do_slots(relocating,data_fixup);
-
- switch(untag_header(get(relocating)))
- {
- case WORD_TYPE:
- fixup_word((F_WORD *)relocating);
- break;
- case QUOTATION_TYPE:
- fixup_quotation((F_QUOTATION *)relocating);
- break;
- case DLL_TYPE:
- ffi_dlopen((F_DLL *)relocating);
- break;
- case ALIEN_TYPE:
- fixup_alien((F_ALIEN *)relocating);
- break;
- case CALLSTACK_TYPE:
- fixup_callstack_object((F_CALLSTACK *)relocating);
- break;
- }
- }
-}
-
-/* Since the image might have been saved with a different base address than
-where it is loaded, we need to fix up pointers in the image. */
-void relocate_data()
-{
- CELL relocating;
-
- CELL i;
- for(i = 0; i < USER_ENV; i++)
- data_fixup(&userenv[i]);
-
- data_fixup(&T);
- data_fixup(&bignum_zero);
- data_fixup(&bignum_pos_one);
- data_fixup(&bignum_neg_one);
-
- F_ZONE *tenured = &data_heap->generations[TENURED];
-
- for(relocating = tenured->start;
- relocating < tenured->here;
- relocating += untagged_object_size(relocating))
- {
- allot_barrier(relocating);
- relocate_object(relocating);
- }
-}
-
-void fixup_code_block(F_CODE_BLOCK *compiled)
-{
- /* relocate literal table data */
- data_fixup(&compiled->relocation);
- data_fixup(&compiled->literals);
-
- relocate_code_block(compiled);
-}
-
-void relocate_code()
-{
- iterate_code_heap(fixup_code_block);
}
diff --git a/vm/image.h b/vm/image.h
deleted file mode 100755
index e26a6bb5b4..0000000000
--- a/vm/image.h
+++ /dev/null
@@ -1,68 +0,0 @@
-#define IMAGE_MAGIC 0x0f0e0d0c
-#define IMAGE_VERSION 4
-
-typedef struct {
- CELL magic;
- CELL version;
- /* all pointers in the image file are relocated from
- relocation_base to here when the image is loaded */
- CELL data_relocation_base;
- /* size of heap */
- CELL data_size;
- /* code relocation base */
- CELL code_relocation_base;
- /* size of code heap */
- CELL code_size;
- /* tagged pointer to t singleton */
- CELL t;
- /* tagged pointer to bignum 0 */
- CELL bignum_zero;
- /* tagged pointer to bignum 1 */
- CELL bignum_pos_one;
- /* tagged pointer to bignum -1 */
- CELL bignum_neg_one;
- /* Initial user environment */
- CELL userenv[USER_ENV];
-} F_HEADER;
-
-typedef struct {
- const F_CHAR *image_path;
- const F_CHAR *executable_path;
- CELL ds_size, rs_size;
- CELL gen_count, young_size, aging_size, tenured_size;
- CELL code_size;
- bool secure_gc;
- bool fep;
- bool console;
- bool stack_traces;
-} F_PARAMETERS;
-
-void load_image(F_PARAMETERS *p);
-void init_objects(F_HEADER *h);
-bool save_image(const F_CHAR *file);
-
-void primitive_save_image(void);
-void primitive_save_image_and_exit(void);
-
-/* relocation base of currently loaded image's data heap */
-CELL data_relocation_base;
-
-INLINE void data_fixup(CELL *cell)
-{
- if(immediate_p(*cell))
- return;
-
- F_ZONE *tenured = &data_heap->generations[TENURED];
- *cell += (tenured->start - data_relocation_base);
-}
-
-CELL code_relocation_base;
-
-INLINE void code_fixup(CELL cell)
-{
- CELL value = get(cell);
- put(cell,value + (code_heap.segment->start - code_relocation_base));
-}
-
-void relocate_data();
-void relocate_code();
diff --git a/vm/image.hpp b/vm/image.hpp
new file mode 100755
index 0000000000..c306f322de
--- /dev/null
+++ b/vm/image.hpp
@@ -0,0 +1,50 @@
+namespace factor
+{
+
+#define IMAGE_MAGIC 0x0f0e0d0c
+#define IMAGE_VERSION 4
+
+struct image_header {
+ cell magic;
+ cell version;
+ /* all pointers in the image file are relocated from
+ relocation_base to here when the image is loaded */
+ cell data_relocation_base;
+ /* size of heap */
+ cell data_size;
+ /* code relocation base */
+ cell code_relocation_base;
+ /* size of code heap */
+ cell code_size;
+ /* tagged pointer to t singleton */
+ cell t;
+ /* tagged pointer to bignum 0 */
+ cell bignum_zero;
+ /* tagged pointer to bignum 1 */
+ cell bignum_pos_one;
+ /* tagged pointer to bignum -1 */
+ cell bignum_neg_one;
+ /* Initial user environment */
+ cell userenv[USER_ENV];
+};
+
+struct vm_parameters {
+ const vm_char *image_path;
+ const vm_char *executable_path;
+ cell ds_size, rs_size;
+ cell gen_count, young_size, aging_size, tenured_size;
+ cell code_size;
+ bool secure_gc;
+ bool fep;
+ bool console;
+ bool stack_traces;
+ cell max_pic_size;
+};
+
+void load_image(vm_parameters *p);
+bool save_image(const vm_char *file);
+
+PRIMITIVE(save_image);
+PRIMITIVE(save_image_and_exit);
+
+}
diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp
new file mode 100644
index 0000000000..5d9fbf069e
--- /dev/null
+++ b/vm/inline_cache.cpp
@@ -0,0 +1,261 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+cell max_pic_size;
+
+cell cold_call_to_ic_transitions;
+cell ic_to_pic_transitions;
+cell pic_to_mega_transitions;
+
+/* PIC_TAG, PIC_HI_TAG, PIC_TUPLE, PIC_HI_TAG_TUPLE */
+cell pic_counts[4];
+
+void init_inline_caching(int max_size)
+{
+ max_pic_size = max_size;
+}
+
+void deallocate_inline_cache(cell return_address)
+{
+ /* Find the call target. */
+ void *old_xt = get_call_target(return_address);
+ code_block *old_block = (code_block *)old_xt - 1;
+ cell old_type = old_block->block.type;
+
+#ifdef FACTOR_DEBUG
+ /* The call target was either another PIC,
+ or a compiled quotation (megamorphic stub) */
+ assert(old_type == PIC_TYPE || old_type == QUOTATION_TYPE);
+#endif
+
+ if(old_type == PIC_TYPE)
+ heap_free(&code,&old_block->block);
+}
+
+/* Figure out what kind of type check the PIC needs based on the methods
+it contains */
+static cell determine_inline_cache_type(array *cache_entries)
+{
+ bool seen_hi_tag = false, seen_tuple = false;
+
+ cell i;
+ for(i = 0; i < array_capacity(cache_entries); i += 2)
+ {
+ cell klass = array_nth(cache_entries,i);
+
+ /* Is it a tuple layout? */
+ switch(TAG(klass))
+ {
+ case FIXNUM_TYPE:
+ {
+ fixnum type = untag_fixnum(klass);
+ if(type >= HEADER_TYPE)
+ seen_hi_tag = true;
+ }
+ break;
+ case ARRAY_TYPE:
+ seen_tuple = true;
+ break;
+ default:
+ critical_error("Expected a fixnum or array",klass);
+ break;
+ }
+ }
+
+ if(seen_hi_tag && seen_tuple) return PIC_HI_TAG_TUPLE;
+ if(seen_hi_tag && !seen_tuple) return PIC_HI_TAG;
+ if(!seen_hi_tag && seen_tuple) return PIC_TUPLE;
+ if(!seen_hi_tag && !seen_tuple) return PIC_TAG;
+
+ critical_error("Oops",0);
+ return -1;
+}
+
+static void update_pic_count(cell type)
+{
+ pic_counts[type - PIC_TAG]++;
+}
+
+struct inline_cache_jit : public jit {
+ fixnum index;
+
+ inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {};
+
+ void emit_check(cell klass);
+ void compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_);
+};
+
+void inline_cache_jit::emit_check(cell klass)
+{
+ cell code_template;
+ if(TAG(klass) == FIXNUM_TYPE && untag_fixnum(klass) < HEADER_TYPE)
+ code_template = userenv[PIC_CHECK_TAG];
+ else
+ code_template = userenv[PIC_CHECK];
+
+ emit_with(code_template,klass);
+}
+
+/* index: 0 = top of stack, 1 = item underneath, etc
+ cache_entries: array of class/method pairs */
+void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_)
+{
+ gc_root<word> generic_word(generic_word_);
+ gc_root<array> methods(methods_);
+ gc_root<array> cache_entries(cache_entries_);
+
+ cell inline_cache_type = determine_inline_cache_type(cache_entries.untagged());
+ update_pic_count(inline_cache_type);
+
+ /* Generate machine code to determine the object's class. */
+ emit_class_lookup(index,inline_cache_type);
+
+ /* Generate machine code to check, in turn, if the class is one of the cached entries. */
+ cell i;
+ for(i = 0; i < array_capacity(cache_entries.untagged()); i += 2)
+ {
+ /* Class equal? */
+ cell klass = array_nth(cache_entries.untagged(),i);
+ emit_check(klass);
+
+ /* Yes? Jump to method */
+ cell method = array_nth(cache_entries.untagged(),i + 1);
+ emit_with(userenv[PIC_HIT],method);
+ }
+
+ /* Generate machine code to handle a cache miss, which ultimately results in
+ this function being called again.
+
+ The inline-cache-miss primitive call receives enough information to
+ reconstruct the PIC. */
+ push(generic_word.value());
+ push(methods.value());
+ push(tag_fixnum(index));
+ push(cache_entries.value());
+ word_jump(userenv[PIC_MISS_WORD]);
+}
+
+static code_block *compile_inline_cache(fixnum index,
+ cell generic_word_,
+ cell methods_,
+ cell cache_entries_)
+{
+ gc_root<word> generic_word(generic_word_);
+ gc_root<array> methods(methods_);
+ gc_root<array> cache_entries(cache_entries_);
+
+ inline_cache_jit jit(generic_word.value());
+ jit.compile_inline_cache(index,generic_word.value(),methods.value(),cache_entries.value());
+ code_block *code = jit.to_code_block();
+ relocate_code_block(code);
+ return code;
+}
+
+/* A generic word's definition performs general method lookup. Allocates memory */
+static void *megamorphic_call_stub(cell generic_word)
+{
+ return untag<word>(generic_word)->xt;
+}
+
+static cell inline_cache_size(cell cache_entries)
+{
+ return array_capacity(untag_check<array>(cache_entries)) / 2;
+}
+
+/* Allocates memory */
+static cell add_inline_cache_entry(cell cache_entries_, cell klass_, cell method_)
+{
+ gc_root<array> cache_entries(cache_entries_);
+ gc_root<object> klass(klass_);
+ gc_root<word> method(method_);
+
+ cell pic_size = array_capacity(cache_entries.untagged());
+ gc_root<array> new_cache_entries(reallot_array(cache_entries.untagged(),pic_size + 2));
+ set_array_nth(new_cache_entries.untagged(),pic_size,klass.value());
+ set_array_nth(new_cache_entries.untagged(),pic_size + 1,method.value());
+ return new_cache_entries.value();
+}
+
+static void update_pic_transitions(cell pic_size)
+{
+ if(pic_size == max_pic_size)
+ pic_to_mega_transitions++;
+ else if(pic_size == 0)
+ cold_call_to_ic_transitions++;
+ else if(pic_size == 1)
+ ic_to_pic_transitions++;
+}
+
+/* The cache_entries parameter is either f (on cold call site) or an array (on cache miss).
+Called from assembly with the actual return address */
+void *inline_cache_miss(cell return_address)
+{
+ check_code_pointer(return_address);
+
+ /* Since each PIC is only referenced from a single call site,
+ if the old call target was a PIC, we can deallocate it immediately,
+ instead of leaving dead PICs around until the next GC. */
+ deallocate_inline_cache(return_address);
+
+ gc_root<array> cache_entries(dpop());
+ fixnum index = untag_fixnum(dpop());
+ gc_root<array> methods(dpop());
+ gc_root<word> generic_word(dpop());
+ gc_root<object> object(((cell *)ds)[-index]);
+
+ void *xt;
+
+ cell pic_size = inline_cache_size(cache_entries.value());
+
+ update_pic_transitions(pic_size);
+
+ if(pic_size >= max_pic_size)
+ xt = megamorphic_call_stub(generic_word.value());
+ else
+ {
+ cell klass = object_class(object.value());
+ cell method = lookup_method(object.value(),methods.value());
+
+ gc_root<array> new_cache_entries(add_inline_cache_entry(
+ cache_entries.value(),
+ klass,
+ method));
+ xt = compile_inline_cache(index,
+ generic_word.value(),
+ methods.value(),
+ new_cache_entries.value()) + 1;
+ }
+
+ /* Install the new stub. */
+ set_call_target(return_address,xt);
+
+#ifdef PIC_DEBUG
+ printf("Updated call site 0x%lx with 0x%lx\n",return_address,(cell)xt);
+#endif
+
+ return xt;
+}
+
+PRIMITIVE(reset_inline_cache_stats)
+{
+ cold_call_to_ic_transitions = ic_to_pic_transitions = pic_to_mega_transitions = 0;
+ cell i;
+ for(i = 0; i < 4; i++) pic_counts[i] = 0;
+}
+
+PRIMITIVE(inline_cache_stats)
+{
+ growable_array stats;
+ stats.add(allot_cell(cold_call_to_ic_transitions));
+ stats.add(allot_cell(ic_to_pic_transitions));
+ stats.add(allot_cell(pic_to_mega_transitions));
+ cell i;
+ for(i = 0; i < 4; i++)
+ stats.add(allot_cell(pic_counts[i]));
+ stats.trim();
+ dpush(stats.elements.value());
+}
+
+}
diff --git a/vm/inline_cache.hpp b/vm/inline_cache.hpp
new file mode 100644
index 0000000000..84334efc78
--- /dev/null
+++ b/vm/inline_cache.hpp
@@ -0,0 +1,14 @@
+namespace factor
+{
+
+extern cell max_pic_size;
+
+void init_inline_caching(int max_size);
+
+PRIMITIVE(reset_inline_cache_stats);
+PRIMITIVE(inline_cache_stats);
+PRIMITIVE(inline_cache_miss);
+
+extern "C" void *inline_cache_miss(cell return_address);
+
+}
diff --git a/vm/io.c b/vm/io.cpp
similarity index 63%
rename from vm/io.c
rename to vm/io.cpp
index d88f1bab50..2d6c94faf0 100755
--- a/vm/io.c
+++ b/vm/io.cpp
@@ -1,4 +1,7 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
/* Simple wrappers for ANSI C I/O functions, used for bootstrapping.
@@ -13,9 +16,9 @@ normal operation. */
void init_c_io(void)
{
- userenv[STDIN_ENV] = allot_alien(F,(CELL)stdin);
- userenv[STDOUT_ENV] = allot_alien(F,(CELL)stdout);
- userenv[STDERR_ENV] = allot_alien(F,(CELL)stderr);
+ userenv[STDIN_ENV] = allot_alien(F,(cell)stdin);
+ userenv[STDOUT_ENV] = allot_alien(F,(cell)stdout);
+ userenv[STDERR_ENV] = allot_alien(F,(cell)stderr);
}
void io_error(void)
@@ -25,20 +28,20 @@ void io_error(void)
return;
#endif
- CELL error = tag_object(from_char_string(strerror(errno)));
- general_error(ERROR_IO,error,F,NULL);
+ general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
}
-void primitive_fopen(void)
+PRIMITIVE(fopen)
{
- char *mode = unbox_char_string();
- REGISTER_C_STRING(mode);
- char *path = unbox_char_string();
- UNREGISTER_C_STRING(mode);
+ gc_root<byte_array> mode(dpop());
+ gc_root<byte_array> path(dpop());
+ mode.untag_check();
+ path.untag_check();
for(;;)
{
- FILE *file = fopen(path,mode);
+ FILE *file = fopen((char *)(path.untagged() + 1),
+ (char *)(mode.untagged() + 1));
if(file == NULL)
io_error();
else
@@ -49,9 +52,9 @@ void primitive_fopen(void)
}
}
-void primitive_fgetc(void)
+PRIMITIVE(fgetc)
{
- FILE* file = unbox_alien();
+ FILE *file = (FILE *)unbox_alien();
for(;;)
{
@@ -74,22 +77,22 @@ void primitive_fgetc(void)
}
}
-void primitive_fread(void)
+PRIMITIVE(fread)
{
- FILE* file = unbox_alien();
- CELL size = unbox_array_size();
+ FILE *file = (FILE *)unbox_alien();
+ fixnum size = unbox_array_size();
if(size == 0)
{
- dpush(tag_object(allot_string(0,0)));
+ dpush(tag<string>(allot_string(0,0)));
return;
}
- F_BYTE_ARRAY *buf = allot_byte_array(size);
+ gc_root<byte_array> buf(allot_array_internal<byte_array>(size));
for(;;)
{
- int c = fread(buf + 1,1,size,file);
+ int c = fread(buf.untagged() + 1,1,size,file);
if(c <= 0)
{
if(feof(file))
@@ -104,22 +107,20 @@ void primitive_fread(void)
{
if(c != size)
{
- REGISTER_UNTAGGED(buf);
- F_BYTE_ARRAY *new_buf = allot_byte_array(c);
- UNREGISTER_UNTAGGED(buf);
- memcpy(new_buf + 1, buf + 1,c);
+ byte_array *new_buf = allot_byte_array(c);
+ memcpy(new_buf + 1, buf.untagged() + 1,c);
buf = new_buf;
}
- dpush(tag_object(buf));
+ dpush(buf.value());
break;
}
}
}
-void primitive_fputc(void)
+PRIMITIVE(fputc)
{
- FILE *file = unbox_alien();
- F_FIXNUM ch = to_fixnum(dpop());
+ FILE *file = (FILE *)unbox_alien();
+ fixnum ch = to_fixnum(dpop());
for(;;)
{
@@ -134,11 +135,11 @@ void primitive_fputc(void)
}
}
-void primitive_fwrite(void)
+PRIMITIVE(fwrite)
{
- FILE *file = unbox_alien();
- F_BYTE_ARRAY *text = untag_byte_array(dpop());
- F_FIXNUM length = array_capacity(text);
+ FILE *file = (FILE *)unbox_alien();
+ byte_array *text = untag_check<byte_array>(dpop());
+ cell length = array_capacity(text);
char *string = (char *)(text + 1);
if(length == 0)
@@ -163,10 +164,10 @@ void primitive_fwrite(void)
}
}
-void primitive_fseek(void)
+PRIMITIVE(fseek)
{
int whence = to_fixnum(dpop());
- FILE *file = unbox_alien();
+ FILE *file = (FILE *)unbox_alien();
off_t offset = to_signed_8(dpop());
switch(whence)
@@ -188,9 +189,9 @@ void primitive_fseek(void)
}
}
-void primitive_fflush(void)
+PRIMITIVE(fflush)
{
- FILE *file = unbox_alien();
+ FILE *file = (FILE *)unbox_alien();
for(;;)
{
if(fflush(file) == EOF)
@@ -200,9 +201,9 @@ void primitive_fflush(void)
}
}
-void primitive_fclose(void)
+PRIMITIVE(fclose)
{
- FILE *file = unbox_alien();
+ FILE *file = (FILE *)unbox_alien();
for(;;)
{
if(fclose(file) == EOF)
@@ -215,12 +216,14 @@ void primitive_fclose(void)
/* This function is used by FFI I/O. Accessing the errno global directly is
not portable, since on some libc's errno is not a global but a funky macro that
reads thread-local storage. */
-int err_no(void)
+VM_C_API int err_no(void)
{
return errno;
}
-void clear_err_no(void)
+VM_C_API void clear_err_no(void)
{
errno = 0;
}
+
+}
diff --git a/vm/io.h b/vm/io.h
deleted file mode 100755
index 63a9c35490..0000000000
--- a/vm/io.h
+++ /dev/null
@@ -1,18 +0,0 @@
-void init_c_io(void);
-void io_error(void);
-DLLEXPORT int err_no(void);
-DLLEXPORT void clear_err_no(void);
-
-void primitive_fopen(void);
-void primitive_fgetc(void);
-void primitive_fread(void);
-void primitive_fputc(void);
-void primitive_fwrite(void);
-void primitive_fflush(void);
-void primitive_fseek(void);
-void primitive_fclose(void);
-
-/* Platform specific primitives */
-void primitive_open_file(void);
-void primitive_existsp(void);
-void primitive_read_dir(void);
diff --git a/vm/io.hpp b/vm/io.hpp
new file mode 100755
index 0000000000..968e96f0b5
--- /dev/null
+++ b/vm/io.hpp
@@ -0,0 +1,24 @@
+namespace factor
+{
+
+void init_c_io(void);
+void io_error(void);
+
+PRIMITIVE(fopen);
+PRIMITIVE(fgetc);
+PRIMITIVE(fread);
+PRIMITIVE(fputc);
+PRIMITIVE(fwrite);
+PRIMITIVE(fflush);
+PRIMITIVE(fseek);
+PRIMITIVE(fclose);
+
+/* Platform specific primitives */
+PRIMITIVE(open_file);
+PRIMITIVE(existsp);
+PRIMITIVE(read_dir);
+
+VM_C_API int err_no(void);
+VM_C_API void clear_err_no(void);
+
+}
diff --git a/vm/jit.cpp b/vm/jit.cpp
new file mode 100644
index 0000000000..bb86506058
--- /dev/null
+++ b/vm/jit.cpp
@@ -0,0 +1,117 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Simple code generator used by:
+- profiler (profiler.cpp),
+- quotation compiler (quotations.cpp),
+- megamorphic caches (dispatch.cpp),
+- polymorphic inline caches (inline_cache.cpp) */
+
+/* Allocates memory */
+jit::jit(cell type_, cell owner_)
+ : type(type_),
+ owner(owner_),
+ code(),
+ relocation(),
+ literals(),
+ computing_offset_p(false),
+ position(0),
+ offset(0)
+{
+ if(stack_traces_p()) literal(owner.value());
+}
+
+relocation_entry jit::rel_to_emit(cell code_template, bool *rel_p)
+{
+ array *quadruple = untag<array>(code_template);
+ cell rel_class = array_nth(quadruple,1);
+ cell rel_type = array_nth(quadruple,2);
+ cell offset = array_nth(quadruple,3);
+
+ if(rel_class == F)
+ {
+ *rel_p = false;
+ return 0;
+ }
+ else
+ {
+ *rel_p = true;
+ return (untag_fixnum(rel_type) << 28)
+ | (untag_fixnum(rel_class) << 24)
+ | ((code.count + untag_fixnum(offset)));
+ }
+}
+
+/* Allocates memory */
+void jit::emit(cell code_template_)
+{
+ gc_root<array> code_template(code_template_);
+
+ bool rel_p;
+ relocation_entry rel = rel_to_emit(code_template.value(),&rel_p);
+ if(rel_p) relocation.append_bytes(&rel,sizeof(relocation_entry));
+
+ gc_root<byte_array> insns(array_nth(code_template.untagged(),0));
+
+ if(computing_offset_p)
+ {
+ cell size = array_capacity(insns.untagged());
+
+ if(offset == 0)
+ {
+ position--;
+ computing_offset_p = false;
+ }
+ else if(offset < size)
+ {
+ position++;
+ computing_offset_p = false;
+ }
+ else
+ offset -= size;
+ }
+
+ code.append_byte_array(insns.value());
+}
+
+void jit::emit_with(cell code_template_, cell argument_) {
+ gc_root<array> code_template(code_template_);
+ gc_root<object> argument(argument_);
+ literal(argument.value());
+ emit(code_template.value());
+}
+
+void jit::emit_class_lookup(fixnum index, cell type)
+{
+ emit_with(userenv[PIC_LOAD],tag_fixnum(-index * sizeof(cell)));
+ emit(userenv[type]);
+}
+
+/* Facility to convert compiled code offsets to quotation offsets.
+Call jit_compute_offset() with the compiled code offset, then emit
+code, and at the end jit->position is the quotation position. */
+void jit::compute_position(cell offset_)
+{
+ computing_offset_p = true;
+ position = 0;
+ offset = offset_;
+}
+
+/* Allocates memory */
+code_block *jit::to_code_block()
+{
+ code.trim();
+ relocation.trim();
+ literals.trim();
+
+ return add_code_block(
+ type,
+ code.elements.value(),
+ F, /* no labels */
+ relocation.elements.value(),
+ literals.elements.value());
+}
+
+}
diff --git a/vm/jit.hpp b/vm/jit.hpp
new file mode 100644
index 0000000000..30b5163b4a
--- /dev/null
+++ b/vm/jit.hpp
@@ -0,0 +1,64 @@
+namespace factor
+{
+
+struct jit {
+ cell type;
+ gc_root<object> owner;
+ growable_byte_array code;
+ growable_byte_array relocation;
+ growable_array literals;
+ bool computing_offset_p;
+ fixnum position;
+ cell offset;
+
+ jit(cell jit_type, cell owner);
+ void compute_position(cell offset);
+
+ relocation_entry rel_to_emit(cell code_template, bool *rel_p);
+ void emit(cell code_template);
+
+ void literal(cell literal) { literals.add(literal); }
+ void emit_with(cell code_template_, cell literal_);
+
+ void push(cell literal) {
+ emit_with(userenv[JIT_PUSH_IMMEDIATE],literal);
+ }
+
+ void word_jump(cell word) {
+ emit_with(userenv[JIT_WORD_JUMP],word);
+ }
+
+ void word_call(cell word) {
+ emit_with(userenv[JIT_WORD_CALL],word);
+ }
+
+ void emit_subprimitive(cell word_) {
+ gc_root<word> word(word_);
+ gc_root<array> code_template(word->subprimitive);
+ if(array_nth(code_template.untagged(),1) != F) literal(T);
+ emit(code_template.value());
+ }
+
+ void emit_class_lookup(fixnum index, cell type);
+
+ fixnum get_position() {
+ if(computing_offset_p)
+ {
+ /* If this is still on, emit() didn't clear it,
+ so the offset was out of bounds */
+ return -1;
+ }
+ else
+ return position;
+ }
+
+ void set_position(fixnum position_) {
+ if(computing_offset_p)
+ position = position_;
+ }
+
+
+ code_block *to_code_block();
+};
+
+}
diff --git a/vm/layouts.h b/vm/layouts.h
deleted file mode 100755
index e9cdef6272..0000000000
--- a/vm/layouts.h
+++ /dev/null
@@ -1,270 +0,0 @@
-#define INLINE inline static
-
-typedef unsigned char u8;
-typedef unsigned short u16;
-typedef unsigned int u32;
-typedef unsigned long long u64;
-typedef signed char s8;
-typedef signed short s16;
-typedef signed int s32;
-typedef signed long long s64;
-
-#ifdef _WIN64
- typedef long long F_FIXNUM;
- typedef unsigned long long CELL;
-#else
- typedef long F_FIXNUM;
- typedef unsigned long CELL;
-#endif
-
-#define CELLS ((signed)sizeof(CELL))
-
-#define WORD_SIZE (CELLS*8)
-#define HALF_WORD_SIZE (CELLS*4)
-#define HALF_WORD_MASK (((unsigned long)1<<HALF_WORD_SIZE)-1)
-
-#define TAG_MASK 7
-#define TAG_BITS 3
-#define TAG(cell) ((CELL)(cell) & TAG_MASK)
-#define UNTAG(cell) ((CELL)(cell) & ~TAG_MASK)
-#define RETAG(cell,tag) (UNTAG(cell) | (tag))
-
-/*** Tags ***/
-#define FIXNUM_TYPE 0
-#define BIGNUM_TYPE 1
-#define TUPLE_TYPE 2
-#define OBJECT_TYPE 3
-#define RATIO_TYPE 4
-#define FLOAT_TYPE 5
-#define COMPLEX_TYPE 6
-
-/* Canonical F object */
-#define F_TYPE 7
-#define F F_TYPE
-
-#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */
-
-#define GC_COLLECTED 5 /* See gc.c */
-
-/*** Header types ***/
-#define ARRAY_TYPE 8
-#define WRAPPER_TYPE 9
-#define BYTE_ARRAY_TYPE 10
-#define CALLSTACK_TYPE 11
-#define STRING_TYPE 12
-#define WORD_TYPE 13
-#define QUOTATION_TYPE 14
-#define DLL_TYPE 15
-#define ALIEN_TYPE 16
-
-#define TYPE_COUNT 17
-
-INLINE bool immediate_p(CELL obj)
-{
- return (obj == F || TAG(obj) == FIXNUM_TYPE);
-}
-
-INLINE F_FIXNUM untag_fixnum_fast(CELL tagged)
-{
- return ((F_FIXNUM)tagged) >> TAG_BITS;
-}
-
-INLINE CELL tag_fixnum(F_FIXNUM untagged)
-{
- return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
-}
-
-INLINE void *untag_object(CELL tagged)
-{
- return (void *)UNTAG(tagged);
-}
-
-typedef void *XT;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- /* tagged */
- CELL capacity;
-} F_ARRAY;
-
-typedef F_ARRAY F_BYTE_ARRAY;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- /* tagged num of chars */
- CELL length;
- /* tagged */
- CELL aux;
- /* tagged */
- CELL hashcode;
-} F_STRING;
-
-/* The compiled code heap is structured into blocks. */
-typedef enum
-{
- B_FREE,
- B_ALLOCATED,
- B_MARKED
-} F_BLOCK_STATUS;
-
-typedef struct _F_BLOCK
-{
- char status; /* free or allocated? */
- char type; /* this is WORD_TYPE or QUOTATION_TYPE */
- char last_scan; /* the youngest generation in which this block's literals may live */
- char needs_fixup; /* is this a new block that needs full fixup? */
-
- /* In bytes, includes this header */
- CELL size;
-
- /* Used during compaction */
- struct _F_BLOCK *forwarding;
-} F_BLOCK;
-
-typedef struct _F_FREE_BLOCK
-{
- F_BLOCK block;
-
- /* Filled in on image load */
- struct _F_FREE_BLOCK *next_free;
-} F_FREE_BLOCK;
-
-typedef struct
-{
- F_BLOCK block;
- CELL literals; /* # bytes */
- CELL relocation; /* tagged pointer to byte-array or f */
-} F_CODE_BLOCK;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- /* TAGGED header */
- CELL header;
- /* TAGGED hashcode */
- CELL hashcode;
- /* TAGGED word name */
- CELL name;
- /* TAGGED word vocabulary */
- CELL vocabulary;
- /* TAGGED definition */
- CELL def;
- /* TAGGED property assoc for library code */
- CELL props;
- /* TAGGED t or f, t means its compiled with the optimizing compiler,
- f means its compiled with the non-optimizing compiler */
- CELL optimizedp;
- /* TAGGED call count for profiling */
- CELL counter;
- /* TAGGED machine code for sub-primitive */
- CELL subprimitive;
- /* UNTAGGED execution token: jump here to execute word */
- XT xt;
- /* UNTAGGED compiled code block */
- F_CODE_BLOCK *code;
- /* UNTAGGED profiler stub */
- F_CODE_BLOCK *profiling;
-} F_WORD;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- CELL object;
-} F_WRAPPER;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- CELL numerator;
- CELL denominator;
-} F_RATIO;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
-/* We use a union here to force the float value to be aligned on an
-8-byte boundary. */
- union {
- CELL header;
- long long padding;
- };
- double n;
-} F_FLOAT;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- /* tagged */
- CELL array;
- /* tagged */
- CELL compiledp;
- /* tagged */
- CELL cached_effect;
- /* tagged */
- CELL cache_counter;
- /* UNTAGGED */
- XT xt;
- /* UNTAGGED compiled code block */
- F_CODE_BLOCK *code;
-} F_QUOTATION;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- CELL real;
- CELL imaginary;
-} F_COMPLEX;
-
-/* Assembly code makes assumptions about the layout of this struct */
-typedef struct {
- CELL header;
- /* tagged */
- CELL alien;
- /* tagged */
- CELL expired;
- /* untagged */
- CELL displacement;
-} F_ALIEN;
-
-typedef struct {
- CELL header;
- /* tagged byte array holding a C string */
- CELL path;
- /* OS-specific handle */
- void *dll;
-} F_DLL;
-
-typedef struct {
- CELL header;
- /* tagged */
- CELL length;
-} F_CALLSTACK;
-
-typedef struct
-{
- XT xt;
- /* Frame size in bytes */
- CELL size;
-} F_STACK_FRAME;
-
-/* These are really just arrays, but certain elements have special
-significance */
-typedef struct
-{
- CELL header;
- /* tagged */
- CELL capacity;
- /* tagged */
- CELL class;
- /* tagged fixnum */
- CELL size;
- /* tagged fixnum */
- CELL echelon;
-} F_TUPLE_LAYOUT;
-
-typedef struct
-{
- CELL header;
- /* tagged layout */
- CELL layout;
-} F_TUPLE;
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
new file mode 100755
index 0000000000..4928fda632
--- /dev/null
+++ b/vm/layouts.hpp
@@ -0,0 +1,323 @@
+namespace factor
+{
+
+typedef unsigned char u8;
+typedef unsigned short u16;
+typedef unsigned int u32;
+typedef unsigned long long u64;
+typedef signed char s8;
+typedef signed short s16;
+typedef signed int s32;
+typedef signed long long s64;
+
+#ifdef _WIN64
+ typedef long long fixnum;
+ typedef unsigned long long cell;
+#else
+ typedef long fixnum;
+ typedef unsigned long cell;
+#endif
+
+inline static cell align(cell a, cell b)
+{
+ return (a + (b-1)) & ~(b-1);
+}
+
+#define align8(a) align(a,8)
+#define align_page(a) align(a,getpagesize())
+
+#define WORD_SIZE (signed)(sizeof(cell)*8)
+
+#define TAG_MASK 7
+#define TAG_BITS 3
+#define TAG(x) ((cell)(x) & TAG_MASK)
+#define UNTAG(x) ((cell)(x) & ~TAG_MASK)
+#define RETAG(x,tag) (UNTAG(x) | (tag))
+
+/*** Tags ***/
+#define FIXNUM_TYPE 0
+#define BIGNUM_TYPE 1
+#define ARRAY_TYPE 2
+#define FLOAT_TYPE 3
+#define QUOTATION_TYPE 4
+#define F_TYPE 5
+#define OBJECT_TYPE 6
+#define TUPLE_TYPE 7
+
+/* Canonical F object */
+#define F F_TYPE
+
+#define HEADER_TYPE 8 /* anything less than this is a tag */
+
+#define GC_COLLECTED 5 /* can be anything other than FIXNUM_TYPE */
+
+/*** Header types ***/
+#define WRAPPER_TYPE 8
+#define BYTE_ARRAY_TYPE 9
+#define CALLSTACK_TYPE 10
+#define STRING_TYPE 11
+#define WORD_TYPE 12
+#define DLL_TYPE 13
+#define ALIEN_TYPE 14
+
+#define TYPE_COUNT 15
+
+/* Not a real type, but code_block's type field can be set to this */
+#define PIC_TYPE 69
+
+inline static bool immediate_p(cell obj)
+{
+ return (obj == F || TAG(obj) == FIXNUM_TYPE);
+}
+
+inline static fixnum untag_fixnum(cell tagged)
+{
+#ifdef FACTOR_DEBUG
+ assert(TAG(tagged) == FIXNUM_TYPE);
+#endif
+ return ((fixnum)tagged) >> TAG_BITS;
+}
+
+inline static cell tag_fixnum(fixnum untagged)
+{
+ return RETAG(untagged << TAG_BITS,FIXNUM_TYPE);
+}
+
+inline static cell tag_for(cell type)
+{
+ return type < HEADER_TYPE ? type : OBJECT_TYPE;
+}
+
+class object;
+
+struct header {
+ cell value;
+
+ header(cell value_) : value(value_ << TAG_BITS) {}
+
+ void check_header() {
+#ifdef FACTOR_DEBUG
+ assert(TAG(value) == FIXNUM_TYPE && untag_fixnum(value) < TYPE_COUNT);
+#endif
+ }
+
+ cell hi_tag() {
+ check_header();
+ return value >> TAG_BITS;
+ }
+
+ bool forwarding_pointer_p() {
+ return TAG(value) == GC_COLLECTED;
+ }
+
+ object *forwarding_pointer() {
+ return (object *)UNTAG(value);
+ }
+
+ void forward_to(object *pointer) {
+ value = RETAG(pointer,GC_COLLECTED);
+ }
+};
+
+#define NO_TYPE_CHECK static const cell type_number = TYPE_COUNT
+
+struct object {
+ NO_TYPE_CHECK;
+ header h;
+ cell *slots() { return (cell *)this; }
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct array : public object {
+ static const cell type_number = ARRAY_TYPE;
+ static const cell element_size = sizeof(cell);
+ /* tagged */
+ cell capacity;
+
+ cell *data() { return (cell *)(this + 1); }
+};
+
+/* These are really just arrays, but certain elements have special
+significance */
+struct tuple_layout : public array {
+ NO_TYPE_CHECK;
+ /* tagged */
+ cell klass;
+ /* tagged fixnum */
+ cell size;
+ /* tagged fixnum */
+ cell echelon;
+};
+
+struct bignum : public object {
+ static const cell type_number = BIGNUM_TYPE;
+ static const cell element_size = sizeof(cell);
+ /* tagged */
+ cell capacity;
+
+ cell *data() { return (cell *)(this + 1); }
+};
+
+struct byte_array : public object {
+ static const cell type_number = BYTE_ARRAY_TYPE;
+ static const cell element_size = 1;
+ /* tagged */
+ cell capacity;
+
+ template<typename T> T *data() { return (T *)(this + 1); }
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct string : public object {
+ static const cell type_number = STRING_TYPE;
+ /* tagged num of chars */
+ cell length;
+ /* tagged */
+ cell aux;
+ /* tagged */
+ cell hashcode;
+
+ u8 *data() { return (u8 *)(this + 1); }
+};
+
+/* The compiled code heap is structured into blocks. */
+enum block_status
+{
+ B_FREE,
+ B_ALLOCATED,
+ B_MARKED
+};
+
+struct heap_block
+{
+ unsigned char status; /* free or allocated? */
+ unsigned char type; /* this is WORD_TYPE or QUOTATION_TYPE */
+ unsigned char last_scan; /* the youngest generation in which this block's literals may live */
+ char needs_fixup; /* is this a new block that needs full fixup? */
+
+ /* In bytes, includes this header */
+ cell size;
+
+ /* Used during compaction */
+ heap_block *forwarding;
+};
+
+struct free_heap_block
+{
+ heap_block block;
+
+ /* Filled in on image load */
+ free_heap_block *next_free;
+};
+
+struct code_block
+{
+ heap_block block;
+ cell literals; /* # bytes */
+ cell relocation; /* tagged pointer to byte-array or f */
+
+ void *xt() { return (void *)(this + 1); }
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct word : public object {
+ static const cell type_number = WORD_TYPE;
+ /* TAGGED hashcode */
+ cell hashcode;
+ /* TAGGED word name */
+ cell name;
+ /* TAGGED word vocabulary */
+ cell vocabulary;
+ /* TAGGED definition */
+ cell def;
+ /* TAGGED property assoc for library code */
+ cell props;
+ /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */
+ cell direct_entry_def;
+ /* TAGGED call count for profiling */
+ cell counter;
+ /* TAGGED machine code for sub-primitive */
+ cell subprimitive;
+ /* UNTAGGED execution token: jump here to execute word */
+ void *xt;
+ /* UNTAGGED compiled code block */
+ code_block *code;
+ /* UNTAGGED profiler stub */
+ code_block *profiling;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct wrapper : public object {
+ static const cell type_number = WRAPPER_TYPE;
+ cell object;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct boxed_float : object {
+ static const cell type_number = FLOAT_TYPE;
+
+#ifndef FACTOR_64
+ cell padding;
+#endif
+
+ double n;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct quotation : public object {
+ static const cell type_number = QUOTATION_TYPE;
+ /* tagged */
+ cell array;
+ /* tagged */
+ cell compiledp;
+ /* tagged */
+ cell cached_effect;
+ /* tagged */
+ cell cache_counter;
+ /* UNTAGGED */
+ void *xt;
+ /* UNTAGGED compiled code block */
+ code_block *code;
+};
+
+/* Assembly code makes assumptions about the layout of this struct */
+struct alien : public object {
+ static const cell type_number = ALIEN_TYPE;
+ /* tagged */
+ cell alien;
+ /* tagged */
+ cell expired;
+ /* untagged */
+ cell displacement;
+};
+
+struct dll : public object {
+ static const cell type_number = DLL_TYPE;
+ /* tagged byte array holding a C string */
+ cell path;
+ /* OS-specific handle */
+ void *dll;
+};
+
+struct callstack : public object {
+ static const cell type_number = CALLSTACK_TYPE;
+ /* tagged */
+ cell length;
+};
+
+struct stack_frame
+{
+ void *xt;
+ /* Frame size in bytes */
+ cell size;
+};
+
+struct tuple : public object {
+ static const cell type_number = TUPLE_TYPE;
+ /* tagged layout */
+ cell layout;
+
+ cell *data() { return (cell *)(this + 1); }
+};
+
+}
diff --git a/vm/local_roots.cpp b/vm/local_roots.cpp
new file mode 100644
index 0000000000..717beb32c7
--- /dev/null
+++ b/vm/local_roots.cpp
@@ -0,0 +1,12 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+segment *gc_locals_region;
+cell gc_locals;
+
+segment *gc_bignums_region;
+cell gc_bignums;
+
+}
diff --git a/vm/local_roots.h b/vm/local_roots.h
deleted file mode 100644
index e852f9e54d..0000000000
--- a/vm/local_roots.h
+++ /dev/null
@@ -1,63 +0,0 @@
-/* If a runtime function needs to call another function which potentially
-allocates memory, it must store any local variable references to Factor
-objects on the root stack */
-
-/* GC locals: stores addresses of pointers to objects. The GC updates these
-pointers, so you can do
-
-REGISTER_ROOT(some_local);
-
-... allocate memory ...
-
-foo(some_local);
-
-...
-
-UNREGISTER_ROOT(some_local); */
-F_SEGMENT *gc_locals_region;
-CELL gc_locals;
-
-DEFPUSHPOP(gc_local_,gc_locals)
-
-#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
-#define UNREGISTER_ROOT(obj) \
- { \
- if(gc_local_pop() != (CELL)&obj) \
- critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
- }
-
-/* Extra roots: stores pointers to objects in the heap. Requires extra work
-(you have to unregister before accessing the object) but more flexible. */
-F_SEGMENT *extra_roots_region;
-CELL extra_roots;
-
-DEFPUSHPOP(root_,extra_roots)
-
-#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
-#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
-
-/* We ignore strings which point outside the data heap, but we might be given
-a char* which points inside the data heap, in which case it is a root, for
-example if we call unbox_char_string() the result is placed in a byte array */
-INLINE bool root_push_alien(const void *ptr)
-{
- if(in_data_heap_p((CELL)ptr))
- {
- F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
- if(objptr->header == tag_header(BYTE_ARRAY_TYPE))
- {
- root_push(tag_object(objptr));
- return true;
- }
- }
-
- return false;
-}
-
-#define REGISTER_C_STRING(obj) \
- bool obj##_root = root_push_alien(obj)
-#define UNREGISTER_C_STRING(obj) \
- if(obj##_root) obj = alien_offset(root_pop())
-
-#define REGISTER_BIGNUM(obj) if(obj) root_push(tag_bignum(obj))
-#define UNREGISTER_BIGNUM(obj) if(obj) obj = (untag_object(root_pop()))
diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp
new file mode 100644
index 0000000000..e074d999e7
--- /dev/null
+++ b/vm/local_roots.hpp
@@ -0,0 +1,54 @@
+namespace factor
+{
+
+/* If a runtime function needs to call another function which potentially
+allocates memory, it must wrap any local variable references to Factor
+objects in gc_root instances */
+extern segment *gc_locals_region;
+extern cell gc_locals;
+
+DEFPUSHPOP(gc_local_,gc_locals)
+
+template <typename T>
+struct gc_root : public tagged<T>
+{
+ void push() { gc_local_push((cell)this); }
+
+ explicit gc_root(cell value_) : tagged<T>(value_) { push(); }
+ explicit gc_root(T *value_) : tagged<T>(value_) { push(); }
+
+ const gc_root<T>& operator=(const T *x) { tagged<T>::operator=(x); return *this; }
+ const gc_root<T>& operator=(const cell &x) { tagged<T>::operator=(x); return *this; }
+
+ ~gc_root() {
+#ifdef FACTOR_DEBUG
+ cell old = gc_local_pop();
+ assert(old == (cell)this);
+#else
+ gc_local_pop();
+#endif
+ }
+};
+
+/* A similar hack for the bignum implementation */
+extern segment *gc_bignums_region;
+extern cell gc_bignums;
+
+DEFPUSHPOP(gc_bignum_,gc_bignums)
+
+struct gc_bignum
+{
+ bignum **addr;
+
+ gc_bignum(bignum **addr_) : addr(addr_) {
+ if(*addr_)
+ check_data_pointer(*addr_);
+ gc_bignum_push((cell)addr);
+ }
+
+ ~gc_bignum() { assert((cell)addr == gc_bignum_pop()); }
+};
+
+#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x)
+
+}
diff --git a/vm/mach_signal.c b/vm/mach_signal.cpp
similarity index 92%
rename from vm/mach_signal.c
rename to vm/mach_signal.cpp
index 57fb91d662..f752c3cb8f 100644
--- a/vm/mach_signal.c
+++ b/vm/mach_signal.cpp
@@ -1,5 +1,6 @@
/* Fault handler information. MacOSX version.
Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
+
Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
@@ -9,7 +10,13 @@ http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno
Modified for Factor by Slava Pestov */
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
+
+/* The exception port on which our thread listens. */
+mach_port_t our_exception_port;
/* The following sources were used as a *reference* for this exception handling
code:
@@ -32,7 +39,7 @@ static void call_fault_handler(exception_type_t exception,
/* Are we in compiled Factor code? Then use the current stack pointer */
if(in_code_heap_p(MACH_PROGRAM_COUNTER(thread_state)))
- signal_callstack_top = (void *)MACH_STACK_POINTER(thread_state);
+ signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state);
/* Are we in C? Then use the saved callstack top */
else
signal_callstack_top = NULL;
@@ -43,7 +50,7 @@ static void call_fault_handler(exception_type_t exception,
if(exception == EXC_BAD_ACCESS)
{
signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
- MACH_PROGRAM_COUNTER(thread_state) = (CELL)memory_signal_handler_impl;
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
}
else
{
@@ -51,12 +58,13 @@ static void call_fault_handler(exception_type_t exception,
signal_number = SIGFPE;
else
signal_number = SIGABRT;
- MACH_PROGRAM_COUNTER(thread_state) = (CELL)misc_signal_handler_impl;
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
}
}
/* Handle an exception by invoking the user's fault handler and/or forwarding
the duty to the previously installed handlers. */
+extern "C"
kern_return_t
catch_exception_raise (mach_port_t exception_port,
mach_port_t thread,
@@ -74,7 +82,7 @@ catch_exception_raise (mach_port_t exception_port,
See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */
state_count = MACH_EXC_STATE_COUNT;
if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR,
- (void *) &exc_state, &state_count)
+ (natural_t *)&exc_state, &state_count)
!= KERN_SUCCESS)
{
/* The thread is supposed to be suspended while the exception
@@ -84,7 +92,7 @@ catch_exception_raise (mach_port_t exception_port,
state_count = MACH_THREAD_STATE_COUNT;
if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
- (void *) &thread_state, &state_count)
+ (natural_t *)&thread_state, &state_count)
!= KERN_SUCCESS)
{
/* The thread is supposed to be suspended while the exception
@@ -100,7 +108,7 @@ catch_exception_raise (mach_port_t exception_port,
See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */
if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR,
- (void *) &thread_state, state_count)
+ (natural_t *)&thread_state, state_count)
!= KERN_SUCCESS)
{
return KERN_FAILURE;
@@ -160,7 +168,6 @@ mach_exception_thread (void *arg)
}
}
-
/* Initialize the Mach exception handler thread. */
void mach_initialize (void)
{
@@ -197,3 +204,5 @@ void mach_initialize (void)
!= KERN_SUCCESS)
fatal_error("task_set_exception_ports() failed",0);
}
+
+}
diff --git a/vm/mach_signal.h b/vm/mach_signal.hpp
similarity index 94%
rename from vm/mach_signal.h
rename to vm/mach_signal.hpp
index 863fd86dae..5dd344c080 100644
--- a/vm/mach_signal.h
+++ b/vm/mach_signal.hpp
@@ -20,9 +20,6 @@ Modified for Factor by Slava Pestov */
#include <mach/task.h>
#include <pthread.h>
-/* The exception port on which our thread listens. */
-mach_port_t our_exception_port;
-
/* This is not defined in any header, although documented. */
/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/exc_server.html says:
@@ -39,14 +36,13 @@ mach_port_t our_exception_port;
allowing the thread to continue from the point of the exception; otherwise,
no reply message is sent and the called routine must have dealt with the
exception thread directly. */
-extern boolean_t
- exc_server (mach_msg_header_t *request_msg,
- mach_msg_header_t *reply_msg);
+extern "C" boolean_t exc_server (mach_msg_header_t *request_msg, mach_msg_header_t *reply_msg);
/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/catch_exception_raise.html
These functions are defined in this file, and called by exc_server.
FIXME: What needs to be done when this code is put into a shared library? */
+extern "C"
kern_return_t
catch_exception_raise (mach_port_t exception_port,
mach_port_t thread,
@@ -54,6 +50,7 @@ catch_exception_raise (mach_port_t exception_port,
exception_type_t exception,
exception_data_t code,
mach_msg_type_number_t code_count);
+extern "C"
kern_return_t
catch_exception_raise_state (mach_port_t exception_port,
exception_type_t exception,
@@ -64,6 +61,8 @@ catch_exception_raise_state (mach_port_t exception_port,
mach_msg_type_number_t in_state_count,
thread_state_t out_state,
mach_msg_type_number_t *out_state_count);
+
+extern "C"
kern_return_t
catch_exception_raise_state_identity (mach_port_t exception_port,
mach_port_t thread,
@@ -77,4 +76,9 @@ catch_exception_raise_state_identity (mach_port_t exception_port,
thread_state_t out_state,
mach_msg_type_number_t *out_state_count);
+namespace factor
+{
+
void mach_initialize (void);
+
+}
diff --git a/vm/main-unix.c b/vm/main-unix.c
deleted file mode 100644
index b177c58eb3..0000000000
--- a/vm/main-unix.c
+++ /dev/null
@@ -1,7 +0,0 @@
-#include "master.h"
-
-int main(int argc, char **argv)
-{
- start_standalone_factor(argc,argv);
- return 0;
-}
diff --git a/vm/main-unix.cpp b/vm/main-unix.cpp
new file mode 100644
index 0000000000..bc605e3cfd
--- /dev/null
+++ b/vm/main-unix.cpp
@@ -0,0 +1,7 @@
+#include "master.hpp"
+
+int main(int argc, char **argv)
+{
+ factor::start_standalone_factor(argc,argv);
+ return 0;
+}
diff --git a/vm/main-windows-ce.c b/vm/main-windows-ce.cpp
similarity index 97%
rename from vm/main-windows-ce.c
rename to vm/main-windows-ce.cpp
index fc04d455db..526f3b2c36 100644
--- a/vm/main-windows-ce.c
+++ b/vm/main-windows-ce.cpp
@@ -1,4 +1,4 @@
-#include "master.h"
+#include "master.hpp"
/*
Windows CE argument parsing ported to work on
@@ -128,7 +128,7 @@ WinMain(
int nCmdShow)
{
parse_args(&__argc, &__argv, lpCmdLine);
- start_standalone_factor(__argc,(LPWSTR*)__argv);
+ factor::start_standalone_factor(__argc,(LPWSTR*)__argv);
// memory leak from malloc, wcsdup
return 0;
}
diff --git a/vm/main-windows-nt.c b/vm/main-windows-nt.cpp
similarity index 71%
rename from vm/main-windows-nt.c
rename to vm/main-windows-nt.cpp
index 6552e88bed..eaaad0f55b 100755
--- a/vm/main-windows-nt.c
+++ b/vm/main-windows-nt.cpp
@@ -1,7 +1,4 @@
-#include <windows.h>
-#include <stdio.h>
-#include <shellapi.h>
-#include "master.h"
+#include "master.hpp"
int WINAPI WinMain(
HINSTANCE hInstance,
@@ -19,7 +16,7 @@ int WINAPI WinMain(
return 1;
}
- start_standalone_factor(nArgs,szArglist);
+ factor::start_standalone_factor(nArgs,szArglist);
LocalFree(szArglist);
diff --git a/vm/master.h b/vm/master.h
deleted file mode 100644
index 86b5223eaa..0000000000
--- a/vm/master.h
+++ /dev/null
@@ -1,47 +0,0 @@
-#ifndef __FACTOR_MASTER_H__
-#define __FACTOR_MASTER_H__
-
-#ifndef WINCE
- #include <errno.h>
-#endif
-
-#include <fcntl.h>
-#include <limits.h>
-#include <math.h>
-#include <stdbool.h>
-#include <setjmp.h>
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <time.h>
-#include <sys/param.h>
-
-#include "layouts.h"
-#include "platform.h"
-#include "primitives.h"
-#include "run.h"
-#include "profiler.h"
-#include "errors.h"
-#include "bignumint.h"
-#include "bignum.h"
-#include "write_barrier.h"
-#include "data_heap.h"
-#include "local_roots.h"
-#include "data_gc.h"
-#include "debug.h"
-#include "types.h"
-#include "math.h"
-#include "float_bits.h"
-#include "io.h"
-#include "code_gc.h"
-#include "code_block.h"
-#include "code_heap.h"
-#include "image.h"
-#include "callstack.h"
-#include "alien.h"
-#include "quotations.h"
-#include "factor.h"
-#include "utilities.h"
-
-#endif /* __FACTOR_MASTER_H__ */
diff --git a/vm/master.hpp b/vm/master.hpp
new file mode 100644
index 0000000000..fa7d7fa1a4
--- /dev/null
+++ b/vm/master.hpp
@@ -0,0 +1,63 @@
+#ifndef __FACTOR_MASTER_H__
+#define __FACTOR_MASTER_H__
+
+#ifndef WINCE
+#include <errno.h>
+#endif
+
+#ifdef FACTOR_DEBUG
+#include <assert.h>
+#endif
+
+#include <fcntl.h>
+#include <limits.h>
+#include <math.h>
+#include <stdbool.h>
+#include <setjmp.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <time.h>
+#include <sys/param.h>
+
+#include "layouts.hpp"
+#include "platform.hpp"
+#include "primitives.hpp"
+#include "stacks.hpp"
+#include "segments.hpp"
+#include "contexts.hpp"
+#include "run.hpp"
+#include "tagged.hpp"
+#include "profiler.hpp"
+#include "errors.hpp"
+#include "bignumint.hpp"
+#include "bignum.hpp"
+#include "data_heap.hpp"
+#include "write_barrier.hpp"
+#include "data_gc.hpp"
+#include "local_roots.hpp"
+#include "generic_arrays.hpp"
+#include "debug.hpp"
+#include "arrays.hpp"
+#include "strings.hpp"
+#include "booleans.hpp"
+#include "byte_arrays.hpp"
+#include "tuples.hpp"
+#include "words.hpp"
+#include "math.hpp"
+#include "float_bits.hpp"
+#include "io.hpp"
+#include "code_gc.hpp"
+#include "code_block.hpp"
+#include "code_heap.hpp"
+#include "image.hpp"
+#include "callstack.hpp"
+#include "alien.hpp"
+#include "jit.hpp"
+#include "quotations.hpp"
+#include "dispatch.hpp"
+#include "inline_cache.hpp"
+#include "factor.hpp"
+#include "utilities.hpp"
+
+#endif /* __FACTOR_MASTER_H__ */
diff --git a/vm/math.c b/vm/math.c
deleted file mode 100644
index 7bff0de387..0000000000
--- a/vm/math.c
+++ /dev/null
@@ -1,537 +0,0 @@
-#include "master.h"
-
-/* Fixnums */
-F_FIXNUM to_fixnum(CELL tagged)
-{
- switch(TAG(tagged))
- {
- case FIXNUM_TYPE:
- return untag_fixnum_fast(tagged);
- case BIGNUM_TYPE:
- return bignum_to_fixnum(untag_object(tagged));
- default:
- type_error(FIXNUM_TYPE,tagged);
- return -1; /* can't happen */
- }
-}
-
-CELL to_cell(CELL tagged)
-{
- return (CELL)to_fixnum(tagged);
-}
-
-void primitive_bignum_to_fixnum(void)
-{
- drepl(tag_fixnum(bignum_to_fixnum(untag_object(dpeek()))));
-}
-
-void primitive_float_to_fixnum(void)
-{
- drepl(tag_fixnum(float_to_fixnum(dpeek())));
-}
-
-/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
-overflow, they call these functions. */
-F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y)
-{
- drepl(tag_bignum(fixnum_to_bignum(
- untag_fixnum_fast(x) + untag_fixnum_fast(y))));
-}
-
-F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y)
-{
- drepl(tag_bignum(fixnum_to_bignum(
- untag_fixnum_fast(x) - untag_fixnum_fast(y))));
-}
-
-F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y)
-{
- F_ARRAY *bx = fixnum_to_bignum(x);
- REGISTER_BIGNUM(bx);
- F_ARRAY *by = fixnum_to_bignum(y);
- UNREGISTER_BIGNUM(bx);
- drepl(tag_bignum(bignum_multiply(bx,by)));
-}
-
-/* Division can only overflow when we are dividing the most negative fixnum
-by -1. */
-void primitive_fixnum_divint(void)
-{
- F_FIXNUM y = untag_fixnum_fast(dpop()); \
- F_FIXNUM x = untag_fixnum_fast(dpeek());
- F_FIXNUM result = x / y;
- if(result == -FIXNUM_MIN)
- drepl(allot_integer(-FIXNUM_MIN));
- else
- drepl(tag_fixnum(result));
-}
-
-void primitive_fixnum_divmod(void)
-{
- F_FIXNUM y = get(ds);
- F_FIXNUM x = get(ds - CELLS);
- if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
- {
- put(ds - CELLS,allot_integer(-FIXNUM_MIN));
- put(ds,tag_fixnum(0));
- }
- else
- {
- put(ds - CELLS,tag_fixnum(x / y));
- put(ds,x % y);
- }
-}
-
-/*
- * If we're shifting right by n bits, we won't overflow as long as none of the
- * high WORD_SIZE-TAG_BITS-n bits are set.
- */
-#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
-#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
-#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
-
-void primitive_fixnum_shift(void)
-{
- F_FIXNUM y = untag_fixnum_fast(dpop()); \
- F_FIXNUM x = untag_fixnum_fast(dpeek());
-
- if(x == 0)
- return;
- else if(y < 0)
- {
- y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
- drepl(tag_fixnum(x >> -y));
- return;
- }
- else if(y < WORD_SIZE - TAG_BITS)
- {
- F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
- if(!(BRANCHLESS_ABS(x) & mask))
- {
- drepl(tag_fixnum(x << y));
- return;
- }
- }
-
- drepl(tag_bignum(bignum_arithmetic_shift(
- fixnum_to_bignum(x),y)));
-}
-
-/* Bignums */
-void primitive_fixnum_to_bignum(void)
-{
- drepl(tag_bignum(fixnum_to_bignum(untag_fixnum_fast(dpeek()))));
-}
-
-void primitive_float_to_bignum(void)
-{
- drepl(tag_bignum(float_to_bignum(dpeek())));
-}
-
-#define POP_BIGNUMS(x,y) \
- F_ARRAY *y = untag_object(dpop()); \
- F_ARRAY *x = untag_object(dpop());
-
-void primitive_bignum_eq(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_equal_p(x,y));
-}
-
-void primitive_bignum_add(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_add(x,y)));
-}
-
-void primitive_bignum_subtract(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_subtract(x,y)));
-}
-
-void primitive_bignum_multiply(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_multiply(x,y)));
-}
-
-void primitive_bignum_divint(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_quotient(x,y)));
-}
-
-void primitive_bignum_divmod(void)
-{
- F_ARRAY *q, *r;
- POP_BIGNUMS(x,y);
- bignum_divide(x,y,&q,&r);
- dpush(tag_bignum(q));
- dpush(tag_bignum(r));
-}
-
-void primitive_bignum_mod(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_remainder(x,y)));
-}
-
-void primitive_bignum_and(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_bitwise_and(x,y)));
-}
-
-void primitive_bignum_or(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_bitwise_ior(x,y)));
-}
-
-void primitive_bignum_xor(void)
-{
- POP_BIGNUMS(x,y);
- dpush(tag_bignum(bignum_bitwise_xor(x,y)));
-}
-
-void primitive_bignum_shift(void)
-{
- F_FIXNUM y = untag_fixnum_fast(dpop());
- F_ARRAY* x = untag_object(dpop());
- dpush(tag_bignum(bignum_arithmetic_shift(x,y)));
-}
-
-void primitive_bignum_less(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_compare(x,y) == bignum_comparison_less);
-}
-
-void primitive_bignum_lesseq(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
-}
-
-void primitive_bignum_greater(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
-}
-
-void primitive_bignum_greatereq(void)
-{
- POP_BIGNUMS(x,y);
- box_boolean(bignum_compare(x,y) != bignum_comparison_less);
-}
-
-void primitive_bignum_not(void)
-{
- drepl(tag_bignum(bignum_bitwise_not(untag_object(dpeek()))));
-}
-
-void primitive_bignum_bitp(void)
-{
- F_FIXNUM bit = to_fixnum(dpop());
- F_ARRAY *x = untag_object(dpop());
- box_boolean(bignum_logbitp(bit,x));
-}
-
-void primitive_bignum_log2(void)
-{
- drepl(tag_bignum(bignum_integer_length(untag_object(dpeek()))));
-}
-
-unsigned int bignum_producer(unsigned int digit)
-{
- unsigned char *ptr = alien_offset(dpeek());
- return *(ptr + digit);
-}
-
-void primitive_byte_array_to_bignum(void)
-{
- type_check(BYTE_ARRAY_TYPE,dpeek());
- CELL n_digits = array_capacity(untag_object(dpeek()));
- bignum_type bignum = digit_stream_to_bignum(
- n_digits,bignum_producer,0x100,0);
- drepl(tag_bignum(bignum));
-}
-
-void box_signed_1(s8 n)
-{
- dpush(tag_fixnum(n));
-}
-
-void box_unsigned_1(u8 n)
-{
- dpush(tag_fixnum(n));
-}
-
-void box_signed_2(s16 n)
-{
- dpush(tag_fixnum(n));
-}
-
-void box_unsigned_2(u16 n)
-{
- dpush(tag_fixnum(n));
-}
-
-void box_signed_4(s32 n)
-{
- dpush(allot_integer(n));
-}
-
-void box_unsigned_4(u32 n)
-{
- dpush(allot_cell(n));
-}
-
-void box_signed_cell(F_FIXNUM integer)
-{
- dpush(allot_integer(integer));
-}
-
-void box_unsigned_cell(CELL cell)
-{
- dpush(allot_cell(cell));
-}
-
-void box_signed_8(s64 n)
-{
- if(n < FIXNUM_MIN || n > FIXNUM_MAX)
- dpush(tag_bignum(long_long_to_bignum(n)));
- else
- dpush(tag_fixnum(n));
-}
-
-s64 to_signed_8(CELL obj)
-{
- switch(type_of(obj))
- {
- case FIXNUM_TYPE:
- return untag_fixnum_fast(obj);
- case BIGNUM_TYPE:
- return bignum_to_long_long(untag_object(obj));
- default:
- type_error(BIGNUM_TYPE,obj);
- return -1;
- }
-}
-
-void box_unsigned_8(u64 n)
-{
- if(n > FIXNUM_MAX)
- dpush(tag_bignum(ulong_long_to_bignum(n)));
- else
- dpush(tag_fixnum(n));
-}
-
-u64 to_unsigned_8(CELL obj)
-{
- switch(type_of(obj))
- {
- case FIXNUM_TYPE:
- return untag_fixnum_fast(obj);
- case BIGNUM_TYPE:
- return bignum_to_ulong_long(untag_object(obj));
- default:
- type_error(BIGNUM_TYPE,obj);
- return -1;
- }
-}
-
-CELL unbox_array_size(void)
-{
- switch(type_of(dpeek()))
- {
- case FIXNUM_TYPE:
- {
- F_FIXNUM n = untag_fixnum_fast(dpeek());
- if(n >= 0 && n < ARRAY_SIZE_MAX)
- {
- dpop();
- return n;
- }
- break;
- }
- case BIGNUM_TYPE:
- {
- bignum_type zero = untag_object(bignum_zero);
- bignum_type max = cell_to_bignum(ARRAY_SIZE_MAX);
- bignum_type n = untag_object(dpeek());
- if(bignum_compare(n,zero) != bignum_comparison_less
- && bignum_compare(n,max) == bignum_comparison_less)
- {
- dpop();
- return bignum_to_cell(n);
- }
- break;
- }
- }
-
- general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
- return 0; /* can't happen */
-}
-
-/* Ratios */
-
-/* Does not reduce to lowest terms, so should only be used by math
-library implementation, to avoid breaking invariants. */
-void primitive_from_fraction(void)
-{
- F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO));
- ratio->denominator = dpop();
- ratio->numerator = dpop();
- dpush(RETAG(ratio,RATIO_TYPE));
-}
-
-/* Floats */
-void primitive_fixnum_to_float(void)
-{
- drepl(allot_float(fixnum_to_float(dpeek())));
-}
-
-void primitive_bignum_to_float(void)
-{
- drepl(allot_float(bignum_to_float(dpeek())));
-}
-
-void primitive_str_to_float(void)
-{
- char *c_str, *end;
- double f;
- F_STRING *str = untag_string(dpeek());
- CELL capacity = string_capacity(str);
-
- c_str = to_char_string(str,false);
- end = c_str;
- f = strtod(c_str,&end);
- if(end != c_str + capacity)
- drepl(F);
- else
- drepl(allot_float(f));
-}
-
-void primitive_float_to_str(void)
-{
- char tmp[33];
- snprintf(tmp,32,"%.16g",untag_float(dpop()));
- tmp[32] = '\0';
- box_char_string(tmp);
-}
-
-#define POP_FLOATS(x,y) \
- double y = untag_float_fast(dpop()); \
- double x = untag_float_fast(dpop());
-
-void primitive_float_eq(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x == y);
-}
-
-void primitive_float_add(void)
-{
- POP_FLOATS(x,y);
- box_double(x + y);
-}
-
-void primitive_float_subtract(void)
-{
- POP_FLOATS(x,y);
- box_double(x - y);
-}
-
-void primitive_float_multiply(void)
-{
- POP_FLOATS(x,y);
- box_double(x * y);
-}
-
-void primitive_float_divfloat(void)
-{
- POP_FLOATS(x,y);
- box_double(x / y);
-}
-
-void primitive_float_mod(void)
-{
- POP_FLOATS(x,y);
- box_double(fmod(x,y));
-}
-
-void primitive_float_less(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x < y);
-}
-
-void primitive_float_lesseq(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x <= y);
-}
-
-void primitive_float_greater(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x > y);
-}
-
-void primitive_float_greatereq(void)
-{
- POP_FLOATS(x,y);
- box_boolean(x >= y);
-}
-
-void primitive_float_bits(void)
-{
- box_unsigned_4(float_bits(untag_float(dpop())));
-}
-
-void primitive_bits_float(void)
-{
- box_float(bits_float(to_cell(dpop())));
-}
-
-void primitive_double_bits(void)
-{
- box_unsigned_8(double_bits(untag_float(dpop())));
-}
-
-void primitive_bits_double(void)
-{
- box_double(bits_double(to_unsigned_8(dpop())));
-}
-
-float to_float(CELL value)
-{
- return untag_float(value);
-}
-
-double to_double(CELL value)
-{
- return untag_float(value);
-}
-
-void box_float(float flo)
-{
- dpush(allot_float(flo));
-}
-
-void box_double(double flo)
-{
- dpush(allot_float(flo));
-}
-
-/* Complex numbers */
-
-void primitive_from_rect(void)
-{
- F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX));
- z->imaginary = dpop();
- z->real = dpop();
- dpush(RETAG(z,COMPLEX_TYPE));
-}
diff --git a/vm/math.cpp b/vm/math.cpp
new file mode 100644
index 0000000000..57d5e4a517
--- /dev/null
+++ b/vm/math.cpp
@@ -0,0 +1,516 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+cell bignum_zero;
+cell bignum_pos_one;
+cell bignum_neg_one;
+
+PRIMITIVE(bignum_to_fixnum)
+{
+ drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
+}
+
+PRIMITIVE(float_to_fixnum)
+{
+ drepl(tag_fixnum(float_to_fixnum(dpeek())));
+}
+
+/* Division can only overflow when we are dividing the most negative fixnum
+by -1. */
+PRIMITIVE(fixnum_divint)
+{
+ fixnum y = untag_fixnum(dpop()); \
+ fixnum x = untag_fixnum(dpeek());
+ fixnum result = x / y;
+ if(result == -FIXNUM_MIN)
+ drepl(allot_integer(-FIXNUM_MIN));
+ else
+ drepl(tag_fixnum(result));
+}
+
+PRIMITIVE(fixnum_divmod)
+{
+ cell y = ((cell *)ds)[0];
+ cell x = ((cell *)ds)[-1];
+ if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
+ {
+ ((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN);
+ ((cell *)ds)[0] = tag_fixnum(0);
+ }
+ else
+ {
+ ((cell *)ds)[-1] = tag_fixnum(untag_fixnum(x) / untag_fixnum(y));
+ ((cell *)ds)[0] = (fixnum)x % (fixnum)y;
+ }
+}
+
+/*
+ * If we're shifting right by n bits, we won't overflow as long as none of the
+ * high WORD_SIZE-TAG_BITS-n bits are set.
+ */
+#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
+#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
+#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
+
+PRIMITIVE(fixnum_shift)
+{
+ fixnum y = untag_fixnum(dpop()); \
+ fixnum x = untag_fixnum(dpeek());
+
+ if(x == 0)
+ return;
+ else if(y < 0)
+ {
+ y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
+ drepl(tag_fixnum(x >> -y));
+ return;
+ }
+ else if(y < WORD_SIZE - TAG_BITS)
+ {
+ fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y));
+ if(!(BRANCHLESS_ABS(x) & mask))
+ {
+ drepl(tag_fixnum(x << y));
+ return;
+ }
+ }
+
+ drepl(tag<bignum>(bignum_arithmetic_shift(
+ fixnum_to_bignum(x),y)));
+}
+
+PRIMITIVE(fixnum_to_bignum)
+{
+ drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek()))));
+}
+
+PRIMITIVE(float_to_bignum)
+{
+ drepl(tag<bignum>(float_to_bignum(dpeek())));
+}
+
+#define POP_BIGNUMS(x,y) \
+ bignum * y = untag<bignum>(dpop()); \
+ bignum * x = untag<bignum>(dpop());
+
+PRIMITIVE(bignum_eq)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_equal_p(x,y));
+}
+
+PRIMITIVE(bignum_add)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_add(x,y)));
+}
+
+PRIMITIVE(bignum_subtract)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_subtract(x,y)));
+}
+
+PRIMITIVE(bignum_multiply)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_multiply(x,y)));
+}
+
+PRIMITIVE(bignum_divint)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_quotient(x,y)));
+}
+
+PRIMITIVE(bignum_divmod)
+{
+ bignum *q, *r;
+ POP_BIGNUMS(x,y);
+ bignum_divide(x,y,&q,&r);
+ dpush(tag<bignum>(q));
+ dpush(tag<bignum>(r));
+}
+
+PRIMITIVE(bignum_mod)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_remainder(x,y)));
+}
+
+PRIMITIVE(bignum_and)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_bitwise_and(x,y)));
+}
+
+PRIMITIVE(bignum_or)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_bitwise_ior(x,y)));
+}
+
+PRIMITIVE(bignum_xor)
+{
+ POP_BIGNUMS(x,y);
+ dpush(tag<bignum>(bignum_bitwise_xor(x,y)));
+}
+
+PRIMITIVE(bignum_shift)
+{
+ fixnum y = untag_fixnum(dpop());
+ bignum* x = untag<bignum>(dpop());
+ dpush(tag<bignum>(bignum_arithmetic_shift(x,y)));
+}
+
+PRIMITIVE(bignum_less)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) == bignum_comparison_less);
+}
+
+PRIMITIVE(bignum_lesseq)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
+}
+
+PRIMITIVE(bignum_greater)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
+}
+
+PRIMITIVE(bignum_greatereq)
+{
+ POP_BIGNUMS(x,y);
+ box_boolean(bignum_compare(x,y) != bignum_comparison_less);
+}
+
+PRIMITIVE(bignum_not)
+{
+ drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek()))));
+}
+
+PRIMITIVE(bignum_bitp)
+{
+ fixnum bit = to_fixnum(dpop());
+ bignum *x = untag<bignum>(dpop());
+ box_boolean(bignum_logbitp(bit,x));
+}
+
+PRIMITIVE(bignum_log2)
+{
+ drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek()))));
+}
+
+unsigned int bignum_producer(unsigned int digit)
+{
+ unsigned char *ptr = (unsigned char *)alien_offset(dpeek());
+ return *(ptr + digit);
+}
+
+PRIMITIVE(byte_array_to_bignum)
+{
+ cell n_digits = array_capacity(untag_check<byte_array>(dpeek()));
+ bignum * result = digit_stream_to_bignum(n_digits,bignum_producer,0x100,0);
+ drepl(tag<bignum>(result));
+}
+
+cell unbox_array_size(void)
+{
+ switch(tagged<object>(dpeek()).type())
+ {
+ case FIXNUM_TYPE:
+ {
+ fixnum n = untag_fixnum(dpeek());
+ if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX)
+ {
+ dpop();
+ return n;
+ }
+ break;
+ }
+ case BIGNUM_TYPE:
+ {
+ bignum * zero = untag<bignum>(bignum_zero);
+ bignum * max = cell_to_bignum(ARRAY_SIZE_MAX);
+ bignum * n = untag<bignum>(dpeek());
+ if(bignum_compare(n,zero) != bignum_comparison_less
+ && bignum_compare(n,max) == bignum_comparison_less)
+ {
+ dpop();
+ return bignum_to_cell(n);
+ }
+ break;
+ }
+ }
+
+ general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
+ return 0; /* can't happen */
+}
+
+PRIMITIVE(fixnum_to_float)
+{
+ drepl(allot_float(fixnum_to_float(dpeek())));
+}
+
+PRIMITIVE(bignum_to_float)
+{
+ drepl(allot_float(bignum_to_float(dpeek())));
+}
+
+PRIMITIVE(str_to_float)
+{
+ byte_array *bytes = untag_check<byte_array>(dpeek());
+ cell capacity = array_capacity(bytes);
+
+ char *c_str = (char *)(bytes + 1);
+ char *end = c_str;
+ double f = strtod(c_str,&end);
+ if(end == c_str + capacity - 1)
+ drepl(allot_float(f));
+ else
+ drepl(F);
+}
+
+PRIMITIVE(float_to_str)
+{
+ byte_array *array = allot_byte_array(33);
+ snprintf((char *)(array + 1),32,"%.16g",untag_float_check(dpop()));
+ dpush(tag<byte_array>(array));
+}
+
+#define POP_FLOATS(x,y) \
+ double y = untag_float(dpop()); \
+ double x = untag_float(dpop());
+
+PRIMITIVE(float_eq)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x == y);
+}
+
+PRIMITIVE(float_add)
+{
+ POP_FLOATS(x,y);
+ box_double(x + y);
+}
+
+PRIMITIVE(float_subtract)
+{
+ POP_FLOATS(x,y);
+ box_double(x - y);
+}
+
+PRIMITIVE(float_multiply)
+{
+ POP_FLOATS(x,y);
+ box_double(x * y);
+}
+
+PRIMITIVE(float_divfloat)
+{
+ POP_FLOATS(x,y);
+ box_double(x / y);
+}
+
+PRIMITIVE(float_mod)
+{
+ POP_FLOATS(x,y);
+ box_double(fmod(x,y));
+}
+
+PRIMITIVE(float_less)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x < y);
+}
+
+PRIMITIVE(float_lesseq)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x <= y);
+}
+
+PRIMITIVE(float_greater)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x > y);
+}
+
+PRIMITIVE(float_greatereq)
+{
+ POP_FLOATS(x,y);
+ box_boolean(x >= y);
+}
+
+PRIMITIVE(float_bits)
+{
+ box_unsigned_4(float_bits(untag_float_check(dpop())));
+}
+
+PRIMITIVE(bits_float)
+{
+ box_float(bits_float(to_cell(dpop())));
+}
+
+PRIMITIVE(double_bits)
+{
+ box_unsigned_8(double_bits(untag_float_check(dpop())));
+}
+
+PRIMITIVE(bits_double)
+{
+ box_double(bits_double(to_unsigned_8(dpop())));
+}
+
+VM_C_API fixnum to_fixnum(cell tagged)
+{
+ switch(TAG(tagged))
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum(tagged);
+ case BIGNUM_TYPE:
+ return bignum_to_fixnum(untag<bignum>(tagged));
+ default:
+ type_error(FIXNUM_TYPE,tagged);
+ return -1; /* can't happen */
+ }
+}
+
+VM_C_API cell to_cell(cell tagged)
+{
+ return (cell)to_fixnum(tagged);
+}
+
+VM_C_API void box_signed_1(s8 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API void box_unsigned_1(u8 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API void box_signed_2(s16 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API void box_unsigned_2(u16 n)
+{
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API void box_signed_4(s32 n)
+{
+ dpush(allot_integer(n));
+}
+
+VM_C_API void box_unsigned_4(u32 n)
+{
+ dpush(allot_cell(n));
+}
+
+VM_C_API void box_signed_cell(fixnum integer)
+{
+ dpush(allot_integer(integer));
+}
+
+VM_C_API void box_unsigned_cell(cell cell)
+{
+ dpush(allot_cell(cell));
+}
+
+VM_C_API void box_signed_8(s64 n)
+{
+ if(n < FIXNUM_MIN || n > FIXNUM_MAX)
+ dpush(tag<bignum>(long_long_to_bignum(n)));
+ else
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API s64 to_signed_8(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum(obj);
+ case BIGNUM_TYPE:
+ return bignum_to_long_long(untag<bignum>(obj));
+ default:
+ type_error(BIGNUM_TYPE,obj);
+ return -1;
+ }
+}
+
+VM_C_API void box_unsigned_8(u64 n)
+{
+ if(n > FIXNUM_MAX)
+ dpush(tag<bignum>(ulong_long_to_bignum(n)));
+ else
+ dpush(tag_fixnum(n));
+}
+
+VM_C_API u64 to_unsigned_8(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case FIXNUM_TYPE:
+ return untag_fixnum(obj);
+ case BIGNUM_TYPE:
+ return bignum_to_ulong_long(untag<bignum>(obj));
+ default:
+ type_error(BIGNUM_TYPE,obj);
+ return -1;
+ }
+}
+
+VM_C_API void box_float(float flo)
+{
+ dpush(allot_float(flo));
+}
+
+VM_C_API float to_float(cell value)
+{
+ return untag_float_check(value);
+}
+
+VM_C_API void box_double(double flo)
+{
+ dpush(allot_float(flo));
+}
+
+VM_C_API double to_double(cell value)
+{
+ return untag_float_check(value);
+}
+
+/* The fixnum+, fixnum- and fixnum* primitives are defined in cpu_*.S. On
+overflow, they call these functions. */
+VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y)
+{
+ drepl(tag<bignum>(fixnum_to_bignum(
+ untag_fixnum(x) + untag_fixnum(y))));
+}
+
+VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y)
+{
+ drepl(tag<bignum>(fixnum_to_bignum(
+ untag_fixnum(x) - untag_fixnum(y))));
+}
+
+VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y)
+{
+ bignum *bx = fixnum_to_bignum(x);
+ GC_BIGNUM(bx);
+ bignum *by = fixnum_to_bignum(y);
+ GC_BIGNUM(by);
+ drepl(tag<bignum>(bignum_multiply(bx,by)));
+}
+
+}
diff --git a/vm/math.h b/vm/math.h
deleted file mode 100644
index f94f12b76d..0000000000
--- a/vm/math.h
+++ /dev/null
@@ -1,155 +0,0 @@
-#define CELL_MAX (CELL)(-1)
-#define FIXNUM_MAX (((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
-#define FIXNUM_MIN (-((F_FIXNUM)1 << (WORD_SIZE - TAG_BITS - 1)))
-#define ARRAY_SIZE_MAX ((CELL)1 << (WORD_SIZE - TAG_BITS - 2))
-
-DLLEXPORT F_FIXNUM to_fixnum(CELL tagged);
-DLLEXPORT CELL to_cell(CELL tagged);
-
-void primitive_bignum_to_fixnum(void);
-void primitive_float_to_fixnum(void);
-
-void primitive_fixnum_add(void);
-void primitive_fixnum_subtract(void);
-void primitive_fixnum_multiply(void);
-
-DLLEXPORT F_FASTCALL void overflow_fixnum_add(F_FIXNUM x, F_FIXNUM y);
-DLLEXPORT F_FASTCALL void overflow_fixnum_subtract(F_FIXNUM x, F_FIXNUM y);
-DLLEXPORT F_FASTCALL void overflow_fixnum_multiply(F_FIXNUM x, F_FIXNUM y);
-
-void primitive_fixnum_divint(void);
-void primitive_fixnum_divmod(void);
-void primitive_fixnum_shift(void);
-
-CELL bignum_zero;
-CELL bignum_pos_one;
-CELL bignum_neg_one;
-
-INLINE CELL tag_bignum(F_ARRAY* bignum)
-{
- return RETAG(bignum,BIGNUM_TYPE);
-}
-
-void primitive_fixnum_to_bignum(void);
-void primitive_float_to_bignum(void);
-void primitive_bignum_eq(void);
-void primitive_bignum_add(void);
-void primitive_bignum_subtract(void);
-void primitive_bignum_multiply(void);
-void primitive_bignum_divint(void);
-void primitive_bignum_divmod(void);
-void primitive_bignum_mod(void);
-void primitive_bignum_and(void);
-void primitive_bignum_or(void);
-void primitive_bignum_xor(void);
-void primitive_bignum_shift(void);
-void primitive_bignum_less(void);
-void primitive_bignum_lesseq(void);
-void primitive_bignum_greater(void);
-void primitive_bignum_greatereq(void);
-void primitive_bignum_not(void);
-void primitive_bignum_bitp(void);
-void primitive_bignum_log2(void);
-void primitive_byte_array_to_bignum(void);
-
-INLINE CELL allot_integer(F_FIXNUM x)
-{
- if(x < FIXNUM_MIN || x > FIXNUM_MAX)
- return tag_bignum(fixnum_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-INLINE CELL allot_cell(CELL x)
-{
- if(x > (CELL)FIXNUM_MAX)
- return tag_bignum(cell_to_bignum(x));
- else
- return tag_fixnum(x);
-}
-
-/* FFI calls this */
-DLLEXPORT void box_signed_1(s8 n);
-DLLEXPORT void box_unsigned_1(u8 n);
-DLLEXPORT void box_signed_2(s16 n);
-DLLEXPORT void box_unsigned_2(u16 n);
-DLLEXPORT void box_signed_4(s32 n);
-DLLEXPORT void box_unsigned_4(u32 n);
-DLLEXPORT void box_signed_cell(F_FIXNUM integer);
-DLLEXPORT void box_unsigned_cell(CELL cell);
-DLLEXPORT void box_signed_8(s64 n);
-DLLEXPORT s64 to_signed_8(CELL obj);
-
-DLLEXPORT void box_unsigned_8(u64 n);
-DLLEXPORT u64 to_unsigned_8(CELL obj);
-
-CELL unbox_array_size(void);
-
-void primitive_from_fraction(void);
-
-INLINE double untag_float_fast(CELL tagged)
-{
- return ((F_FLOAT*)UNTAG(tagged))->n;
-}
-
-INLINE double untag_float(CELL tagged)
-{
- type_check(FLOAT_TYPE,tagged);
- return untag_float_fast(tagged);
-}
-
-INLINE CELL allot_float(double n)
-{
- F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
- flo->n = n;
- return RETAG(flo,FLOAT_TYPE);
-}
-
-INLINE F_FIXNUM float_to_fixnum(CELL tagged)
-{
- return (F_FIXNUM)untag_float_fast(tagged);
-}
-
-INLINE F_ARRAY *float_to_bignum(CELL tagged)
-{
- return double_to_bignum(untag_float_fast(tagged));
-}
-
-INLINE double fixnum_to_float(CELL tagged)
-{
- return (double)untag_fixnum_fast(tagged);
-}
-
-INLINE double bignum_to_float(CELL tagged)
-{
- return bignum_to_double(untag_object(tagged));
-}
-
-DLLEXPORT void box_float(float flo);
-DLLEXPORT float to_float(CELL value);
-DLLEXPORT void box_double(double flo);
-DLLEXPORT double to_double(CELL value);
-
-void primitive_fixnum_to_float(void);
-void primitive_bignum_to_float(void);
-void primitive_str_to_float(void);
-void primitive_float_to_str(void);
-void primitive_float_to_bits(void);
-
-void primitive_float_eq(void);
-void primitive_float_add(void);
-void primitive_float_subtract(void);
-void primitive_float_multiply(void);
-void primitive_float_divfloat(void);
-void primitive_float_mod(void);
-void primitive_float_less(void);
-void primitive_float_lesseq(void);
-void primitive_float_greater(void);
-void primitive_float_greatereq(void);
-
-void primitive_float_bits(void);
-void primitive_bits_float(void);
-void primitive_double_bits(void);
-void primitive_bits_double(void);
-
-void primitive_from_rect(void);
diff --git a/vm/math.hpp b/vm/math.hpp
new file mode 100644
index 0000000000..763ed55f9a
--- /dev/null
+++ b/vm/math.hpp
@@ -0,0 +1,149 @@
+namespace factor
+{
+
+extern cell bignum_zero;
+extern cell bignum_pos_one;
+extern cell bignum_neg_one;
+
+#define cell_MAX (cell)(-1)
+#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
+#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)))
+#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2))
+
+PRIMITIVE(fixnum_add);
+PRIMITIVE(fixnum_subtract);
+PRIMITIVE(fixnum_multiply);
+
+PRIMITIVE(bignum_to_fixnum);
+PRIMITIVE(float_to_fixnum);
+
+PRIMITIVE(fixnum_divint);
+PRIMITIVE(fixnum_divmod);
+PRIMITIVE(fixnum_shift);
+
+PRIMITIVE(fixnum_to_bignum);
+PRIMITIVE(float_to_bignum);
+PRIMITIVE(bignum_eq);
+PRIMITIVE(bignum_add);
+PRIMITIVE(bignum_subtract);
+PRIMITIVE(bignum_multiply);
+PRIMITIVE(bignum_divint);
+PRIMITIVE(bignum_divmod);
+PRIMITIVE(bignum_mod);
+PRIMITIVE(bignum_and);
+PRIMITIVE(bignum_or);
+PRIMITIVE(bignum_xor);
+PRIMITIVE(bignum_shift);
+PRIMITIVE(bignum_less);
+PRIMITIVE(bignum_lesseq);
+PRIMITIVE(bignum_greater);
+PRIMITIVE(bignum_greatereq);
+PRIMITIVE(bignum_not);
+PRIMITIVE(bignum_bitp);
+PRIMITIVE(bignum_log2);
+PRIMITIVE(byte_array_to_bignum);
+
+inline static cell allot_integer(fixnum x)
+{
+ if(x < FIXNUM_MIN || x > FIXNUM_MAX)
+ return tag<bignum>(fixnum_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+inline static cell allot_cell(cell x)
+{
+ if(x > (cell)FIXNUM_MAX)
+ return tag<bignum>(cell_to_bignum(x));
+ else
+ return tag_fixnum(x);
+}
+
+cell unbox_array_size(void);
+
+inline static double untag_float(cell tagged)
+{
+ return untag<boxed_float>(tagged)->n;
+}
+
+inline static double untag_float_check(cell tagged)
+{
+ return untag_check<boxed_float>(tagged)->n;
+}
+
+inline static cell allot_float(double n)
+{
+ boxed_float *flo = allot<boxed_float>(sizeof(boxed_float));
+ flo->n = n;
+ return tag(flo);
+}
+
+inline static fixnum float_to_fixnum(cell tagged)
+{
+ return (fixnum)untag_float(tagged);
+}
+
+inline static bignum *float_to_bignum(cell tagged)
+{
+ return double_to_bignum(untag_float(tagged));
+}
+
+inline static double fixnum_to_float(cell tagged)
+{
+ return (double)untag_fixnum(tagged);
+}
+
+inline static double bignum_to_float(cell tagged)
+{
+ return bignum_to_double(untag<bignum>(tagged));
+}
+
+PRIMITIVE(fixnum_to_float);
+PRIMITIVE(bignum_to_float);
+PRIMITIVE(str_to_float);
+PRIMITIVE(float_to_str);
+PRIMITIVE(float_to_bits);
+
+PRIMITIVE(float_eq);
+PRIMITIVE(float_add);
+PRIMITIVE(float_subtract);
+PRIMITIVE(float_multiply);
+PRIMITIVE(float_divfloat);
+PRIMITIVE(float_mod);
+PRIMITIVE(float_less);
+PRIMITIVE(float_lesseq);
+PRIMITIVE(float_greater);
+PRIMITIVE(float_greatereq);
+
+PRIMITIVE(float_bits);
+PRIMITIVE(bits_float);
+PRIMITIVE(double_bits);
+PRIMITIVE(bits_double);
+
+VM_C_API void box_float(float flo);
+VM_C_API float to_float(cell value);
+VM_C_API void box_double(double flo);
+VM_C_API double to_double(cell value);
+
+VM_C_API void box_signed_1(s8 n);
+VM_C_API void box_unsigned_1(u8 n);
+VM_C_API void box_signed_2(s16 n);
+VM_C_API void box_unsigned_2(u16 n);
+VM_C_API void box_signed_4(s32 n);
+VM_C_API void box_unsigned_4(u32 n);
+VM_C_API void box_signed_cell(fixnum integer);
+VM_C_API void box_unsigned_cell(cell cell);
+VM_C_API void box_signed_8(s64 n);
+VM_C_API void box_unsigned_8(u64 n);
+
+VM_C_API s64 to_signed_8(cell obj);
+VM_C_API u64 to_unsigned_8(cell obj);
+
+VM_C_API fixnum to_fixnum(cell tagged);
+VM_C_API cell to_cell(cell tagged);
+
+VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y);
+VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y);
+VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y);
+
+}
diff --git a/vm/os-freebsd-x86.32.h b/vm/os-freebsd-x86.32.hpp
similarity index 73%
rename from vm/os-freebsd-x86.32.h
rename to vm/os-freebsd-x86.32.hpp
index a04755e9dd..c276ce6174 100644
--- a/vm/os-freebsd-x86.32.h
+++ b/vm/os-freebsd-x86.32.hpp
@@ -1,9 +1,14 @@
#include <ucontext.h>
-INLINE void *ucontext_stack_pointer(void *uap)
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.mc_esp;
}
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
+
+}
diff --git a/vm/os-freebsd-x86.64.h b/vm/os-freebsd-x86.64.hpp
similarity index 73%
rename from vm/os-freebsd-x86.64.h
rename to vm/os-freebsd-x86.64.hpp
index 23e1ff5733..6ee491f3ae 100644
--- a/vm/os-freebsd-x86.64.h
+++ b/vm/os-freebsd-x86.64.hpp
@@ -1,9 +1,14 @@
#include <ucontext.h>
-INLINE void *ucontext_stack_pointer(void *uap)
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.mc_rsp;
}
#define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
+
+}
diff --git a/vm/os-freebsd.c b/vm/os-freebsd.cpp
similarity index 92%
rename from vm/os-freebsd.c
rename to vm/os-freebsd.cpp
index 1d43a13001..63313f61e0 100644
--- a/vm/os-freebsd.c
+++ b/vm/os-freebsd.cpp
@@ -1,4 +1,7 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
/* From SBCL */
const char *vm_executable_path(void)
@@ -32,3 +35,5 @@ const char *vm_executable_path(void)
return safe_strdup(path);
}
+
+}
diff --git a/vm/os-freebsd.h b/vm/os-freebsd.hpp
similarity index 76%
rename from vm/os-freebsd.h
rename to vm/os-freebsd.hpp
index 617a6686c2..0acf537d45 100644
--- a/vm/os-freebsd.h
+++ b/vm/os-freebsd.hpp
@@ -1,9 +1,8 @@
#include <osreldate.h>
-
-extern int getosreldate(void);
-
#include <sys/sysctl.h>
+extern "C" int getosreldate(void);
+
#ifndef KERN_PROC_PATHNAME
#define KERN_PROC_PATHNAME 12
#endif
diff --git a/vm/os-genunix.c b/vm/os-genunix.cpp
similarity index 78%
rename from vm/os-genunix.c
rename to vm/os-genunix.cpp
index f582483ce7..731527d208 100755
--- a/vm/os-genunix.c
+++ b/vm/os-genunix.cpp
@@ -1,6 +1,9 @@
-#include "master.h"
+#include "master.hpp"
-void c_to_factor_toplevel(CELL quot)
+namespace factor
+{
+
+void c_to_factor_toplevel(cell quot)
{
c_to_factor(quot);
}
@@ -28,8 +31,10 @@ const char *default_image_path(void)
const char *iter = path;
while(*iter) { len++; iter++; }
- char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
+ char *new_path = (char *)safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
memcpy(new_path,path,len + 1);
memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
return new_path;
}
+
+}
diff --git a/vm/os-genunix.h b/vm/os-genunix.hpp
similarity index 62%
rename from vm/os-genunix.h
rename to vm/os-genunix.hpp
index 7afc68998d..bc12f716cf 100644
--- a/vm/os-genunix.h
+++ b/vm/os-genunix.hpp
@@ -1,8 +1,13 @@
-#define DLLEXPORT
+namespace factor
+{
+
+#define VM_C_API extern "C"
#define NULL_DLL NULL
-void c_to_factor_toplevel(CELL quot);
+void c_to_factor_toplevel(cell quot);
void init_signals(void);
void early_init(void);
const char *vm_executable_path(void);
const char *default_image_path(void);
+
+}
diff --git a/vm/os-linux-arm.c b/vm/os-linux-arm.cpp
similarity index 87%
rename from vm/os-linux-arm.c
rename to vm/os-linux-arm.cpp
index 39a3da0b3f..8e131b9011 100644
--- a/vm/os-linux-arm.c
+++ b/vm/os-linux-arm.cpp
@@ -1,6 +1,9 @@
-#include "master.h"
+#include "master.hpp"
-void flush_icache(CELL start, CELL len)
+namespace factor
+{
+
+void flush_icache(cell start, cell len)
{
int result;
@@ -24,3 +27,5 @@ void flush_icache(CELL start, CELL len)
if(result < 0)
critical_error("flush_icache() failed",result);
}
+
+}
diff --git a/vm/os-linux-arm.h b/vm/os-linux-arm.hpp
similarity index 68%
rename from vm/os-linux-arm.h
rename to vm/os-linux-arm.hpp
index 6e078b014d..70c3eb3ff6 100644
--- a/vm/os-linux-arm.h
+++ b/vm/os-linux-arm.hpp
@@ -2,7 +2,10 @@
#include <asm/unistd.h>
#include <sys/syscall.h>
-INLINE void *ucontext_stack_pointer(void *uap)
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.arm_sp;
@@ -11,4 +14,6 @@ INLINE void *ucontext_stack_pointer(void *uap)
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
-void flush_icache(CELL start, CELL len);
+void flush_icache(cell start, cell len);
+
+}
diff --git a/vm/os-linux-ppc.h b/vm/os-linux-ppc.hpp
similarity index 61%
rename from vm/os-linux-ppc.h
rename to vm/os-linux-ppc.hpp
index eb28af53e4..c0d13e6f17 100644
--- a/vm/os-linux-ppc.h
+++ b/vm/os-linux-ppc.hpp
@@ -1,8 +1,11 @@
#include <ucontext.h>
-#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
+namespace factor
+{
-INLINE void *ucontext_stack_pointer(void *uap)
+#define FRAME_RETURN_ADDRESS(frame) *((void **)(frame_successor(frame) + 1) + 1)
+
+inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
@@ -10,3 +13,5 @@ INLINE void *ucontext_stack_pointer(void *uap)
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
+
+}
diff --git a/vm/os-linux-x86.32.h b/vm/os-linux-x86.32.hpp
similarity index 74%
rename from vm/os-linux-x86.32.h
rename to vm/os-linux-x86.32.hpp
index b458fcbe21..4ba7c77e4b 100644
--- a/vm/os-linux-x86.32.h
+++ b/vm/os-linux-x86.32.hpp
@@ -1,6 +1,9 @@
#include <ucontext.h>
-INLINE void *ucontext_stack_pointer(void *uap)
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[7];
@@ -8,3 +11,5 @@ INLINE void *ucontext_stack_pointer(void *uap)
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
+
+}
diff --git a/vm/os-linux-x86.64.h b/vm/os-linux-x86.64.hpp
similarity index 74%
rename from vm/os-linux-x86.64.h
rename to vm/os-linux-x86.64.hpp
index 911c2f1749..477e21708c 100644
--- a/vm/os-linux-x86.64.h
+++ b/vm/os-linux-x86.64.hpp
@@ -1,6 +1,9 @@
#include <ucontext.h>
-INLINE void *ucontext_stack_pointer(void *uap)
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[15];
@@ -8,3 +11,5 @@ INLINE void *ucontext_stack_pointer(void *uap)
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
+
+}
diff --git a/vm/os-linux.c b/vm/os-linux.cpp
similarity index 90%
rename from vm/os-linux.c
rename to vm/os-linux.cpp
index 91017fc3f8..ecc8973ebe 100644
--- a/vm/os-linux.c
+++ b/vm/os-linux.cpp
@@ -1,9 +1,12 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
const char *vm_executable_path(void)
{
- char *path = safe_malloc(PATH_MAX + 1);
+ char *path = (char *)safe_malloc(PATH_MAX + 1);
int size = readlink("/proc/self/exe", path, PATH_MAX);
if (size < 0)
@@ -56,3 +59,5 @@ int inotify_rm_watch(int fd, u32 wd)
}
#endif
+
+}
diff --git a/vm/os-linux.h b/vm/os-linux.hpp
similarity index 86%
rename from vm/os-linux.h
rename to vm/os-linux.hpp
index 8e78595687..4e2f22b95f 100644
--- a/vm/os-linux.h
+++ b/vm/os-linux.hpp
@@ -1,5 +1,10 @@
#include <sys/syscall.h>
+namespace factor
+{
+
int inotify_init(void);
int inotify_add_watch(int fd, const char *name, u32 mask);
int inotify_rm_watch(int fd, u32 wd);
+
+}
diff --git a/vm/os-macosx-ppc.h b/vm/os-macosx-ppc.hpp
similarity index 90%
rename from vm/os-macosx-ppc.h
rename to vm/os-macosx-ppc.hpp
index 13213acbbc..d80959eaec 100644
--- a/vm/os-macosx-ppc.h
+++ b/vm/os-macosx-ppc.hpp
@@ -1,3 +1,8 @@
+#include <ucontext.h>
+
+namespace factor
+{
+
/* Fault handler information. MacOSX version.
Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
@@ -8,9 +13,7 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov */
-#include <ucontext.h>
-
-#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 2)
+#define FRAME_RETURN_ADDRESS(frame) *((void **)(frame_successor(frame) + 1) + 2)
#define MACH_EXC_STATE_TYPE ppc_exception_state_t
#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
@@ -33,7 +36,9 @@ Modified for Factor by Slava Pestov */
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
#endif
-INLINE CELL fix_stack_pointer(CELL sp)
+inline static cell fix_stack_pointer(cell sp)
{
return sp;
}
+
+}
diff --git a/vm/os-macosx-x86.32.h b/vm/os-macosx-x86.32.hpp
similarity index 95%
rename from vm/os-macosx-x86.32.h
rename to vm/os-macosx-x86.32.hpp
index 7c830c775d..e6454fd039 100644
--- a/vm/os-macosx-x86.32.h
+++ b/vm/os-macosx-x86.32.hpp
@@ -1,3 +1,8 @@
+#include <ucontext.h>
+
+namespace factor
+{
+
/* Fault handler information. MacOSX version.
Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
@@ -8,8 +13,6 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov */
-#include <ucontext.h>
-
#define MACH_EXC_STATE_TYPE i386_exception_state_t
#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
@@ -31,7 +34,9 @@ Modified for Factor by Slava Pestov */
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
#endif
-INLINE CELL fix_stack_pointer(CELL sp)
+inline static cell fix_stack_pointer(cell sp)
{
return ((sp + 4) & ~15) - 4;
}
+
+}
diff --git a/vm/os-macosx-x86.64.h b/vm/os-macosx-x86.64.hpp
similarity index 95%
rename from vm/os-macosx-x86.64.h
rename to vm/os-macosx-x86.64.hpp
index b11aa80ce8..4d8976991e 100644
--- a/vm/os-macosx-x86.64.h
+++ b/vm/os-macosx-x86.64.hpp
@@ -1,3 +1,8 @@
+#include <ucontext.h>
+
+namespace factor
+{
+
/* Fault handler information. MacOSX version.
Copyright (C) 1993-1999, 2002-2003 Bruno Haible <clisp.org at bruno>
Copyright (C) 2003 Paolo Bonzini <gnu.org at bonzini>
@@ -8,8 +13,6 @@ Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
Modified for Factor by Slava Pestov and Daniel Ehrenberg */
-#include <ucontext.h>
-
#define MACH_EXC_STATE_TYPE x86_exception_state64_t
#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
@@ -31,7 +34,9 @@ Modified for Factor by Slava Pestov and Daniel Ehrenberg */
MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
#endif
-INLINE CELL fix_stack_pointer(CELL sp)
+inline static cell fix_stack_pointer(cell sp)
{
return ((sp + 8) & ~15) - 8;
}
+
+}
diff --git a/vm/os-macosx.h b/vm/os-macosx.hpp
similarity index 60%
rename from vm/os-macosx.h
rename to vm/os-macosx.hpp
index 216212e973..aa166910f5 100644
--- a/vm/os-macosx.h
+++ b/vm/os-macosx.hpp
@@ -1,4 +1,7 @@
-#define DLLEXPORT __attribute__((visibility("default")))
+namespace factor
+{
+
+#define VM_C_API extern "C" __attribute__((visibility("default")))
#define FACTOR_OS_STRING "macosx"
#define NULL_DLL "libfactor.dylib"
@@ -8,10 +11,12 @@ void early_init(void);
const char *vm_executable_path(void);
const char *default_image_path(void);
-DLLEXPORT void c_to_factor_toplevel(CELL quot);
-
-INLINE void *ucontext_stack_pointer(void *uap)
+inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return ucontext->uc_stack.ss_sp;
}
+
+void c_to_factor_toplevel(cell quot);
+
+}
diff --git a/vm/os-macosx.m b/vm/os-macosx.mm
similarity index 90%
rename from vm/os-macosx.m
rename to vm/os-macosx.mm
index 9b0366ff75..792ba0d541 100644
--- a/vm/os-macosx.m
+++ b/vm/os-macosx.mm
@@ -1,8 +1,11 @@
#import <Cocoa/Cocoa.h>
-#include "master.h"
+#include "master.hpp"
-void c_to_factor_toplevel(CELL quot)
+namespace factor
+{
+
+void c_to_factor_toplevel(cell quot)
{
for(;;)
{
@@ -10,9 +13,9 @@ NS_DURING
c_to_factor(quot);
NS_VOIDRETURN;
NS_HANDLER
- dpush(allot_alien(F,(CELL)localException));
+ dpush(allot_alien(F,(cell)localException));
quot = userenv[COCOA_EXCEPTION_ENV];
- if(type_of(quot) != QUOTATION_TYPE)
+ if(!tagged<object>(quot).type_p(QUOTATION_TYPE))
{
/* No Cocoa exception handler was registered, so
extra/cocoa/ is not loaded. So we pass the exception
@@ -80,3 +83,5 @@ Protocol *objc_getProtocol(char *name)
else
return nil;
}
+
+}
diff --git a/vm/os-netbsd-x86.32.h b/vm/os-netbsd-x86.32.hpp
similarity index 81%
rename from vm/os-netbsd-x86.32.h
rename to vm/os-netbsd-x86.32.hpp
index ca4a9f88f5..ebba4f356d 100644
--- a/vm/os-netbsd-x86.32.h
+++ b/vm/os-netbsd-x86.32.hpp
@@ -1,3 +1,8 @@
#include <ucontext.h>
+namespace factor
+{
+
#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
+
+}
diff --git a/vm/os-netbsd-x86.64.h b/vm/os-netbsd-x86.64.hpp
similarity index 84%
rename from vm/os-netbsd-x86.64.h
rename to vm/os-netbsd-x86.64.hpp
index 587dc85ec7..1a062cc6ef 100644
--- a/vm/os-netbsd-x86.64.h
+++ b/vm/os-netbsd-x86.64.hpp
@@ -1,4 +1,9 @@
#include <ucontext.h>
+namespace factor
+{
+
#define ucontext_stack_pointer(uap) \
((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
+
+}
diff --git a/vm/os-netbsd.c b/vm/os-netbsd.cpp
similarity index 54%
rename from vm/os-netbsd.c
rename to vm/os-netbsd.cpp
index c33b4ad69c..7a3cb30652 100755
--- a/vm/os-netbsd.c
+++ b/vm/os-netbsd.cpp
@@ -1,11 +1,16 @@
-#include "master.h"
+#include "master.hpp"
-extern int main();
+namespace factor
+{
+
+extern "C" int main();
const char *vm_executable_path(void)
{
static Dl_info info = {0};
if (!info.dli_fname)
- dladdr(main, &info);
+ dladdr((void *)main, &info);
return info.dli_fname;
}
+
+}
diff --git a/vm/os-netbsd.h b/vm/os-netbsd.hpp
similarity index 86%
rename from vm/os-netbsd.h
rename to vm/os-netbsd.hpp
index 6486acda4a..635361e3e4 100644
--- a/vm/os-netbsd.h
+++ b/vm/os-netbsd.hpp
@@ -1,5 +1,10 @@
#include <ucontext.h>
+namespace factor
+{
+
#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
+
+}
diff --git a/vm/os-openbsd-x86.32.h b/vm/os-openbsd-x86.32.hpp
similarity index 75%
rename from vm/os-openbsd-x86.32.h
rename to vm/os-openbsd-x86.32.hpp
index 0617e62c0d..6065d96a5f 100644
--- a/vm/os-openbsd-x86.32.h
+++ b/vm/os-openbsd-x86.32.hpp
@@ -1,6 +1,9 @@
#include <i386/signal.h>
-INLINE void *openbsd_stack_pointer(void *uap)
+namespace factor
+{
+
+inline static void *openbsd_stack_pointer(void *uap)
{
struct sigcontext *sc = (struct sigcontext*) uap;
return (void *)sc->sc_esp;
@@ -8,3 +11,5 @@ INLINE void *openbsd_stack_pointer(void *uap)
#define ucontext_stack_pointer openbsd_stack_pointer
#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
+
+}
diff --git a/vm/os-openbsd-x86.64.h b/vm/os-openbsd-x86.64.hpp
similarity index 75%
rename from vm/os-openbsd-x86.64.h
rename to vm/os-openbsd-x86.64.hpp
index 3386e80a4b..7338b04e6f 100644
--- a/vm/os-openbsd-x86.64.h
+++ b/vm/os-openbsd-x86.64.hpp
@@ -1,6 +1,9 @@
#include <amd64/signal.h>
-INLINE void *openbsd_stack_pointer(void *uap)
+namespace factor
+{
+
+inline static void *openbsd_stack_pointer(void *uap)
{
struct sigcontext *sc = (struct sigcontext*) uap;
return (void *)sc->sc_rsp;
@@ -8,3 +11,5 @@ INLINE void *openbsd_stack_pointer(void *uap)
#define ucontext_stack_pointer openbsd_stack_pointer
#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
+
+}
diff --git a/vm/os-openbsd.c b/vm/os-openbsd.cpp
similarity index 55%
rename from vm/os-openbsd.c
rename to vm/os-openbsd.cpp
index b9238b7877..fc8aac8cf7 100644
--- a/vm/os-openbsd.c
+++ b/vm/os-openbsd.cpp
@@ -1,6 +1,11 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
const char *vm_executable_path(void)
{
return NULL;
}
+
+}
diff --git a/vm/os-solaris-x86.32.h b/vm/os-solaris-x86.32.hpp
similarity index 74%
rename from vm/os-solaris-x86.32.h
rename to vm/os-solaris-x86.32.hpp
index 1f4ec74e17..b89b8d541b 100644
--- a/vm/os-solaris-x86.32.h
+++ b/vm/os-solaris-x86.32.hpp
@@ -1,6 +1,9 @@
#include <ucontext.h>
-INLINE void *ucontext_stack_pointer(void *uap)
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[ESP];
@@ -8,3 +11,5 @@ INLINE void *ucontext_stack_pointer(void *uap)
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
+
+}
diff --git a/vm/os-solaris-x86.64.h b/vm/os-solaris-x86.64.hpp
similarity index 74%
rename from vm/os-solaris-x86.64.h
rename to vm/os-solaris-x86.64.hpp
index 54d1866d50..0d3a74e11d 100644
--- a/vm/os-solaris-x86.64.h
+++ b/vm/os-solaris-x86.64.hpp
@@ -1,6 +1,9 @@
#include <ucontext.h>
-INLINE void *ucontext_stack_pointer(void *uap)
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
{
ucontext_t *ucontext = (ucontext_t *)uap;
return (void *)ucontext->uc_mcontext.gregs[RSP];
@@ -8,3 +11,5 @@ INLINE void *ucontext_stack_pointer(void *uap)
#define UAP_PROGRAM_COUNTER(ucontext) \
(((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
+
+}
diff --git a/vm/os-solaris.c b/vm/os-solaris.cpp
similarity index 55%
rename from vm/os-solaris.c
rename to vm/os-solaris.cpp
index b9238b7877..fc8aac8cf7 100644
--- a/vm/os-solaris.c
+++ b/vm/os-solaris.cpp
@@ -1,6 +1,11 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
const char *vm_executable_path(void)
{
return NULL;
}
+
+}
diff --git a/vm/os-unix.c b/vm/os-unix.cpp
similarity index 79%
rename from vm/os-unix.c
rename to vm/os-unix.cpp
index 97c29d8c6e..c0a268018e 100755
--- a/vm/os-unix.c
+++ b/vm/os-unix.cpp
@@ -1,4 +1,7 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
void start_thread(void *(*start_routine)(void *))
{
@@ -23,7 +26,7 @@ s64 current_micros(void)
return (s64)t.tv_sec * 1000000 + t.tv_usec;
}
-void sleep_micros(CELL usec)
+void sleep_micros(cell usec)
{
usleep(usec);
}
@@ -34,38 +37,36 @@ void init_ffi(void)
null_dll = dlopen(NULL_DLL,RTLD_LAZY);
}
-void ffi_dlopen(F_DLL *dll)
+void ffi_dlopen(dll *dll)
{
dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
}
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
+void *ffi_dlsym(dll *dll, symbol_char *symbol)
{
void *handle = (dll == NULL ? null_dll : dll->dll);
return dlsym(handle,symbol);
}
-void ffi_dlclose(F_DLL *dll)
+void ffi_dlclose(dll *dll)
{
if(dlclose(dll->dll))
- {
- general_error(ERROR_FFI,tag_object(
- from_char_string(dlerror())),F,NULL);
- }
+ general_error(ERROR_FFI,F,F,NULL);
dll->dll = NULL;
}
-void primitive_existsp(void)
+PRIMITIVE(existsp)
{
struct stat sb;
- box_boolean(stat(unbox_char_string(),&sb) >= 0);
+ char *path = (char *)(untag_check<byte_array>(dpop()) + 1);
+ box_boolean(stat(path,&sb) >= 0);
}
-F_SEGMENT *alloc_segment(CELL size)
+segment *alloc_segment(cell size)
{
int pagesize = getpagesize();
- char *array = mmap(NULL,pagesize + size + pagesize,
+ char *array = (char *)mmap(NULL,pagesize + size + pagesize,
PROT_READ | PROT_WRITE | PROT_EXEC,
MAP_ANON | MAP_PRIVATE,-1,0);
@@ -73,21 +74,21 @@ F_SEGMENT *alloc_segment(CELL size)
out_of_memory();
if(mprotect(array,pagesize,PROT_NONE) == -1)
- fatal_error("Cannot protect low guard page",(CELL)array);
+ fatal_error("Cannot protect low guard page",(cell)array);
if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
- fatal_error("Cannot protect high guard page",(CELL)array);
+ fatal_error("Cannot protect high guard page",(cell)array);
- F_SEGMENT *retval = safe_malloc(sizeof(F_SEGMENT));
+ segment *retval = (segment *)safe_malloc(sizeof(segment));
- retval->start = (CELL)(array + pagesize);
+ retval->start = (cell)(array + pagesize);
retval->size = size;
retval->end = retval->start + size;
return retval;
}
-void dealloc_segment(F_SEGMENT *block)
+void dealloc_segment(segment *block)
{
int pagesize = getpagesize();
@@ -100,7 +101,7 @@ void dealloc_segment(F_SEGMENT *block)
free(block);
}
-INLINE F_STACK_FRAME *uap_stack_pointer(void *uap)
+static stack_frame *uap_stack_pointer(void *uap)
{
/* There is a race condition here, but in practice a signal
delivered during stack frame setup/teardown or while transitioning
@@ -108,9 +109,9 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap)
a divide by zero or stack underflow in the listener */
if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
{
- F_STACK_FRAME *ptr = ucontext_stack_pointer(uap);
+ stack_frame *ptr = (stack_frame *)ucontext_stack_pointer(uap);
if(!ptr)
- critical_error("Invalid uap",(CELL)uap);
+ critical_error("Invalid uap",(cell)uap);
return ptr;
}
else
@@ -119,16 +120,16 @@ INLINE F_STACK_FRAME *uap_stack_pointer(void *uap)
void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
- signal_fault_addr = (CELL)siginfo->si_addr;
+ signal_fault_addr = (cell)siginfo->si_addr;
signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (CELL)memory_signal_handler_impl;
+ UAP_PROGRAM_COUNTER(uap) = (cell)memory_signal_handler_impl;
}
void misc_signal_handler(int signal, siginfo_t *siginfo, void *uap)
{
signal_number = signal;
signal_callstack_top = uap_stack_pointer(uap);
- UAP_PROGRAM_COUNTER(uap) = (CELL)misc_signal_handler_impl;
+ UAP_PROGRAM_COUNTER(uap) = (cell)misc_signal_handler_impl;
}
static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
@@ -182,14 +183,16 @@ and writes it to a data pipe. Upon completion, it writes a 4-byte integer to
the size pipe, indicating how much data was written to the data pipe.
The read end of the size pipe can be set to non-blocking. */
-__attribute__((visibility("default"))) int stdin_read;
-__attribute__((visibility("default"))) int stdin_write;
+extern "C" {
+ int stdin_read;
+ int stdin_write;
-__attribute__((visibility("default"))) int control_read;
-__attribute__((visibility("default"))) int control_write;
+ int control_read;
+ int control_write;
-__attribute__((visibility("default"))) int size_read;
-__attribute__((visibility("default"))) int size_write;
+ int size_read;
+ int size_write;
+}
void safe_close(int fd)
{
@@ -197,7 +200,7 @@ void safe_close(int fd)
fatal_error("error closing fd",errno);
}
-bool check_write(int fd, void *data, size_t size)
+bool check_write(int fd, void *data, ssize_t size)
{
if(write(fd,data,size) == size)
return true;
@@ -210,13 +213,13 @@ bool check_write(int fd, void *data, size_t size)
}
}
-void safe_write(int fd, void *data, size_t size)
+void safe_write(int fd, void *data, ssize_t size)
{
if(!check_write(fd,data,size))
fatal_error("error writing fd",errno);
}
-bool safe_read(int fd, void *data, size_t size)
+bool safe_read(int fd, void *data, ssize_t size)
{
ssize_t bytes = read(fd,data,size);
if(bytes < 0)
@@ -301,7 +304,7 @@ void open_console(void)
start_thread(stdin_loop);
}
-DLLEXPORT void wait_for_stdin(void)
+VM_C_API void wait_for_stdin(void)
{
if(write(control_write,"X",1) != 1)
{
@@ -311,3 +314,5 @@ DLLEXPORT void wait_for_stdin(void)
fatal_error("Error writing control fd",errno);
}
}
+
+}
diff --git a/vm/os-unix.h b/vm/os-unix.hpp
similarity index 62%
rename from vm/os-unix.h
rename to vm/os-unix.hpp
index 35abfee41c..24e8016db4 100755
--- a/vm/os-unix.h
+++ b/vm/os-unix.hpp
@@ -8,13 +8,11 @@
#include <signal.h>
#include <pthread.h>
-typedef char F_CHAR;
-typedef char F_SYMBOL;
+namespace factor
+{
-#define from_native_string from_char_string
-#define unbox_native_string unbox_char_string
-#define string_to_native_alien(string) string_to_char_alien(string,true)
-#define unbox_symbol_string unbox_char_string
+typedef char vm_char;
+typedef char symbol_char;
#define STRING_LITERAL(string) string
@@ -26,13 +24,13 @@ typedef char F_SYMBOL;
#define FSEEK fseeko
#define FIXNUM_FORMAT "%ld"
-#define CELL_FORMAT "%lu"
-#define CELL_HEX_FORMAT "%lx"
+#define cell_FORMAT "%lu"
+#define cell_HEX_FORMAT "%lx"
#ifdef FACTOR_64
- #define CELL_HEX_PAD_FORMAT "%016lx"
+ #define cell_HEX_PAD_FORMAT "%016lx"
#else
- #define CELL_HEX_PAD_FORMAT "%08lx"
+ #define cell_HEX_PAD_FORMAT "%08lx"
#endif
#define FIXNUM_FORMAT "%ld"
@@ -45,15 +43,17 @@ typedef char F_SYMBOL;
void start_thread(void *(*start_routine)(void *));
void init_ffi(void);
-void ffi_dlopen(F_DLL *dll);
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
-void ffi_dlclose(F_DLL *dll);
+void ffi_dlopen(dll *dll);
+void *ffi_dlsym(dll *dll, symbol_char *symbol);
+void ffi_dlclose(dll *dll);
void unix_init_signals(void);
void signal_handler(int signal, siginfo_t* siginfo, void* uap);
void dump_stack_signal(int signal, siginfo_t* siginfo, void* uap);
s64 current_micros(void);
-void sleep_micros(CELL usec);
+void sleep_micros(cell usec);
void open_console(void);
+
+}
diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.cpp
similarity index 79%
rename from vm/os-windows-ce.c
rename to vm/os-windows-ce.cpp
index 621198ff7d..71c72e55f8 100755
--- a/vm/os-windows-ce.c
+++ b/vm/os-windows-ce.cpp
@@ -1,4 +1,7 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
s64 current_micros(void)
{
@@ -16,7 +19,7 @@ char *strerror(int err)
return "strerror() is not defined on WinCE. Use native I/O.";
}
-void flush_icache(CELL start, CELL end)
+void flush_icache(cell start, cell end)
{
FlushInstructionCache(GetCurrentProcess(), 0, 0);
}
@@ -27,14 +30,16 @@ char *getenv(char *name)
return 0; /* unreachable */
}
-void primitive_os_envs(void)
+PRIMITIVE(os_envs)
{
not_implemented_error();
}
-void c_to_factor_toplevel(CELL quot)
+void c_to_factor_toplevel(cell quot)
{
c_to_factor(quot);
}
void open_console(void) { }
+
+}
diff --git a/vm/os-windows-ce.h b/vm/os-windows-ce.hpp
similarity index 65%
rename from vm/os-windows-ce.h
rename to vm/os-windows-ce.hpp
index a2be5fe475..49450f91c7 100755
--- a/vm/os-windows-ce.h
+++ b/vm/os-windows-ce.hpp
@@ -5,10 +5,10 @@
#include <windows.h>
#include <ctype.h>
-typedef wchar_t F_SYMBOL;
+namespace factor
+{
-#define unbox_symbol_string unbox_u16_string
-#define from_symbol_string from_u16_string
+typedef wchar_t symbol_char;
#define FACTOR_OS_STRING "wince"
#define FACTOR_DLL L"factor-ce.dll"
@@ -16,12 +16,14 @@ typedef wchar_t F_SYMBOL;
int errno;
char *strerror(int err);
-void flush_icache(CELL start, CELL end);
+void flush_icache(cell start, cell end);
char *getenv(char *name);
#define snprintf _snprintf
#define snwprintf _snwprintf
s64 current_micros(void);
-void c_to_factor_toplevel(CELL quot);
+void c_to_factor_toplevel(cell quot);
void open_console(void);
+
+}
diff --git a/vm/os-windows-nt.32.h b/vm/os-windows-nt.32.hpp
similarity index 58%
rename from vm/os-windows-nt.32.h
rename to vm/os-windows-nt.32.hpp
index 9b10671ba0..ed67e28b8b 100644
--- a/vm/os-windows-nt.32.h
+++ b/vm/os-windows-nt.32.hpp
@@ -1,2 +1,7 @@
+namespace factor
+{
+
#define ESP Esp
#define EIP Eip
+
+}
diff --git a/vm/os-windows-nt.64.h b/vm/os-windows-nt.64.hpp
similarity index 58%
rename from vm/os-windows-nt.64.h
rename to vm/os-windows-nt.64.hpp
index 1f61c2335f..30ce150754 100644
--- a/vm/os-windows-nt.64.h
+++ b/vm/os-windows-nt.64.hpp
@@ -1,2 +1,7 @@
+namespace factor
+{
+
#define ESP Rsp
#define EIP Rip
+
+}
diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.cpp
similarity index 76%
rename from vm/os-windows-nt.c
rename to vm/os-windows-nt.cpp
index bcddd0b140..0a63dce513 100755
--- a/vm/os-windows-nt.c
+++ b/vm/os-windows-nt.cpp
@@ -1,4 +1,7 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
s64 current_micros(void)
{
@@ -21,13 +24,7 @@ long exception_handler(PEXCEPTION_POINTERS pe)
if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
{
signal_fault_addr = e->ExceptionInformation[1];
- c->EIP = (CELL)memory_signal_handler_impl;
- }
- else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO
- || e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO)
- {
- signal_number = ERROR_DIVIDE_BY_ZERO;
- c->EIP = (CELL)divide_by_zero_signal_handler_impl;
+ c->EIP = (cell)memory_signal_handler_impl;
}
/* If the Widcomm bluetooth stack is installed, the BTTray.exe process
injects code into running programs. For some reason this results in
@@ -37,14 +34,14 @@ long exception_handler(PEXCEPTION_POINTERS pe)
this exception means. */
else if(e->ExceptionCode != 0x40010006)
{
- signal_number = 11;
- c->EIP = (CELL)misc_signal_handler_impl;
+ signal_number = e->ExceptionCode;
+ c->EIP = (cell)misc_signal_handler_impl;
}
return EXCEPTION_CONTINUE_EXECUTION;
}
-void c_to_factor_toplevel(CELL quot)
+void c_to_factor_toplevel(cell quot)
{
if(!AddVectoredExceptionHandler(0, (void*)exception_handler))
fatal_error("AddVectoredExceptionHandler failed", 0);
@@ -55,3 +52,5 @@ void c_to_factor_toplevel(CELL quot)
void open_console(void)
{
}
+
+}
diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.hpp
similarity index 68%
rename from vm/os-windows-nt.h
rename to vm/os-windows-nt.hpp
index 4e047b497c..107e42ea2e 100755
--- a/vm/os-windows-nt.h
+++ b/vm/os-windows-nt.hpp
@@ -5,17 +5,20 @@
#define UNICODE
#endif
+#include <shellapi.h>
#include <windows.h>
-typedef char F_SYMBOL;
+namespace factor
+{
-#define unbox_symbol_string unbox_char_string
-#define from_symbol_string from_char_string
+typedef char symbol_char;
#define FACTOR_OS_STRING "winnt"
#define FACTOR_DLL L"factor.dll"
#define FACTOR_DLL_NAME "factor.dll"
-void c_to_factor_toplevel(CELL quot);
+void c_to_factor_toplevel(cell quot);
long exception_handler(PEXCEPTION_POINTERS pe);
void open_console(void);
+
+}
diff --git a/vm/os-windows.c b/vm/os-windows.cpp
similarity index 61%
rename from vm/os-windows.c
rename to vm/os-windows.cpp
index 2abc04cb3b..796a1c7184 100755
--- a/vm/os-windows.c
+++ b/vm/os-windows.cpp
@@ -1,38 +1,7 @@
-#include "master.h"
+#include "master.hpp"
-F_STRING *get_error_message(void)
+namespace factor
{
- DWORD id = GetLastError();
- F_CHAR *msg = error_message(id);
- F_STRING *string = from_u16_string(msg);
- LocalFree(msg);
- return string;
-}
-
-/* You must LocalFree() the return value! */
-F_CHAR *error_message(DWORD id)
-{
- F_CHAR *buffer;
- int index;
-
- DWORD ret = FormatMessage(
- FORMAT_MESSAGE_ALLOCATE_BUFFER |
- FORMAT_MESSAGE_FROM_SYSTEM,
- NULL,
- id,
- MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
- (LPTSTR)(void *) &buffer,
- 0, NULL);
- if(ret == 0)
- return error_message(GetLastError());
-
- /* strip whitespace from end */
- index = wcslen(buffer) - 1;
- while(index >= 0 && isspace(buffer[index]))
- buffer[index--] = 0;
-
- return buffer;
-}
HMODULE hFactorDll;
@@ -43,23 +12,23 @@ void init_ffi(void)
fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
}
-void ffi_dlopen(F_DLL *dll)
+void ffi_dlopen(dll *dll)
{
dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
}
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
+void *ffi_dlsym(dll *dll, symbol_char *symbol)
{
return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
}
-void ffi_dlclose(F_DLL *dll)
+void ffi_dlclose(dll *dll)
{
FreeLibrary((HMODULE)dll->dll);
dll->dll = NULL;
}
-bool windows_stat(F_CHAR *path)
+bool windows_stat(vm_char *path)
{
BY_HANDLE_FILE_INFORMATION bhfi;
HANDLE h = CreateFileW(path,
@@ -87,18 +56,18 @@ bool windows_stat(F_CHAR *path)
return ret;
}
-void windows_image_path(F_CHAR *full_path, F_CHAR *temp_path, unsigned int length)
+void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length)
{
snwprintf(temp_path, length-1, L"%s.image", full_path);
temp_path[sizeof(temp_path) - 1] = 0;
}
/* You must free() this yourself. */
-const F_CHAR *default_image_path(void)
+const vm_char *default_image_path(void)
{
- F_CHAR full_path[MAX_UNICODE_PATH];
- F_CHAR *ptr;
- F_CHAR temp_path[MAX_UNICODE_PATH];
+ vm_char full_path[MAX_UNICODE_PATH];
+ vm_char *ptr;
+ vm_char temp_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
fatal_error("GetModuleFileName() failed", 0);
@@ -113,23 +82,22 @@ const F_CHAR *default_image_path(void)
}
/* You must free() this yourself. */
-const F_CHAR *vm_executable_path(void)
+const vm_char *vm_executable_path(void)
{
- F_CHAR full_path[MAX_UNICODE_PATH];
+ vm_char full_path[MAX_UNICODE_PATH];
if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
fatal_error("GetModuleFileName() failed", 0);
return safe_strdup(full_path);
}
-void primitive_existsp(void)
+PRIMITIVE(existsp)
{
-
- F_CHAR *path = unbox_u16_string();
+ vm_char *path = (vm_char *)(untag_check<byte_array>(dpop()) + 1);
box_boolean(windows_stat(path));
}
-F_SEGMENT *alloc_segment(CELL size)
+segment *alloc_segment(cell size)
{
char *mem;
DWORD ignore;
@@ -139,22 +107,22 @@ F_SEGMENT *alloc_segment(CELL size)
out_of_memory();
if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
- fatal_error("Cannot allocate low guard page", (CELL)mem);
+ fatal_error("Cannot allocate low guard page", (cell)mem);
if (!VirtualProtect(mem + size + getpagesize(),
getpagesize(), PAGE_NOACCESS, &ignore))
- fatal_error("Cannot allocate high guard page", (CELL)mem);
+ fatal_error("Cannot allocate high guard page", (cell)mem);
- F_SEGMENT *block = safe_malloc(sizeof(F_SEGMENT));
+ segment *block = safe_malloc(sizeof(segment));
- block->start = (CELL)mem + getpagesize();
+ block->start = (cell)mem + getpagesize();
block->size = size;
block->end = block->start + size;
return block;
}
-void dealloc_segment(F_SEGMENT *block)
+void dealloc_segment(segment *block)
{
SYSTEM_INFO si;
GetSystemInfo(&si);
@@ -179,3 +147,5 @@ void sleep_micros(u64 usec)
{
Sleep((DWORD)(usec / 1000));
}
+
+}
diff --git a/vm/os-windows.h b/vm/os-windows.h
deleted file mode 100755
index 36d350f50d..0000000000
--- a/vm/os-windows.h
+++ /dev/null
@@ -1,63 +0,0 @@
-#include <ctype.h>
-
-#ifndef wcslen
- /* for cygwin */
- #include <wchar.h>
-#endif
-
-typedef wchar_t F_CHAR;
-
-#define from_native_string from_u16_string
-#define unbox_native_string unbox_u16_string
-#define string_to_native_alien(string) string_to_u16_alien(string,true)
-
-#define STRING_LITERAL(string) L##string
-
-#define MAX_UNICODE_PATH 32768
-#define DLLEXPORT __declspec(dllexport)
-#define SSCANF swscanf
-#define STRCMP wcscmp
-#define STRNCMP wcsncmp
-#define STRDUP _wcsdup
-#define MIN(a,b) ((a)>(b)?(b):(a))
-#define FSEEK fseek
-
-#ifdef WIN64
- #define CELL_FORMAT "%Iu"
- #define CELL_HEX_FORMAT "%Ix"
- #define CELL_HEX_PAD_FORMAT "%016Ix"
- #define FIXNUM_FORMAT "%Id"
-#else
- #define CELL_FORMAT "%lu"
- #define CELL_HEX_FORMAT "%lx"
- #define CELL_HEX_PAD_FORMAT "%08lx"
- #define FIXNUM_FORMAT "%ld"
-#endif
-
-#define OPEN_READ(path) _wfopen(path,L"rb")
-#define OPEN_WRITE(path) _wfopen(path,L"wb")
-
-#define print_native_string(string) wprintf(L"%s",string)
-
-/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
-#define EPOCH_OFFSET 0x019db1ded53e8000LL
-
-F_STRING *get_error_message(void);
-DLLEXPORT F_CHAR *error_message(DWORD id);
-void windows_error(void);
-
-void init_ffi(void);
-void ffi_dlopen(F_DLL *dll);
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
-void ffi_dlclose(F_DLL *dll);
-
-void sleep_micros(u64 msec);
-
-INLINE void init_signals(void) {}
-INLINE void early_init(void) {}
-const F_CHAR *vm_executable_path(void);
-const F_CHAR *default_image_path(void);
-long getpagesize (void);
-
-s64 current_micros(void);
-
diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp
new file mode 100755
index 0000000000..2926ea50a8
--- /dev/null
+++ b/vm/os-windows.hpp
@@ -0,0 +1,59 @@
+#include <ctype.h>
+
+#ifndef wcslen
+ /* for cygwin */
+ #include <wchar.h>
+#endif
+
+namespace factor
+{
+
+typedef wchar_t vm_char;
+
+#define STRING_LITERAL(string) L##string
+
+#define MAX_UNICODE_PATH 32768
+#define VM_C_API extern "C" __declspec(dllexport)
+#define SSCANF swscanf
+#define STRCMP wcscmp
+#define STRNCMP wcsncmp
+#define STRDUP _wcsdup
+#define MIN(a,b) ((a)>(b)?(b):(a))
+#define FSEEK fseek
+
+#ifdef WIN64
+ #define cell_FORMAT "%Iu"
+ #define cell_HEX_FORMAT "%Ix"
+ #define cell_HEX_PAD_FORMAT "%016Ix"
+ #define FIXNUM_FORMAT "%Id"
+#else
+ #define cell_FORMAT "%lu"
+ #define cell_HEX_FORMAT "%lx"
+ #define cell_HEX_PAD_FORMAT "%08lx"
+ #define FIXNUM_FORMAT "%ld"
+#endif
+
+#define OPEN_READ(path) _wfopen(path,L"rb")
+#define OPEN_WRITE(path) _wfopen(path,L"wb")
+
+#define print_native_string(string) wprintf(L"%s",string)
+
+/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
+#define EPOCH_OFFSET 0x019db1ded53e8000LL
+
+void init_ffi(void);
+void ffi_dlopen(dll *dll);
+void *ffi_dlsym(dll *dll, symbol_char *symbol);
+void ffi_dlclose(dll *dll);
+
+void sleep_micros(u64 msec);
+
+inline static void init_signals(void) {}
+inline static void early_init(void) {}
+const vm_char *vm_executable_path(void);
+const vm_char *default_image_path(void);
+long getpagesize (void);
+
+s64 current_micros(void);
+
+}
diff --git a/vm/platform.h b/vm/platform.hpp
similarity index 63%
rename from vm/platform.h
rename to vm/platform.hpp
index 70804542b4..7b4356af56 100644
--- a/vm/platform.h
+++ b/vm/platform.hpp
@@ -12,44 +12,44 @@
#if defined(WINDOWS)
#if defined(WINCE)
- #include "os-windows-ce.h"
+ #include "os-windows-ce.hpp"
#else
- #include "os-windows-nt.h"
+ #include "os-windows-nt.hpp"
#endif
- #include "os-windows.h"
+ #include "os-windows.hpp"
#if defined(FACTOR_AMD64)
- #include "os-windows-nt.64.h"
+ #include "os-windows-nt.64.hpp"
#elif defined(FACTOR_X86)
- #include "os-windows-nt.32.h"
+ #include "os-windows-nt.32.hpp"
#endif
#else
- #include "os-unix.h"
+ #include "os-unix.hpp"
#ifdef __APPLE__
- #include "os-macosx.h"
- #include "mach_signal.h"
+ #include "os-macosx.hpp"
+ #include "mach_signal.hpp"
#ifdef FACTOR_X86
- #include "os-macosx-x86.32.h"
+ #include "os-macosx-x86.32.hpp"
#elif defined(FACTOR_PPC)
- #include "os-macosx-ppc.h"
+ #include "os-macosx-ppc.hpp"
#elif defined(FACTOR_AMD64)
- #include "os-macosx-x86.64.h"
+ #include "os-macosx-x86.64.hpp"
#else
#error "Unsupported Mac OS X flavor"
#endif
#else
- #include "os-genunix.h"
+ #include "os-genunix.hpp"
#ifdef __FreeBSD__
#define FACTOR_OS_STRING "freebsd"
- #include "os-freebsd.h"
+ #include "os-freebsd.hpp"
#if defined(FACTOR_X86)
- #include "os-freebsd-x86.32.h"
+ #include "os-freebsd-x86.32.hpp"
#elif defined(FACTOR_AMD64)
- #include "os-freebsd-x86.64.h"
+ #include "os-freebsd-x86.64.hpp"
#else
#error "Unsupported FreeBSD flavor"
#endif
@@ -57,9 +57,9 @@
#define FACTOR_OS_STRING "openbsd"
#if defined(FACTOR_X86)
- #include "os-openbsd-x86.32.h"
+ #include "os-openbsd-x86.32.hpp"
#elif defined(FACTOR_AMD64)
- #include "os-openbsd-x86.64.h"
+ #include "os-openbsd-x86.64.hpp"
#else
#error "Unsupported OpenBSD flavor"
#endif
@@ -67,26 +67,26 @@
#define FACTOR_OS_STRING "netbsd"
#if defined(FACTOR_X86)
- #include "os-netbsd-x86.32.h"
+ #include "os-netbsd-x86.32.hpp"
#elif defined(FACTOR_AMD64)
- #include "os-netbsd-x86.64.h"
+ #include "os-netbsd-x86.64.hpp"
#else
#error "Unsupported NetBSD flavor"
#endif
- #include "os-netbsd.h"
+ #include "os-netbsd.hpp"
#elif defined(linux)
#define FACTOR_OS_STRING "linux"
- #include "os-linux.h"
+ #include "os-linux.hpp"
#if defined(FACTOR_X86)
- #include "os-linux-x86.32.h"
+ #include "os-linux-x86.32.hpp"
#elif defined(FACTOR_PPC)
- #include "os-linux-ppc.h"
+ #include "os-linux-ppc.hpp"
#elif defined(FACTOR_ARM)
- #include "os-linux-arm.h"
+ #include "os-linux-arm.hpp"
#elif defined(FACTOR_AMD64)
- #include "os-linux-x86.64.h"
+ #include "os-linux-x86.64.hpp"
#else
#error "Unsupported Linux flavor"
#endif
@@ -94,9 +94,9 @@
#define FACTOR_OS_STRING "solaris"
#if defined(FACTOR_X86)
- #include "os-solaris-x86.32.h"
+ #include "os-solaris-x86.32.hpp"
#elif defined(FACTOR_AMD64)
- #include "os-solaris-x86.64.h"
+ #include "os-solaris-x86.64.hpp"
#else
#error "Unsupported Solaris flavor"
#endif
@@ -108,15 +108,15 @@
#endif
#if defined(FACTOR_X86)
- #include "cpu-x86.32.h"
- #include "cpu-x86.h"
+ #include "cpu-x86.32.hpp"
+ #include "cpu-x86.hpp"
#elif defined(FACTOR_AMD64)
- #include "cpu-x86.64.h"
- #include "cpu-x86.h"
+ #include "cpu-x86.64.hpp"
+ #include "cpu-x86.hpp"
#elif defined(FACTOR_PPC)
- #include "cpu-ppc.h"
+ #include "cpu-ppc.hpp"
#elif defined(FACTOR_ARM)
- #include "cpu-arm.h"
+ #include "cpu-arm.hpp"
#else
#error "Unsupported CPU"
#endif
diff --git a/vm/primitives.c b/vm/primitives.cpp
similarity index 91%
rename from vm/primitives.c
rename to vm/primitives.cpp
index 80b672d9d2..08db684ff6 100755
--- a/vm/primitives.c
+++ b/vm/primitives.cpp
@@ -1,20 +1,21 @@
-#include "master.h"
+#include "master.hpp"
-void *primitives[] = {
+namespace factor
+{
+
+const primitive_type primitives[] = {
primitive_bignum_to_fixnum,
primitive_float_to_fixnum,
primitive_fixnum_to_bignum,
primitive_float_to_bignum,
primitive_fixnum_to_float,
primitive_bignum_to_float,
- primitive_from_fraction,
primitive_str_to_float,
primitive_float_to_str,
primitive_float_bits,
primitive_double_bits,
primitive_bits_float,
primitive_bits_double,
- primitive_from_rect,
primitive_fixnum_add,
primitive_fixnum_subtract,
primitive_fixnum_multiply,
@@ -144,5 +145,15 @@ void *primitives[] = {
primitive_clear_gc_stats,
primitive_jit_compile,
primitive_load_locals,
- primitive_check_datastack
+ primitive_check_datastack,
+ primitive_inline_cache_miss,
+ primitive_mega_cache_miss,
+ primitive_lookup_method,
+ primitive_reset_dispatch_stats,
+ primitive_dispatch_stats,
+ primitive_reset_inline_cache_stats,
+ primitive_inline_cache_stats,
+ primitive_optimized_p,
};
+
+}
diff --git a/vm/primitives.h b/vm/primitives.h
deleted file mode 100644
index 30e0a4af96..0000000000
--- a/vm/primitives.h
+++ /dev/null
@@ -1 +0,0 @@
-extern void *primitives[];
diff --git a/vm/primitives.hpp b/vm/primitives.hpp
new file mode 100644
index 0000000000..c520a67cc5
--- /dev/null
+++ b/vm/primitives.hpp
@@ -0,0 +1,9 @@
+namespace factor
+{
+
+extern "C" typedef void (*primitive_type)();
+extern const primitive_type primitives[];
+
+#define PRIMITIVE(name) extern "C" void primitive_##name()
+
+}
diff --git a/vm/profiler.c b/vm/profiler.c
deleted file mode 100755
index acafecdff5..0000000000
--- a/vm/profiler.c
+++ /dev/null
@@ -1,85 +0,0 @@
-#include "master.h"
-
-/* Allocates memory */
-F_CODE_BLOCK *compile_profiling_stub(F_WORD *word)
-{
- CELL literals = allot_array_2(tag_object(word),tag_object(word));
- REGISTER_ROOT(literals);
-
- F_ARRAY *quadruple = untag_object(userenv[JIT_PROFILING]);
-
- CELL code = array_nth(quadruple,0);
- REGISTER_ROOT(code);
-
- F_REL rel = (to_fixnum(array_nth(quadruple,1)) << 24)
- | (to_fixnum(array_nth(quadruple,2)) << 28)
- | (to_fixnum(array_nth(quadruple,3)) * compiled_code_format());
-
- F_BYTE_ARRAY *relocation = allot_byte_array(sizeof(F_REL));
- memcpy(relocation + 1,&rel,sizeof(F_REL));
-
- UNREGISTER_ROOT(code);
- UNREGISTER_ROOT(literals);
-
- return add_code_block(
- WORD_TYPE,
- untag_object(code),
- NULL, /* no labels */
- tag_object(relocation),
- literals);
-}
-
-/* Allocates memory */
-void update_word_xt(F_WORD *word)
-{
- if(profiling_p)
- {
- if(!word->profiling)
- {
- REGISTER_UNTAGGED(word);
- F_CODE_BLOCK *profiling = compile_profiling_stub(word);
- UNREGISTER_UNTAGGED(word);
- word->profiling = profiling;
- }
-
- word->xt = (XT)(word->profiling + 1);
- }
- else
- word->xt = (XT)(word->code + 1);
-}
-
-void set_profiling(bool profiling)
-{
- if(profiling == profiling_p)
- return;
-
- profiling_p = profiling;
-
- /* Push everything to tenured space so that we can heap scan
- and allocate profiling blocks if necessary */
- gc();
-
- CELL words = find_all_words();
-
- REGISTER_ROOT(words);
-
- CELL i;
- CELL length = array_capacity(untag_object(words));
- for(i = 0; i < length; i++)
- {
- F_WORD *word = untag_word(array_nth(untag_array(words),i));
- if(profiling)
- word->counter = tag_fixnum(0);
- update_word_xt(word);
- }
-
- UNREGISTER_ROOT(words);
-
- /* Update XTs in code heap */
- iterate_code_heap(relocate_code_block);
-}
-
-void primitive_profiling(void)
-{
- set_profiling(to_boolean(dpop()));
-}
diff --git a/vm/profiler.cpp b/vm/profiler.cpp
new file mode 100755
index 0000000000..9651e4a27e
--- /dev/null
+++ b/vm/profiler.cpp
@@ -0,0 +1,57 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+bool profiling_p;
+
+void init_profiler(void)
+{
+ profiling_p = false;
+}
+
+/* Allocates memory */
+code_block *compile_profiling_stub(cell word_)
+{
+ gc_root<word> word(word_);
+
+ jit jit(WORD_TYPE,word.value());
+ jit.emit_with(userenv[JIT_PROFILING],word.value());
+
+ return jit.to_code_block();
+}
+
+/* Allocates memory */
+static void set_profiling(bool profiling)
+{
+ if(profiling == profiling_p)
+ return;
+
+ profiling_p = profiling;
+
+ /* Push everything to tenured space so that we can heap scan
+ and allocate profiling blocks if necessary */
+ gc();
+
+ gc_root<array> words(find_all_words());
+
+ cell i;
+ cell length = array_capacity(words.untagged());
+ for(i = 0; i < length; i++)
+ {
+ tagged<word> word(array_nth(words.untagged(),i));
+ if(profiling)
+ word->counter = tag_fixnum(0);
+ update_word_xt(word.value());
+ }
+
+ /* Update XTs in code heap */
+ iterate_code_heap(relocate_code_block);
+}
+
+PRIMITIVE(profiling)
+{
+ set_profiling(to_boolean(dpop()));
+}
+
+}
diff --git a/vm/profiler.h b/vm/profiler.h
deleted file mode 100755
index 4a44ec3f36..0000000000
--- a/vm/profiler.h
+++ /dev/null
@@ -1,4 +0,0 @@
-bool profiling_p;
-void primitive_profiling(void);
-F_CODE_BLOCK *compile_profiling_stub(F_WORD *word);
-void update_word_xt(F_WORD *word);
diff --git a/vm/profiler.hpp b/vm/profiler.hpp
new file mode 100755
index 0000000000..00f3e8067b
--- /dev/null
+++ b/vm/profiler.hpp
@@ -0,0 +1,9 @@
+namespace factor
+{
+
+extern bool profiling_p;
+void init_profiler(void);
+code_block *compile_profiling_stub(cell word);
+PRIMITIVE(profiling);
+
+}
diff --git a/vm/quotations.c b/vm/quotations.c
deleted file mode 100755
index e18e6b6098..0000000000
--- a/vm/quotations.c
+++ /dev/null
@@ -1,544 +0,0 @@
-#include "master.h"
-
-/* Simple non-optimizing compiler.
-
-This is one of the two compilers implementing Factor; the second one is written
-in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
-
-The non-optimizing compiler compiles a quotation at a time by concatenating
-machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
-code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
-
-Calls to words and constant quotations (referenced by conditionals and dips)
-are direct jumps to machine code blocks. Literals are also referenced directly
-without going through the literal table.
-
-It actually does do a little bit of very simple optimization:
-
-1) Tail call optimization.
-
-2) If a quotation is determined to not call any other words (except for a few
-special words which are open-coded, see below), then no prolog/epilog is
-generated.
-
-3) When in tail position and immediately preceded by literal arguments, the
-'if' and 'dispatch' conditionals are generated inline, instead of as a call to
-the 'if' word.
-
-4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are
-open-coded as retain stack manipulation surrounding a subroutine call.
-
-5) When preceded by an array, calls to the 'declare' word are optimized out
-entirely. This word is only used by the optimizing compiler, and with the
-non-optimizing compiler it would otherwise just decrease performance to have to
-push the array and immediately drop it after.
-
-6) Sub-primitives are primitive words which are implemented in assembly and not
-in the VM. They are open-coded and no subroutine call is generated. This
-includes stack shufflers, some fixnum arithmetic words, and words such as tag,
-slot and eq?. A primitive call is relatively expensive (two subroutine calls)
-so this results in a big speedup for relatively little effort. */
-
-bool jit_primitive_call_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) == array_capacity(array)
- && type_of(array_nth(array,i)) == FIXNUM_TYPE
- && array_nth(array,i + 1) == userenv[JIT_PRIMITIVE_WORD];
-}
-
-bool jit_fast_if_p(F_ARRAY *array, CELL i)
-{
- return (i + 3) == array_capacity(array)
- && type_of(array_nth(array,i)) == QUOTATION_TYPE
- && type_of(array_nth(array,i + 1)) == QUOTATION_TYPE
- && array_nth(array,i + 2) == userenv[JIT_IF_WORD];
-}
-
-bool jit_fast_dispatch_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) == array_capacity(array)
- && type_of(array_nth(array,i)) == ARRAY_TYPE
- && array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD];
-}
-
-bool jit_fast_dip_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) <= array_capacity(array)
- && type_of(array_nth(array,i)) == QUOTATION_TYPE
- && array_nth(array,i + 1) == userenv[JIT_DIP_WORD];
-}
-
-bool jit_fast_2dip_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) <= array_capacity(array)
- && type_of(array_nth(array,i)) == QUOTATION_TYPE
- && array_nth(array,i + 1) == userenv[JIT_2DIP_WORD];
-}
-
-bool jit_fast_3dip_p(F_ARRAY *array, CELL i)
-{
- return (i + 2) <= array_capacity(array)
- && type_of(array_nth(array,i)) == QUOTATION_TYPE
- && array_nth(array,i + 1) == userenv[JIT_3DIP_WORD];
-}
-
-bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
-{
- return (i + 1) < array_capacity(array)
- && type_of(array_nth(array,i)) == ARRAY_TYPE
- && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
-}
-
-F_ARRAY *code_to_emit(CELL code)
-{
- return untag_object(array_nth(untag_object(code),0));
-}
-
-F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length, bool *rel_p)
-{
- F_ARRAY *quadruple = untag_object(code);
- CELL rel_class = array_nth(quadruple,1);
- CELL rel_type = array_nth(quadruple,2);
- CELL offset = array_nth(quadruple,3);
-
- if(rel_class == F)
- {
- *rel_p = false;
- return 0;
- }
- else
- {
- *rel_p = true;
- return (to_fixnum(rel_type) << 28)
- | (to_fixnum(rel_class) << 24)
- | ((code_length + to_fixnum(offset)) * code_format);
- }
-}
-
-#define EMIT(name) { \
- bool rel_p; \
- F_REL rel = rel_to_emit(name,code_format,code_count,&rel_p); \
- if(rel_p) GROWABLE_BYTE_ARRAY_APPEND(relocation,&rel,sizeof(F_REL)); \
- GROWABLE_ARRAY_APPEND(code,code_to_emit(name)); \
- }
-
-bool jit_stack_frame_p(F_ARRAY *array)
-{
- F_FIXNUM length = array_capacity(array);
- F_FIXNUM i;
-
- for(i = 0; i < length - 1; i++)
- {
- CELL obj = array_nth(array,i);
- if(type_of(obj) == WORD_TYPE)
- {
- F_WORD *word = untag_object(obj);
- if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD])
- return true;
- }
- else if(type_of(obj) == QUOTATION_TYPE)
- {
- if(jit_fast_dip_p(array,i)
- || jit_fast_2dip_p(array,i)
- || jit_fast_3dip_p(array,i))
- return true;
- }
- }
-
- return false;
-}
-
-void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code)
-{
- if(code->block.type != QUOTATION_TYPE)
- critical_error("Bad param to set_quot_xt",(CELL)code);
-
- quot->code = code;
- quot->xt = (XT)(code + 1);
- quot->compiledp = T;
-}
-
-/* Might GC */
-void jit_compile(CELL quot, bool relocate)
-{
- if(untag_quotation(quot)->compiledp != F)
- return;
-
- CELL code_format = compiled_code_format();
-
- REGISTER_ROOT(quot);
-
- CELL array = untag_quotation(quot)->array;
- REGISTER_ROOT(array);
-
- GROWABLE_ARRAY(code);
- REGISTER_ROOT(code);
-
- GROWABLE_BYTE_ARRAY(relocation);
- REGISTER_ROOT(relocation);
-
- GROWABLE_ARRAY(literals);
- REGISTER_ROOT(literals);
-
- if(stack_traces_p())
- GROWABLE_ARRAY_ADD(literals,quot);
-
- bool stack_frame = jit_stack_frame_p(untag_object(array));
-
- if(stack_frame)
- EMIT(userenv[JIT_PROLOG]);
-
- CELL i;
- CELL length = array_capacity(untag_object(array));
- bool tail_call = false;
-
- for(i = 0; i < length; i++)
- {
- CELL obj = array_nth(untag_object(array),i);
- F_WORD *word;
- F_WRAPPER *wrapper;
-
- switch(type_of(obj))
- {
- case WORD_TYPE:
- word = untag_object(obj);
-
- /* Intrinsics */
- if(word->subprimitive != F)
- {
- if(array_nth(untag_object(word->subprimitive),1) != F)
- {
- GROWABLE_ARRAY_ADD(literals,T);
- }
-
- EMIT(word->subprimitive);
- }
- else
- {
- GROWABLE_ARRAY_ADD(literals,obj);
-
- if(i == length - 1)
- {
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
-
- EMIT(userenv[JIT_WORD_JUMP]);
-
- tail_call = true;
- }
- else
- EMIT(userenv[JIT_WORD_CALL]);
- }
- break;
- case WRAPPER_TYPE:
- wrapper = untag_object(obj);
- GROWABLE_ARRAY_ADD(literals,wrapper->object);
- EMIT(userenv[JIT_PUSH_IMMEDIATE]);
- break;
- case FIXNUM_TYPE:
- if(jit_primitive_call_p(untag_object(array),i))
- {
- EMIT(userenv[JIT_SAVE_STACK]);
- GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(userenv[JIT_PRIMITIVE]);
-
- i++;
-
- tail_call = true;
- break;
- }
- case QUOTATION_TYPE:
- if(jit_fast_if_p(untag_object(array),i))
- {
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
-
- jit_compile(array_nth(untag_object(array),i),relocate);
- jit_compile(array_nth(untag_object(array),i + 1),relocate);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_IF_1]);
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
- EMIT(userenv[JIT_IF_2]);
-
- i += 2;
-
- tail_call = true;
- break;
- }
- else if(jit_fast_dip_p(untag_object(array),i))
- {
- jit_compile(obj,relocate);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_DIP]);
-
- i++;
- break;
- }
- else if(jit_fast_2dip_p(untag_object(array),i))
- {
- jit_compile(obj,relocate);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_2DIP]);
-
- i++;
- break;
- }
- else if(jit_fast_3dip_p(untag_object(array),i))
- {
- jit_compile(obj,relocate);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_3DIP]);
-
- i++;
- break;
- }
- case ARRAY_TYPE:
- if(jit_fast_dispatch_p(untag_object(array),i))
- {
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
-
- GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
- EMIT(userenv[JIT_DISPATCH]);
-
- i++;
-
- tail_call = true;
- break;
- }
- else if(jit_ignore_declare_p(untag_object(array),i))
- {
- i++;
- break;
- }
- default:
- GROWABLE_ARRAY_ADD(literals,obj);
- EMIT(userenv[JIT_PUSH_IMMEDIATE]);
- break;
- }
- }
-
- if(!tail_call)
- {
- if(stack_frame)
- EMIT(userenv[JIT_EPILOG]);
-
- EMIT(userenv[JIT_RETURN]);
- }
-
- GROWABLE_ARRAY_TRIM(code);
- GROWABLE_ARRAY_TRIM(literals);
- GROWABLE_BYTE_ARRAY_TRIM(relocation);
-
- F_CODE_BLOCK *compiled = add_code_block(
- QUOTATION_TYPE,
- untag_object(code),
- NULL,
- relocation,
- literals);
-
- set_quot_xt(untag_object(quot),compiled);
-
- if(relocate)
- relocate_code_block(compiled);
-
- UNREGISTER_ROOT(literals);
- UNREGISTER_ROOT(relocation);
- UNREGISTER_ROOT(code);
- UNREGISTER_ROOT(array);
- UNREGISTER_ROOT(quot);
-}
-
-/* Crappy code duplication. If C had closures (not just function pointers)
-it would be easy to get rid of, but I can't think of a good way to deal
-with it right now that doesn't involve lots of boilerplate that would be
-worse than the duplication itself (eg, putting all state in some global
-struct.) */
-#define COUNT(name,scan) \
- { \
- CELL size = array_capacity(code_to_emit(name)) * code_format; \
- if(offset == 0) return scan - 1; \
- if(offset < size) return scan + 1; \
- offset -= size; \
- }
-
-F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
-{
- CELL code_format = compiled_code_format();
-
- CELL array = untag_quotation(quot)->array;
-
- bool stack_frame = jit_stack_frame_p(untag_object(array));
-
- if(stack_frame)
- COUNT(userenv[JIT_PROLOG],0)
-
- CELL i;
- CELL length = array_capacity(untag_object(array));
- bool tail_call = false;
-
- for(i = 0; i < length; i++)
- {
- CELL obj = array_nth(untag_object(array),i);
- F_WORD *word;
-
- switch(type_of(obj))
- {
- case WORD_TYPE:
- /* Intrinsics */
- word = untag_object(obj);
- if(word->subprimitive != F)
- COUNT(word->subprimitive,i)
- else if(i == length - 1)
- {
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],i);
-
- COUNT(userenv[JIT_WORD_JUMP],i)
-
- tail_call = true;
- }
- else
- COUNT(userenv[JIT_WORD_CALL],i)
- break;
- case WRAPPER_TYPE:
- COUNT(userenv[JIT_PUSH_IMMEDIATE],i)
- break;
- case FIXNUM_TYPE:
- if(jit_primitive_call_p(untag_object(array),i))
- {
- COUNT(userenv[JIT_SAVE_STACK],i);
- COUNT(userenv[JIT_PRIMITIVE],i);
-
- i++;
-
- tail_call = true;
- break;
- }
- case QUOTATION_TYPE:
- if(jit_fast_if_p(untag_object(array),i))
- {
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],i)
-
- COUNT(userenv[JIT_IF_1],i)
- COUNT(userenv[JIT_IF_2],i)
- i += 2;
-
- tail_call = true;
- break;
- }
- else if(jit_fast_dip_p(untag_object(array),i))
- {
- COUNT(userenv[JIT_DIP],i)
- i++;
- break;
- }
- else if(jit_fast_2dip_p(untag_object(array),i))
- {
- COUNT(userenv[JIT_2DIP],i)
- i++;
- break;
- }
- else if(jit_fast_3dip_p(untag_object(array),i))
- {
- COUNT(userenv[JIT_3DIP],i)
- i++;
- break;
- }
- case ARRAY_TYPE:
- if(jit_fast_dispatch_p(untag_object(array),i))
- {
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],i)
-
- i++;
-
- COUNT(userenv[JIT_DISPATCH],i)
-
- tail_call = true;
- break;
- }
- if(jit_ignore_declare_p(untag_object(array),i))
- {
- if(offset == 0) return i;
-
- i++;
-
- break;
- }
- default:
- COUNT(userenv[JIT_PUSH_IMMEDIATE],i)
- break;
- }
- }
-
- if(!tail_call)
- {
- if(stack_frame)
- COUNT(userenv[JIT_EPILOG],length)
-
- COUNT(userenv[JIT_RETURN],length)
- }
-
- return -1;
-}
-
-F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack)
-{
- stack_chain->callstack_top = stack;
- REGISTER_ROOT(quot);
- jit_compile(quot,true);
- UNREGISTER_ROOT(quot);
- return quot;
-}
-
-void primitive_jit_compile(void)
-{
- jit_compile(dpop(),true);
-}
-
-/* push a new quotation on the stack */
-void primitive_array_to_quotation(void)
-{
- F_QUOTATION *quot = allot_object(QUOTATION_TYPE,sizeof(F_QUOTATION));
- quot->array = dpeek();
- quot->xt = lazy_jit_compile;
- quot->compiledp = F;
- quot->cached_effect = F;
- quot->cache_counter = F;
- drepl(tag_object(quot));
-}
-
-void primitive_quotation_xt(void)
-{
- F_QUOTATION *quot = untag_quotation(dpeek());
- drepl(allot_cell((CELL)quot->xt));
-}
-
-void compile_all_words(void)
-{
- CELL words = find_all_words();
-
- REGISTER_ROOT(words);
-
- CELL i;
- CELL length = array_capacity(untag_object(words));
- for(i = 0; i < length; i++)
- {
- F_WORD *word = untag_word(array_nth(untag_array(words),i));
- REGISTER_UNTAGGED(word);
- if(word->optimizedp == F)
- default_word_code(word,false);
- UNREGISTER_UNTAGGED(word);
- update_word_xt(word);
- }
-
- UNREGISTER_ROOT(words);
-
- iterate_code_heap(relocate_code_block);
-}
diff --git a/vm/quotations.cpp b/vm/quotations.cpp
new file mode 100755
index 0000000000..c87cf8dc82
--- /dev/null
+++ b/vm/quotations.cpp
@@ -0,0 +1,341 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Simple non-optimizing compiler.
+
+This is one of the two compilers implementing Factor; the second one is written
+in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
+
+The non-optimizing compiler compiles a quotation at a time by concatenating
+machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
+code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
+
+Calls to words and constant quotations (referenced by conditionals and dips)
+are direct jumps to machine code blocks. Literals are also referenced directly
+without going through the literal table.
+
+It actually does do a little bit of very simple optimization:
+
+1) Tail call optimization.
+
+2) If a quotation is determined to not call any other words (except for a few
+special words which are open-coded, see below), then no prolog/epilog is
+generated.
+
+3) When in tail position and immediately preceded by literal arguments, the
+'if' is generated inline, instead of as a call to the 'if' word.
+
+4) When preceded by a quotation, calls to 'dip', '2dip' and '3dip' are
+open-coded as retain stack manipulation surrounding a subroutine call.
+
+5) Sub-primitives are primitive words which are implemented in assembly and not
+in the VM. They are open-coded and no subroutine call is generated. This
+includes stack shufflers, some fixnum arithmetic words, and words such as tag,
+slot and eq?. A primitive call is relatively expensive (two subroutine calls)
+so this results in a big speedup for relatively little effort. */
+
+bool quotation_jit::primitive_call_p(cell i)
+{
+ return (i + 2) == array_capacity(elements.untagged())
+ && tagged<object>(array_nth(elements.untagged(),i)).type_p(FIXNUM_TYPE)
+ && array_nth(elements.untagged(),i + 1) == userenv[JIT_PRIMITIVE_WORD];
+}
+
+bool quotation_jit::fast_if_p(cell i)
+{
+ return (i + 3) == array_capacity(elements.untagged())
+ && tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
+ && tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
+ && array_nth(elements.untagged(),i + 2) == userenv[JIT_IF_WORD];
+}
+
+bool quotation_jit::fast_dip_p(cell i)
+{
+ return (i + 2) <= array_capacity(elements.untagged())
+ && tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
+ && array_nth(elements.untagged(),i + 1) == userenv[JIT_DIP_WORD];
+}
+
+bool quotation_jit::fast_2dip_p(cell i)
+{
+ return (i + 2) <= array_capacity(elements.untagged())
+ && tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
+ && array_nth(elements.untagged(),i + 1) == userenv[JIT_2DIP_WORD];
+}
+
+bool quotation_jit::fast_3dip_p(cell i)
+{
+ return (i + 2) <= array_capacity(elements.untagged())
+ && tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
+ && array_nth(elements.untagged(),i + 1) == userenv[JIT_3DIP_WORD];
+}
+
+bool quotation_jit::mega_lookup_p(cell i)
+{
+ return (i + 3) < array_capacity(elements.untagged())
+ && tagged<object>(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE)
+ && tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
+ && tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
+ && array_nth(elements.untagged(),i + 3) == userenv[MEGA_LOOKUP_WORD];
+}
+
+bool quotation_jit::stack_frame_p()
+{
+ fixnum length = array_capacity(elements.untagged());
+ fixnum i;
+
+ for(i = 0; i < length - 1; i++)
+ {
+ cell obj = array_nth(elements.untagged(),i);
+ switch(tagged<object>(obj).type())
+ {
+ case WORD_TYPE:
+ if(untag<word>(obj)->subprimitive == F)
+ return true;
+ break;
+ case QUOTATION_TYPE:
+ if(fast_dip_p(i) || fast_2dip_p(i) || fast_3dip_p(i))
+ return true;
+ break;
+ default:
+ break;
+ }
+ }
+
+ return false;
+}
+
+/* Allocates memory */
+void quotation_jit::iterate_quotation()
+{
+ bool stack_frame = stack_frame_p();
+
+ set_position(0);
+
+ if(stack_frame)
+ emit(userenv[JIT_PROLOG]);
+
+ cell i;
+ cell length = array_capacity(elements.untagged());
+ bool tail_call = false;
+
+ for(i = 0; i < length; i++)
+ {
+ set_position(i);
+
+ gc_root<object> obj(array_nth(elements.untagged(),i));
+
+ switch(obj.type())
+ {
+ case WORD_TYPE:
+ /* Intrinsics */
+ if(obj.as<word>()->subprimitive != F)
+ emit_subprimitive(obj.value());
+ /* The (execute) primitive is special-cased */
+ else if(obj.value() == userenv[JIT_EXECUTE_WORD])
+ {
+ if(i == length - 1)
+ {
+ if(stack_frame) emit(userenv[JIT_EPILOG]);
+ tail_call = true;
+ emit(userenv[JIT_EXECUTE_JUMP]);
+ }
+ else
+ emit(userenv[JIT_EXECUTE_CALL]);
+ }
+ /* Everything else */
+ else
+ {
+ if(i == length - 1)
+ {
+ if(stack_frame) emit(userenv[JIT_EPILOG]);
+ tail_call = true;
+ word_jump(obj.value());
+ }
+ else
+ word_call(obj.value());
+ }
+ break;
+ case WRAPPER_TYPE:
+ push(obj.as<wrapper>()->object);
+ break;
+ case FIXNUM_TYPE:
+ /* Primitive calls */
+ if(primitive_call_p(i))
+ {
+ emit(userenv[JIT_SAVE_STACK]);
+ emit_with(userenv[JIT_PRIMITIVE],obj.value());
+
+ i++;
+
+ tail_call = true;
+ break;
+ }
+ case QUOTATION_TYPE:
+ /* 'if' preceeded by two literal quotations (this is why if and ? are
+ mutually recursive in the library, but both still work) */
+ if(fast_if_p(i))
+ {
+ if(stack_frame) emit(userenv[JIT_EPILOG]);
+ tail_call = true;
+
+ if(compiling)
+ {
+ jit_compile(array_nth(elements.untagged(),i),relocate);
+ jit_compile(array_nth(elements.untagged(),i + 1),relocate);
+ }
+
+ emit_with(userenv[JIT_IF_1],array_nth(elements.untagged(),i));
+ emit_with(userenv[JIT_IF_2],array_nth(elements.untagged(),i + 1));
+
+ i += 2;
+
+ break;
+ }
+ /* dip */
+ else if(fast_dip_p(i))
+ {
+ if(compiling)
+ jit_compile(obj.value(),relocate);
+ emit_with(userenv[JIT_DIP],obj.value());
+ i++;
+ break;
+ }
+ /* 2dip */
+ else if(fast_2dip_p(i))
+ {
+ if(compiling)
+ jit_compile(obj.value(),relocate);
+ emit_with(userenv[JIT_2DIP],obj.value());
+ i++;
+ break;
+ }
+ /* 3dip */
+ else if(fast_3dip_p(i))
+ {
+ if(compiling)
+ jit_compile(obj.value(),relocate);
+ emit_with(userenv[JIT_3DIP],obj.value());
+ i++;
+ break;
+ }
+ case ARRAY_TYPE:
+ /* Method dispatch */
+ if(mega_lookup_p(i))
+ {
+ emit_mega_cache_lookup(
+ array_nth(elements.untagged(),i),
+ untag_fixnum(array_nth(elements.untagged(),i + 1)),
+ array_nth(elements.untagged(),i + 2));
+ i += 3;
+ tail_call = true;
+ break;
+ }
+ default:
+ push(obj.value());
+ break;
+ }
+ }
+
+ if(!tail_call)
+ {
+ set_position(length);
+
+ if(stack_frame)
+ emit(userenv[JIT_EPILOG]);
+ emit(userenv[JIT_RETURN]);
+ }
+}
+
+void set_quot_xt(quotation *quot, code_block *code)
+{
+ if(code->block.type != QUOTATION_TYPE)
+ critical_error("Bad param to set_quot_xt",(cell)code);
+
+ quot->code = code;
+ quot->xt = code->xt();
+ quot->compiledp = T;
+}
+
+/* Allocates memory */
+void jit_compile(cell quot_, bool relocating)
+{
+ gc_root<quotation> quot(quot_);
+ if(quot->compiledp != F) return;
+
+ quotation_jit compiler(quot.value(),true,relocating);
+ compiler.iterate_quotation();
+
+ code_block *compiled = compiler.to_code_block();
+ set_quot_xt(quot.untagged(),compiled);
+
+ if(relocating) relocate_code_block(compiled);
+}
+
+PRIMITIVE(jit_compile)
+{
+ jit_compile(dpop(),true);
+}
+
+/* push a new quotation on the stack */
+PRIMITIVE(array_to_quotation)
+{
+ quotation *quot = allot<quotation>(sizeof(quotation));
+ quot->array = dpeek();
+ quot->xt = (void *)lazy_jit_compile;
+ quot->compiledp = F;
+ quot->cached_effect = F;
+ quot->cache_counter = F;
+ drepl(tag<quotation>(quot));
+}
+
+PRIMITIVE(quotation_xt)
+{
+ quotation *quot = untag_check<quotation>(dpeek());
+ drepl(allot_cell((cell)quot->xt));
+}
+
+void compile_all_words(void)
+{
+ gc_root<array> words(find_all_words());
+
+ cell i;
+ cell length = array_capacity(words.untagged());
+ for(i = 0; i < length; i++)
+ {
+ gc_root<word> word(array_nth(words.untagged(),i));
+
+ if(!word->code || !word_optimized_p(word.untagged()))
+ jit_compile_word(word.value(),word->def,false);
+
+ update_word_xt(word.value());
+
+ }
+
+ iterate_code_heap(relocate_code_block);
+}
+
+/* Allocates memory */
+fixnum quot_code_offset_to_scan(cell quot_, cell offset)
+{
+ gc_root<quotation> quot(quot_);
+ gc_root<array> array(quot->array);
+
+ quotation_jit compiler(quot.value(),false,false);
+ compiler.compute_position(offset);
+ compiler.iterate_quotation();
+
+ return compiler.get_position();
+}
+
+VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack)
+{
+ gc_root<quotation> quot(quot_);
+ stack_chain->callstack_top = stack;
+ jit_compile(quot.value(),true);
+ return quot.value();
+}
+
+}
diff --git a/vm/quotations.h b/vm/quotations.h
deleted file mode 100755
index d571a90ed6..0000000000
--- a/vm/quotations.h
+++ /dev/null
@@ -1,8 +0,0 @@
-void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code);
-void jit_compile(CELL quot, bool relocate);
-F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack);
-F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset);
-void primitive_array_to_quotation(void);
-void primitive_quotation_xt(void);
-void primitive_jit_compile(void);
-void compile_all_words(void);
diff --git a/vm/quotations.hpp b/vm/quotations.hpp
new file mode 100755
index 0000000000..a4545f3956
--- /dev/null
+++ b/vm/quotations.hpp
@@ -0,0 +1,38 @@
+namespace factor
+{
+
+struct quotation_jit : public jit {
+ gc_root<array> elements;
+ bool compiling, relocate;
+
+ quotation_jit(cell quot, bool compiling_, bool relocate_)
+ : jit(QUOTATION_TYPE,quot),
+ elements(owner.as<quotation>().untagged()->array),
+ compiling(compiling_),
+ relocate(relocate_) {};
+
+ void emit_mega_cache_lookup(cell methods, fixnum index, cell cache);
+ bool primitive_call_p(cell i);
+ bool fast_if_p(cell i);
+ bool fast_dip_p(cell i);
+ bool fast_2dip_p(cell i);
+ bool fast_3dip_p(cell i);
+ bool mega_lookup_p(cell i);
+ bool stack_frame_p();
+ void iterate_quotation();
+};
+
+void set_quot_xt(quotation *quot, code_block *code);
+void jit_compile(cell quot, bool relocate);
+fixnum quot_code_offset_to_scan(cell quot, cell offset);
+
+PRIMITIVE(jit_compile);
+
+void compile_all_words(void);
+
+PRIMITIVE(array_to_quotation);
+PRIMITIVE(quotation_xt);
+
+VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack);
+
+}
diff --git a/vm/run.c b/vm/run.c
deleted file mode 100755
index e55eb904a7..0000000000
--- a/vm/run.c
+++ /dev/null
@@ -1,226 +0,0 @@
-#include "master.h"
-
-void reset_datastack(void)
-{
- ds = ds_bot - CELLS;
-}
-
-void reset_retainstack(void)
-{
- rs = rs_bot - CELLS;
-}
-
-#define RESERVED (64 * CELLS)
-
-void fix_stacks(void)
-{
- if(ds + CELLS < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
- if(rs + CELLS < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
-}
-
-/* called before entry into foreign C code. Note that ds and rs might
-be stored in registers, so callbacks must save and restore the correct values */
-void save_stacks(void)
-{
- if(stack_chain)
- {
- stack_chain->datastack = ds;
- stack_chain->retainstack = rs;
- }
-}
-
-F_CONTEXT *alloc_context(void)
-{
- F_CONTEXT *context;
-
- if(unused_contexts)
- {
- context = unused_contexts;
- unused_contexts = unused_contexts->next;
- }
- else
- {
- context = safe_malloc(sizeof(F_CONTEXT));
- context->datastack_region = alloc_segment(ds_size);
- context->retainstack_region = alloc_segment(rs_size);
- }
-
- return context;
-}
-
-void dealloc_context(F_CONTEXT *context)
-{
- context->next = unused_contexts;
- unused_contexts = context;
-}
-
-/* called on entry into a compiled callback */
-void nest_stacks(void)
-{
- F_CONTEXT *new_stacks = alloc_context();
-
- new_stacks->callstack_bottom = (F_STACK_FRAME *)-1;
- new_stacks->callstack_top = (F_STACK_FRAME *)-1;
-
- /* note that these register values are not necessarily valid stack
- pointers. they are merely saved non-volatile registers, and are
- restored in unnest_stacks(). consider this scenario:
- - factor code calls C function
- - C function saves ds/cs registers (since they're non-volatile)
- - C function clobbers them
- - C function calls Factor callback
- - Factor callback returns
- - C function restores registers
- - C function returns to Factor code */
- new_stacks->datastack_save = ds;
- new_stacks->retainstack_save = rs;
-
- /* save per-callback userenv */
- new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
- new_stacks->catchstack_save = userenv[CATCHSTACK_ENV];
-
- new_stacks->next = stack_chain;
- stack_chain = new_stacks;
-
- reset_datastack();
- reset_retainstack();
-}
-
-/* called when leaving a compiled callback */
-void unnest_stacks(void)
-{
- ds = stack_chain->datastack_save;
- rs = stack_chain->retainstack_save;
-
- /* restore per-callback userenv */
- userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save;
- userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save;
-
- F_CONTEXT *old_stacks = stack_chain;
- stack_chain = old_stacks->next;
- dealloc_context(old_stacks);
-}
-
-/* called on startup */
-void init_stacks(CELL ds_size_, CELL rs_size_)
-{
- ds_size = ds_size_;
- rs_size = rs_size_;
- stack_chain = NULL;
- unused_contexts = NULL;
-}
-
-bool stack_to_array(CELL bottom, CELL top)
-{
- F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS);
-
- if(depth < 0)
- return false;
- else
- {
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS);
- memcpy(a + 1,(void*)bottom,depth);
- dpush(tag_object(a));
- return true;
- }
-}
-
-void primitive_datastack(void)
-{
- if(!stack_to_array(ds_bot,ds))
- general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
-}
-
-void primitive_retainstack(void)
-{
- if(!stack_to_array(rs_bot,rs))
- general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
-}
-
-/* returns pointer to top of stack */
-CELL array_to_stack(F_ARRAY *array, CELL bottom)
-{
- CELL depth = array_capacity(array) * CELLS;
- memcpy((void*)bottom,array + 1,depth);
- return bottom + depth - CELLS;
-}
-
-void primitive_set_datastack(void)
-{
- ds = array_to_stack(untag_array(dpop()),ds_bot);
-}
-
-void primitive_set_retainstack(void)
-{
- rs = array_to_stack(untag_array(dpop()),rs_bot);
-}
-
-/* Used to implement call( */
-void primitive_check_datastack(void)
-{
- F_FIXNUM out = to_fixnum(dpop());
- F_FIXNUM in = to_fixnum(dpop());
- F_FIXNUM height = out - in;
- F_ARRAY *array = untag_array(dpop());
- F_FIXNUM length = array_capacity(array);
- F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS;
- if(depth - height != length)
- dpush(F);
- else
- {
- F_FIXNUM i;
- for(i = 0; i < length - in; i++)
- {
- if(get(ds_bot + i * CELLS) != array_nth(array,i))
- {
- dpush(F);
- return;
- }
- }
- dpush(T);
- }
-}
-
-void primitive_getenv(void)
-{
- F_FIXNUM e = untag_fixnum_fast(dpeek());
- drepl(userenv[e]);
-}
-
-void primitive_setenv(void)
-{
- F_FIXNUM e = untag_fixnum_fast(dpop());
- CELL value = dpop();
- userenv[e] = value;
-}
-
-void primitive_exit(void)
-{
- exit(to_fixnum(dpop()));
-}
-
-void primitive_micros(void)
-{
- box_unsigned_8(current_micros());
-}
-
-void primitive_sleep(void)
-{
- sleep_micros(to_cell(dpop()));
-}
-
-void primitive_set_slot(void)
-{
- F_FIXNUM slot = untag_fixnum_fast(dpop());
- CELL obj = dpop();
- CELL value = dpop();
- set_slot(obj,slot,value);
-}
-
-void primitive_load_locals(void)
-{
- F_FIXNUM count = untag_fixnum_fast(dpop());
- memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count);
- ds -= CELLS * count;
- rs += CELLS * count;
-}
diff --git a/vm/run.cpp b/vm/run.cpp
new file mode 100755
index 0000000000..c6a4bad695
--- /dev/null
+++ b/vm/run.cpp
@@ -0,0 +1,76 @@
+#include "master.hpp"
+
+factor::cell userenv[USER_ENV];
+
+namespace factor
+{
+
+cell T;
+
+PRIMITIVE(getenv)
+{
+ fixnum e = untag_fixnum(dpeek());
+ drepl(userenv[e]);
+}
+
+PRIMITIVE(setenv)
+{
+ fixnum e = untag_fixnum(dpop());
+ cell value = dpop();
+ userenv[e] = value;
+}
+
+PRIMITIVE(exit)
+{
+ exit(to_fixnum(dpop()));
+}
+
+PRIMITIVE(micros)
+{
+ box_unsigned_8(current_micros());
+}
+
+PRIMITIVE(sleep)
+{
+ sleep_micros(to_cell(dpop()));
+}
+
+PRIMITIVE(set_slot)
+{
+ fixnum slot = untag_fixnum(dpop());
+ object *obj = untag<object>(dpop());
+ cell value = dpop();
+
+ obj->slots()[slot] = value;
+ write_barrier(obj);
+}
+
+PRIMITIVE(load_locals)
+{
+ fixnum count = untag_fixnum(dpop());
+ memcpy((cell *)(rs + sizeof(cell)),(cell *)(ds - sizeof(cell) * (count - 1)),sizeof(cell) * count);
+ ds -= sizeof(cell) * count;
+ rs += sizeof(cell) * count;
+}
+
+static cell clone_object(cell obj_)
+{
+ gc_root<object> obj(obj_);
+
+ if(immediate_p(obj.value()))
+ return obj.value();
+ else
+ {
+ cell size = object_size(obj.value());
+ object *new_obj = allot_object(obj.type(),size);
+ memcpy(new_obj,obj.untagged(),size);
+ return tag_dynamic(new_obj);
+ }
+}
+
+PRIMITIVE(clone)
+{
+ drepl(clone_object(dpeek()));
+}
+
+}
diff --git a/vm/run.h b/vm/run.h
deleted file mode 100755
index 2acff2cd5a..0000000000
--- a/vm/run.h
+++ /dev/null
@@ -1,255 +0,0 @@
-#define USER_ENV 70
-
-typedef enum {
- NAMESTACK_ENV, /* used by library only */
- CATCHSTACK_ENV, /* used by library only, per-callback */
-
- CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */
- WALKER_HOOK_ENV, /* non-local exit hook, used by library only */
- CALLCC_1_ENV, /* used to pass the value in callcc1 */
-
- BREAK_ENV = 5, /* quotation called by throw primitive */
- ERROR_ENV, /* a marker consed onto kernel errors */
-
- CELL_SIZE_ENV = 7, /* sizeof(CELL) */
- CPU_ENV, /* CPU architecture */
- OS_ENV, /* operating system name */
-
- ARGS_ENV = 10, /* command line arguments */
- STDIN_ENV, /* stdin FILE* handle */
- STDOUT_ENV, /* stdout FILE* handle */
-
- IMAGE_ENV = 13, /* image path name */
- EXECUTABLE_ENV, /* runtime executable path name */
-
- EMBEDDED_ENV = 15, /* are we embedded in another app? */
- EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */
- SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */
-
- COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */
-
- BOOT_ENV = 20, /* boot quotation */
- GLOBAL_ENV, /* global namespace */
-
- /* Used by the JIT compiler */
- JIT_CODE_FORMAT = 22,
- JIT_PROLOG,
- JIT_PRIMITIVE_WORD,
- JIT_PRIMITIVE,
- JIT_WORD_JUMP,
- JIT_WORD_CALL,
- JIT_IF_WORD,
- JIT_IF_1,
- JIT_IF_2,
- JIT_DISPATCH_WORD,
- JIT_DISPATCH,
- JIT_EPILOG,
- JIT_RETURN,
- JIT_PROFILING,
- JIT_PUSH_IMMEDIATE,
- JIT_DECLARE_WORD = 42,
- JIT_SAVE_STACK,
- JIT_DIP_WORD,
- JIT_DIP,
- JIT_2DIP_WORD,
- JIT_2DIP,
- JIT_3DIP_WORD,
- JIT_3DIP,
-
- STACK_TRACES_ENV = 59,
-
- UNDEFINED_ENV = 60, /* default quotation for undefined words */
-
- STDERR_ENV = 61, /* stderr FILE* handle */
-
- STAGE2_ENV = 62, /* have we bootstrapped? */
-
- CURRENT_THREAD_ENV = 63,
-
- THREADS_ENV = 64,
- RUN_QUEUE_ENV = 65,
- SLEEP_QUEUE_ENV = 66,
-} F_ENVTYPE;
-
-#define FIRST_SAVE_ENV BOOT_ENV
-#define LAST_SAVE_ENV STAGE2_ENV
-
-/* TAGGED user environment data; see getenv/setenv prims */
-DLLEXPORT CELL userenv[USER_ENV];
-
-/* macros for reading/writing memory, useful when working around
-C's type system */
-INLINE CELL get(CELL where)
-{
- return *((CELL*)where);
-}
-
-INLINE void put(CELL where, CELL what)
-{
- *((CELL*)where) = what;
-}
-
-INLINE CELL cget(CELL where)
-{
- return *((u16 *)where);
-}
-
-INLINE void cput(CELL where, CELL what)
-{
- *((u16 *)where) = what;
-}
-
-INLINE CELL bget(CELL where)
-{
- return *((u8 *)where);
-}
-
-INLINE void bput(CELL where, CELL what)
-{
- *((u8 *)where) = what;
-}
-
-INLINE CELL align(CELL a, CELL b)
-{
- return (a + (b-1)) & ~(b-1);
-}
-
-#define align8(a) align(a,8)
-#define align_page(a) align(a,getpagesize())
-
-/* Canonical T object. It's just a word */
-CELL T;
-
-INLINE CELL tag_header(CELL cell)
-{
- return cell << TAG_BITS;
-}
-
-INLINE CELL untag_header(CELL cell)
-{
- return cell >> TAG_BITS;
-}
-
-INLINE CELL tag_object(void* cell)
-{
- return RETAG(cell,OBJECT_TYPE);
-}
-
-INLINE CELL object_type(CELL tagged)
-{
- return untag_header(get(UNTAG(tagged)));
-}
-
-INLINE CELL type_of(CELL tagged)
-{
- CELL tag = TAG(tagged);
- if(tag == OBJECT_TYPE)
- return object_type(tagged);
- else
- return tag;
-}
-
-#define DEFPUSHPOP(prefix,ptr) \
- INLINE CELL prefix##pop(void) \
- { \
- CELL value = get(ptr); \
- ptr -= CELLS; \
- return value; \
- } \
- INLINE void prefix##push(CELL tagged) \
- { \
- ptr += CELLS; \
- put(ptr,tagged); \
- } \
- INLINE void prefix##repl(CELL tagged) \
- { \
- put(ptr,tagged); \
- } \
- INLINE CELL prefix##peek() \
- { \
- return get(ptr); \
- }
-
-DEFPUSHPOP(d,ds)
-DEFPUSHPOP(r,rs)
-
-typedef struct {
- CELL start;
- CELL size;
- CELL end;
-} F_SEGMENT;
-
-/* Assembly code makes assumptions about the layout of this struct:
- - callstack_top field is 0
- - callstack_bottom field is 1
- - datastack field is 2
- - retainstack field is 3 */
-typedef struct _F_CONTEXT {
- /* C stack pointer on entry */
- F_STACK_FRAME *callstack_top;
- F_STACK_FRAME *callstack_bottom;
-
- /* current datastack top pointer */
- CELL datastack;
-
- /* current retain stack top pointer */
- CELL retainstack;
-
- /* saved contents of ds register on entry to callback */
- CELL datastack_save;
-
- /* saved contents of rs register on entry to callback */
- CELL retainstack_save;
-
- /* memory region holding current datastack */
- F_SEGMENT *datastack_region;
-
- /* memory region holding current retain stack */
- F_SEGMENT *retainstack_region;
-
- /* saved userenv slots on entry to callback */
- CELL catchstack_save;
- CELL current_callback_save;
-
- struct _F_CONTEXT *next;
-} F_CONTEXT;
-
-DLLEXPORT F_CONTEXT *stack_chain;
-
-F_CONTEXT *unused_contexts;
-
-CELL ds_size, rs_size;
-
-#define ds_bot (stack_chain->datastack_region->start)
-#define ds_top (stack_chain->datastack_region->end)
-#define rs_bot (stack_chain->retainstack_region->start)
-#define rs_top (stack_chain->retainstack_region->end)
-
-void reset_datastack(void);
-void reset_retainstack(void);
-void fix_stacks(void);
-DLLEXPORT void save_stacks(void);
-DLLEXPORT void nest_stacks(void);
-DLLEXPORT void unnest_stacks(void);
-void init_stacks(CELL ds_size, CELL rs_size);
-
-void primitive_datastack(void);
-void primitive_retainstack(void);
-void primitive_set_datastack(void);
-void primitive_set_retainstack(void);
-void primitive_check_datastack(void);
-void primitive_getenv(void);
-void primitive_setenv(void);
-void primitive_exit(void);
-void primitive_os_env(void);
-void primitive_os_envs(void);
-void primitive_set_os_env(void);
-void primitive_unset_os_env(void);
-void primitive_set_os_envs(void);
-void primitive_micros(void);
-void primitive_sleep(void);
-void primitive_set_slot(void);
-void primitive_load_locals(void);
-
-bool stage2;
diff --git a/vm/run.hpp b/vm/run.hpp
new file mode 100755
index 0000000000..2204585fe5
--- /dev/null
+++ b/vm/run.hpp
@@ -0,0 +1,111 @@
+namespace factor
+{
+
+#define USER_ENV 70
+
+enum special_object {
+ NAMESTACK_ENV, /* used by library only */
+ CATCHSTACK_ENV, /* used by library only, per-callback */
+
+ CURRENT_CALLBACK_ENV = 2, /* used by library only, per-callback */
+ WALKER_HOOK_ENV, /* non-local exit hook, used by library only */
+ CALLCC_1_ENV, /* used to pass the value in callcc1 */
+
+ BREAK_ENV = 5, /* quotation called by throw primitive */
+ ERROR_ENV, /* a marker consed onto kernel errors */
+
+ cell_SIZE_ENV = 7, /* sizeof(cell) */
+ CPU_ENV, /* CPU architecture */
+ OS_ENV, /* operating system name */
+
+ ARGS_ENV = 10, /* command line arguments */
+ STDIN_ENV, /* stdin FILE* handle */
+ STDOUT_ENV, /* stdout FILE* handle */
+
+ IMAGE_ENV = 13, /* image path name */
+ EXECUTABLE_ENV, /* runtime executable path name */
+
+ EMBEDDED_ENV = 15, /* are we embedded in another app? */
+ EVAL_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+ YIELD_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+ SLEEP_CALLBACK_ENV, /* used when Factor is embedded in a C app */
+
+ COCOA_EXCEPTION_ENV = 19, /* Cocoa exception handler quotation */
+
+ BOOT_ENV = 20, /* boot quotation */
+ GLOBAL_ENV, /* global namespace */
+
+ /* Quotation compilation in quotations.c */
+ JIT_PROLOG = 23,
+ JIT_PRIMITIVE_WORD,
+ JIT_PRIMITIVE,
+ JIT_WORD_JUMP,
+ JIT_WORD_CALL,
+ JIT_IF_WORD,
+ JIT_IF_1,
+ JIT_IF_2,
+ JIT_EPILOG = 33,
+ JIT_RETURN,
+ JIT_PROFILING,
+ JIT_PUSH_IMMEDIATE,
+ JIT_SAVE_STACK = 38,
+ JIT_DIP_WORD,
+ JIT_DIP,
+ JIT_2DIP_WORD,
+ JIT_2DIP,
+ JIT_3DIP_WORD,
+ JIT_3DIP,
+ JIT_EXECUTE_WORD,
+ JIT_EXECUTE_JUMP,
+ JIT_EXECUTE_CALL,
+
+ /* Polymorphic inline cache generation in inline_cache.c */
+ PIC_LOAD = 48,
+ PIC_TAG,
+ PIC_HI_TAG,
+ PIC_TUPLE,
+ PIC_HI_TAG_TUPLE,
+ PIC_CHECK_TAG,
+ PIC_CHECK,
+ PIC_HIT,
+ PIC_MISS_WORD,
+
+ /* Megamorphic cache generation in dispatch.c */
+ MEGA_LOOKUP = 57,
+ MEGA_LOOKUP_WORD,
+ MEGA_MISS_WORD,
+
+ UNDEFINED_ENV = 60, /* default quotation for undefined words */
+
+ STDERR_ENV = 61, /* stderr FILE* handle */
+
+ STAGE2_ENV = 62, /* have we bootstrapped? */
+
+ CURRENT_THREAD_ENV = 63,
+
+ THREADS_ENV = 64,
+ RUN_QUEUE_ENV = 65,
+ SLEEP_QUEUE_ENV = 66,
+
+ STACK_TRACES_ENV = 67,
+};
+
+#define FIRST_SAVE_ENV BOOT_ENV
+#define LAST_SAVE_ENV STAGE2_ENV
+
+/* Canonical T object. It's just a word */
+extern cell T;
+
+PRIMITIVE(getenv);
+PRIMITIVE(setenv);
+PRIMITIVE(exit);
+PRIMITIVE(micros);
+PRIMITIVE(sleep);
+PRIMITIVE(set_slot);
+PRIMITIVE(load_locals);
+PRIMITIVE(clone);
+
+}
+
+/* TAGGED user environment data; see getenv/setenv prims */
+VM_C_API factor::cell userenv[USER_ENV];
diff --git a/vm/segments.hpp b/vm/segments.hpp
new file mode 100644
index 0000000000..a715b4dabc
--- /dev/null
+++ b/vm/segments.hpp
@@ -0,0 +1,10 @@
+namespace factor
+{
+
+struct segment {
+ cell start;
+ cell size;
+ cell end;
+};
+
+}
diff --git a/vm/stacks.hpp b/vm/stacks.hpp
new file mode 100644
index 0000000000..4af31e17d9
--- /dev/null
+++ b/vm/stacks.hpp
@@ -0,0 +1,19 @@
+namespace factor
+{
+
+#define DEFPUSHPOP(prefix,ptr) \
+ inline static cell prefix##peek() { return *(cell *)ptr; } \
+ inline static void prefix##repl(cell tagged) { *(cell *)ptr = tagged; } \
+ inline static cell prefix##pop(void) \
+ { \
+ cell value = prefix##peek(); \
+ ptr -= sizeof(cell); \
+ return value; \
+ } \
+ inline static void prefix##push(cell tagged) \
+ { \
+ ptr += sizeof(cell); \
+ prefix##repl(tagged); \
+ }
+
+}
diff --git a/vm/strings.cpp b/vm/strings.cpp
new file mode 100644
index 0000000000..c00c17bc45
--- /dev/null
+++ b/vm/strings.cpp
@@ -0,0 +1,186 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+cell string_nth(string* str, cell index)
+{
+ /* If high bit is set, the most significant 16 bits of the char
+ come from the aux vector. The least significant bit of the
+ corresponding aux vector entry is negated, so that we can
+ XOR the two components together and get the original code point
+ back. */
+ cell lo_bits = str->data()[index];
+
+ if((lo_bits & 0x80) == 0)
+ return lo_bits;
+ else
+ {
+ byte_array *aux = untag<byte_array>(str->aux);
+ cell hi_bits = aux->data<u16>()[index];
+ return (hi_bits << 7) ^ lo_bits;
+ }
+}
+
+void set_string_nth_fast(string *str, cell index, cell ch)
+{
+ str->data()[index] = ch;
+}
+
+void set_string_nth_slow(string *str_, cell index, cell ch)
+{
+ gc_root<string> str(str_);
+
+ byte_array *aux;
+
+ str->data()[index] = ((ch & 0x7f) | 0x80);
+
+ if(str->aux == F)
+ {
+ /* We don't need to pre-initialize the
+ byte array with any data, since we
+ only ever read from the aux vector
+ if the most significant bit of a
+ character is set. Initially all of
+ the bits are clear. */
+ aux = allot_array_internal<byte_array>(untag_fixnum(str->length) * sizeof(u16));
+
+ write_barrier(str.untagged());
+ str->aux = tag<byte_array>(aux);
+ }
+ else
+ aux = untag<byte_array>(str->aux);
+
+ aux->data<u16>()[index] = ((ch >> 7) ^ 1);
+}
+
+/* allocates memory */
+void set_string_nth(string *str, cell index, cell ch)
+{
+ if(ch <= 0x7f)
+ set_string_nth_fast(str,index,ch);
+ else
+ set_string_nth_slow(str,index,ch);
+}
+
+/* Allocates memory */
+string *allot_string_internal(cell capacity)
+{
+ string *str = allot<string>(string_size(capacity));
+
+ str->length = tag_fixnum(capacity);
+ str->hashcode = F;
+ str->aux = F;
+
+ return str;
+}
+
+/* Allocates memory */
+void fill_string(string *str_, cell start, cell capacity, cell fill)
+{
+ gc_root<string> str(str_);
+
+ if(fill <= 0x7f)
+ memset(&str->data()[start],fill,capacity - start);
+ else
+ {
+ cell i;
+
+ for(i = start; i < capacity; i++)
+ set_string_nth(str.untagged(),i,fill);
+ }
+}
+
+/* Allocates memory */
+string *allot_string(cell capacity, cell fill)
+{
+ gc_root<string> str(allot_string_internal(capacity));
+ fill_string(str.untagged(),0,capacity,fill);
+ return str.untagged();
+}
+
+PRIMITIVE(string)
+{
+ cell initial = to_cell(dpop());
+ cell length = unbox_array_size();
+ dpush(tag<string>(allot_string(length,initial)));
+}
+
+static bool reallot_string_in_place_p(string *str, cell capacity)
+{
+ return in_zone(&nursery,str) && capacity <= string_capacity(str);
+}
+
+string* reallot_string(string *str_, cell capacity)
+{
+ gc_root<string> str(str_);
+
+ if(reallot_string_in_place_p(str.untagged(),capacity))
+ {
+ str->length = tag_fixnum(capacity);
+
+ if(str->aux != F)
+ {
+ byte_array *aux = untag<byte_array>(str->aux);
+ aux->capacity = tag_fixnum(capacity * 2);
+ }
+
+ return str.untagged();
+ }
+ else
+ {
+ cell to_copy = string_capacity(str.untagged());
+ if(capacity < to_copy)
+ to_copy = capacity;
+
+ gc_root<string> new_str(allot_string_internal(capacity));
+
+ memcpy(new_str->data(),str->data(),to_copy);
+
+ if(str->aux != F)
+ {
+ byte_array *new_aux = allot_byte_array(capacity * sizeof(u16));
+
+ write_barrier(new_str.untagged());
+ new_str->aux = tag<byte_array>(new_aux);
+
+ byte_array *aux = untag<byte_array>(str->aux);
+ memcpy(new_aux->data<u16>(),aux->data<u16>(),to_copy * sizeof(u16));
+ }
+
+ fill_string(new_str.untagged(),to_copy,capacity,'\0');
+ return new_str.untagged();
+ }
+}
+
+PRIMITIVE(resize_string)
+{
+ string* str = untag_check<string>(dpop());
+ cell capacity = unbox_array_size();
+ dpush(tag<string>(reallot_string(str,capacity)));
+}
+
+PRIMITIVE(string_nth)
+{
+ string *str = untag<string>(dpop());
+ cell index = untag_fixnum(dpop());
+ dpush(tag_fixnum(string_nth(str,index)));
+}
+
+PRIMITIVE(set_string_nth_fast)
+{
+ string *str = untag<string>(dpop());
+ cell index = untag_fixnum(dpop());
+ cell value = untag_fixnum(dpop());
+ set_string_nth_fast(str,index,value);
+}
+
+PRIMITIVE(set_string_nth_slow)
+{
+ string *str = untag<string>(dpop());
+ cell index = untag_fixnum(dpop());
+ cell value = untag_fixnum(dpop());
+ set_string_nth_slow(str,index,value);
+}
+
+}
diff --git a/vm/strings.hpp b/vm/strings.hpp
new file mode 100644
index 0000000000..9a082b0b83
--- /dev/null
+++ b/vm/strings.hpp
@@ -0,0 +1,28 @@
+namespace factor
+{
+
+inline static cell string_capacity(string *str)
+{
+ return untag_fixnum(str->length);
+}
+
+inline static cell string_size(cell size)
+{
+ return sizeof(string) + size;
+}
+
+string* allot_string_internal(cell capacity);
+string* allot_string(cell capacity, cell fill);
+PRIMITIVE(string);
+string *reallot_string(string *string, cell capacity);
+PRIMITIVE(resize_string);
+
+/* String getters and setters */
+cell string_nth(string* string, cell index);
+void set_string_nth(string* string, cell index, cell value);
+
+PRIMITIVE(string_nth);
+PRIMITIVE(set_string_nth_slow);
+PRIMITIVE(set_string_nth_fast);
+
+}
diff --git a/vm/tagged.hpp b/vm/tagged.hpp
new file mode 100644
index 0000000000..ea1942e10c
--- /dev/null
+++ b/vm/tagged.hpp
@@ -0,0 +1,72 @@
+namespace factor
+{
+
+template <typename T> cell tag(T *value)
+{
+ return RETAG(value,tag_for(T::type_number));
+}
+
+inline static cell tag_dynamic(object *value)
+{
+ return RETAG(value,tag_for(value->h.hi_tag()));
+}
+
+template <typename T>
+struct tagged
+{
+ cell value_;
+
+ cell value() const { return value_; }
+ T *untagged() const { return (T *)(UNTAG(value_)); }
+
+ cell type() const {
+ cell tag = TAG(value_);
+ if(tag == OBJECT_TYPE)
+ return untagged()->h.hi_tag();
+ else
+ return tag;
+ }
+
+ bool type_p(cell type_) const { return type() == type_; }
+
+ T *untag_check() const {
+ if(T::type_number != TYPE_COUNT && !type_p(T::type_number))
+ type_error(T::type_number,value_);
+ return untagged();
+ }
+
+ explicit tagged(cell tagged) : value_(tagged) {
+#ifdef FACTOR_DEBUG
+ untag_check();
+#endif
+ }
+
+ explicit tagged(T *untagged) : value_(factor::tag(untagged)) {
+#ifdef FACTOR_DEBUG
+ untag_check();
+#endif
+ }
+
+ T *operator->() const { return untagged(); }
+ cell *operator&() const { return &value_; }
+
+ const tagged<T>& operator=(const T *x) { value_ = tag(x); return *this; }
+ const tagged<T>& operator=(const cell &x) { value_ = x; return *this; }
+
+ bool operator==(const tagged<T> &x) { return value_ == x.value_; }
+ bool operator!=(const tagged<T> &x) { return value_ != x.value_; }
+
+ template<typename X> tagged<X> as() { return tagged<X>(value_); }
+};
+
+template <typename T> T *untag_check(cell value)
+{
+ return tagged<T>(value).untag_check();
+}
+
+template <typename T> T *untag(cell value)
+{
+ return tagged<T>(value).untagged();
+}
+
+}
diff --git a/vm/tuples.cpp b/vm/tuples.cpp
new file mode 100644
index 0000000000..d7e22bb807
--- /dev/null
+++ b/vm/tuples.cpp
@@ -0,0 +1,37 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+/* push a new tuple on the stack */
+tuple *allot_tuple(cell layout_)
+{
+ gc_root<tuple_layout> layout(layout_);
+ gc_root<tuple> t(allot<tuple>(tuple_size(layout.untagged())));
+ t->layout = layout.value();
+ return t.untagged();
+}
+
+PRIMITIVE(tuple)
+{
+ gc_root<tuple_layout> layout(dpop());
+ tuple *t = allot_tuple(layout.value());
+ fixnum i;
+ for(i = tuple_size(layout.untagged()) - 1; i >= 0; i--)
+ t->data()[i] = F;
+
+ dpush(tag<tuple>(t));
+}
+
+/* push a new tuple on the stack, filling its slots from the stack */
+PRIMITIVE(tuple_boa)
+{
+ gc_root<tuple_layout> layout(dpop());
+ gc_root<tuple> t(allot_tuple(layout.value()));
+ cell size = untag_fixnum(layout.untagged()->size) * sizeof(cell);
+ memcpy(t->data(),(cell *)(ds - (size - sizeof(cell))),size);
+ ds -= size;
+ dpush(t.value());
+}
+
+}
diff --git a/vm/tuples.hpp b/vm/tuples.hpp
new file mode 100644
index 0000000000..831bb3bbac
--- /dev/null
+++ b/vm/tuples.hpp
@@ -0,0 +1,14 @@
+namespace factor
+{
+
+inline static cell tuple_size(tuple_layout *layout)
+{
+ cell size = untag_fixnum(layout->size);
+ return sizeof(tuple) + size * sizeof(cell);
+}
+
+PRIMITIVE(tuple);
+PRIMITIVE(tuple_boa);
+PRIMITIVE(tuple_layout);
+
+}
diff --git a/vm/types.c b/vm/types.c
deleted file mode 100755
index 119dc675bc..0000000000
--- a/vm/types.c
+++ /dev/null
@@ -1,608 +0,0 @@
-#include "master.h"
-
-/* FFI calls this */
-void box_boolean(bool value)
-{
- dpush(value ? T : F);
-}
-
-/* FFI calls this */
-bool to_boolean(CELL value)
-{
- return value != F;
-}
-
-CELL clone_object(CELL object)
-{
- CELL size = object_size(object);
- if(size == 0)
- return object;
- else
- {
- REGISTER_ROOT(object);
- void *new_obj = allot_object(type_of(object),size);
- UNREGISTER_ROOT(object);
-
- CELL tag = TAG(object);
- memcpy(new_obj,(void*)UNTAG(object),size);
- return RETAG(new_obj,tag);
- }
-}
-
-void primitive_clone(void)
-{
- drepl(clone_object(dpeek()));
-}
-
-F_WORD *allot_word(CELL vocab, CELL name)
-{
- REGISTER_ROOT(vocab);
- REGISTER_ROOT(name);
- F_WORD *word = allot_object(WORD_TYPE,sizeof(F_WORD));
- UNREGISTER_ROOT(name);
- UNREGISTER_ROOT(vocab);
-
- word->hashcode = tag_fixnum((rand() << 16) ^ rand());
- word->vocabulary = vocab;
- word->name = name;
- word->def = userenv[UNDEFINED_ENV];
- word->props = F;
- word->counter = tag_fixnum(0);
- word->optimizedp = F;
- word->subprimitive = F;
- word->profiling = NULL;
- word->code = NULL;
-
- REGISTER_UNTAGGED(word);
- default_word_code(word,true);
- UNREGISTER_UNTAGGED(word);
-
- REGISTER_UNTAGGED(word);
- update_word_xt(word);
- UNREGISTER_UNTAGGED(word);
-
- if(profiling_p)
- relocate_code_block(word->profiling);
-
- return word;
-}
-
-/* <word> ( name vocabulary -- word ) */
-void primitive_word(void)
-{
- CELL vocab = dpop();
- CELL name = dpop();
- dpush(tag_object(allot_word(vocab,name)));
-}
-
-/* word-xt ( word -- start end ) */
-void primitive_word_xt(void)
-{
- F_WORD *word = untag_word(dpop());
- F_CODE_BLOCK *code = (profiling_p ? word->profiling : word->code);
- dpush(allot_cell((CELL)code + sizeof(F_CODE_BLOCK)));
- dpush(allot_cell((CELL)code + code->block.size));
-}
-
-void primitive_wrapper(void)
-{
- F_WRAPPER *wrapper = allot_object(WRAPPER_TYPE,sizeof(F_WRAPPER));
- wrapper->object = dpeek();
- drepl(tag_object(wrapper));
-}
-
-/* Arrays */
-
-/* the array is full of undefined data, and must be correctly filled before the
-next GC. size is in cells */
-F_ARRAY *allot_array_internal(CELL type, CELL capacity)
-{
- F_ARRAY *array = allot_object(type,array_size(capacity));
- array->capacity = tag_fixnum(capacity);
- return array;
-}
-
-/* make a new array with an initial element */
-F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill)
-{
- int i;
- REGISTER_ROOT(fill);
- F_ARRAY* array = allot_array_internal(type, capacity);
- UNREGISTER_ROOT(fill);
- if(fill == 0)
- memset((void*)AREF(array,0),'\0',capacity * CELLS);
- else
- {
- /* No need for write barrier here. Either the object is in
- the nursery, or it was allocated directly in tenured space
- and the write barrier is already hit for us in that case. */
- for(i = 0; i < capacity; i++)
- put(AREF(array,i),fill);
- }
- return array;
-}
-
-/* push a new array on the stack */
-void primitive_array(void)
-{
- CELL initial = dpop();
- CELL size = unbox_array_size();
- dpush(tag_object(allot_array(ARRAY_TYPE,size,initial)));
-}
-
-CELL allot_array_1(CELL obj)
-{
- REGISTER_ROOT(obj);
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1);
- UNREGISTER_ROOT(obj);
- set_array_nth(a,0,obj);
- return tag_object(a);
-}
-
-CELL allot_array_2(CELL v1, CELL v2)
-{
- REGISTER_ROOT(v1);
- REGISTER_ROOT(v2);
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
- UNREGISTER_ROOT(v2);
- UNREGISTER_ROOT(v1);
- set_array_nth(a,0,v1);
- set_array_nth(a,1,v2);
- return tag_object(a);
-}
-
-CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
-{
- REGISTER_ROOT(v1);
- REGISTER_ROOT(v2);
- REGISTER_ROOT(v3);
- REGISTER_ROOT(v4);
- F_ARRAY *a = allot_array_internal(ARRAY_TYPE,4);
- UNREGISTER_ROOT(v4);
- UNREGISTER_ROOT(v3);
- UNREGISTER_ROOT(v2);
- UNREGISTER_ROOT(v1);
- set_array_nth(a,0,v1);
- set_array_nth(a,1,v2);
- set_array_nth(a,2,v3);
- set_array_nth(a,3,v4);
- return tag_object(a);
-}
-
-F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity)
-{
- CELL to_copy = array_capacity(array);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(array);
- F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity);
- UNREGISTER_UNTAGGED(array);
-
- memcpy(new_array + 1,array + 1,to_copy * CELLS);
- memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS);
-
- return new_array;
-}
-
-void primitive_resize_array(void)
-{
- F_ARRAY* array = untag_array(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_array(array,capacity)));
-}
-
-F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count)
-{
- REGISTER_ROOT(elt);
-
- if(*result_count == array_capacity(result))
- {
- result = reallot_array(result,*result_count * 2);
- }
-
- UNREGISTER_ROOT(elt);
- set_array_nth(result,*result_count,elt);
- (*result_count)++;
-
- return result;
-}
-
-F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
-{
- REGISTER_UNTAGGED(elts);
-
- CELL elts_size = array_capacity(elts);
- CELL new_size = *result_count + elts_size;
-
- if(new_size >= array_capacity(result))
- result = reallot_array(result,new_size * 2);
-
- UNREGISTER_UNTAGGED(elts);
-
- write_barrier((CELL)result);
-
- memcpy((void *)AREF(result,*result_count),(void *)AREF(elts,0),elts_size * CELLS);
-
- *result_count += elts_size;
-
- return result;
-}
-
-/* Byte arrays */
-
-/* must fill out array before next GC */
-F_BYTE_ARRAY *allot_byte_array_internal(CELL size)
-{
- F_BYTE_ARRAY *array = allot_object(BYTE_ARRAY_TYPE,
- byte_array_size(size));
- array->capacity = tag_fixnum(size);
- return array;
-}
-
-/* size is in bytes this time */
-F_BYTE_ARRAY *allot_byte_array(CELL size)
-{
- F_BYTE_ARRAY *array = allot_byte_array_internal(size);
- memset(array + 1,0,size);
- return array;
-}
-
-/* push a new byte array on the stack */
-void primitive_byte_array(void)
-{
- CELL size = unbox_array_size();
- dpush(tag_object(allot_byte_array(size)));
-}
-
-void primitive_uninitialized_byte_array(void)
-{
- CELL size = unbox_array_size();
- dpush(tag_object(allot_byte_array_internal(size)));
-}
-
-F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
-{
- CELL to_copy = array_capacity(array);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(array);
- F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity);
- UNREGISTER_UNTAGGED(array);
-
- memcpy(new_array + 1,array + 1,to_copy);
-
- return new_array;
-}
-
-void primitive_resize_byte_array(void)
-{
- F_BYTE_ARRAY* array = untag_byte_array(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_byte_array(array,capacity)));
-}
-
-F_BYTE_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count)
-{
- CELL new_size = *result_count + len;
-
- if(new_size >= byte_array_capacity(result))
- result = reallot_byte_array(result,new_size * 2);
-
- memcpy((void *)BREF(result,*result_count),elts,len);
-
- *result_count = new_size;
-
- return result;
-}
-
-/* Tuples */
-
-/* push a new tuple on the stack */
-F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout)
-{
- REGISTER_UNTAGGED(layout);
- F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout));
- UNREGISTER_UNTAGGED(layout);
- tuple->layout = tag_object(layout);
- return tuple;
-}
-
-void primitive_tuple(void)
-{
- F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = untag_fixnum_fast(layout->size);
-
- F_TUPLE *tuple = allot_tuple(layout);
- F_FIXNUM i;
- for(i = size - 1; i >= 0; i--)
- put(AREF(tuple,i),F);
-
- dpush(tag_tuple(tuple));
-}
-
-/* push a new tuple on the stack, filling its slots from the stack */
-void primitive_tuple_boa(void)
-{
- F_TUPLE_LAYOUT *layout = untag_object(dpop());
- F_FIXNUM size = untag_fixnum_fast(layout->size);
- F_TUPLE *tuple = allot_tuple(layout);
- memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
- ds -= CELLS * size;
- dpush(tag_tuple(tuple));
-}
-
-/* Strings */
-CELL string_nth(F_STRING* string, CELL index)
-{
- /* If high bit is set, the most significant 16 bits of the char
- come from the aux vector. The least significant bit of the
- corresponding aux vector entry is negated, so that we can
- XOR the two components together and get the original code point
- back. */
- CELL ch = bget(SREF(string,index));
- if((ch & 0x80) == 0)
- return ch;
- else
- {
- F_BYTE_ARRAY *aux = untag_object(string->aux);
- return (cget(BREF(aux,index * sizeof(u16))) << 7) ^ ch;
- }
-}
-
-void set_string_nth_fast(F_STRING* string, CELL index, CELL ch)
-{
- bput(SREF(string,index),ch);
-}
-
-void set_string_nth_slow(F_STRING* string, CELL index, CELL ch)
-{
- F_BYTE_ARRAY *aux;
-
- bput(SREF(string,index),(ch & 0x7f) | 0x80);
-
- if(string->aux == F)
- {
- REGISTER_UNTAGGED(string);
- /* We don't need to pre-initialize the
- byte array with any data, since we
- only ever read from the aux vector
- if the most significant bit of a
- character is set. Initially all of
- the bits are clear. */
- aux = allot_byte_array_internal(
- untag_fixnum_fast(string->length)
- * sizeof(u16));
- UNREGISTER_UNTAGGED(string);
-
- write_barrier((CELL)string);
- string->aux = tag_object(aux);
- }
- else
- aux = untag_object(string->aux);
-
- cput(BREF(aux,index * sizeof(u16)),(ch >> 7) ^ 1);
-}
-
-/* allocates memory */
-void set_string_nth(F_STRING* string, CELL index, CELL ch)
-{
- if(ch <= 0x7f)
- set_string_nth_fast(string,index,ch);
- else
- set_string_nth_slow(string,index,ch);
-}
-
-/* untagged */
-F_STRING* allot_string_internal(CELL capacity)
-{
- F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
-
- string->length = tag_fixnum(capacity);
- string->hashcode = F;
- string->aux = F;
-
- return string;
-}
-
-/* allocates memory */
-void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill)
-{
- if(fill <= 0x7f)
- memset((void *)SREF(string,start),fill,capacity - start);
- else
- {
- CELL i;
-
- for(i = start; i < capacity; i++)
- {
- REGISTER_UNTAGGED(string);
- set_string_nth(string,i,fill);
- UNREGISTER_UNTAGGED(string);
- }
- }
-}
-
-/* untagged */
-F_STRING *allot_string(CELL capacity, CELL fill)
-{
- F_STRING* string = allot_string_internal(capacity);
- REGISTER_UNTAGGED(string);
- fill_string(string,0,capacity,fill);
- UNREGISTER_UNTAGGED(string);
- return string;
-}
-
-void primitive_string(void)
-{
- CELL initial = to_cell(dpop());
- CELL length = unbox_array_size();
- dpush(tag_object(allot_string(length,initial)));
-}
-
-F_STRING* reallot_string(F_STRING* string, CELL capacity)
-{
- CELL to_copy = string_capacity(string);
- if(capacity < to_copy)
- to_copy = capacity;
-
- REGISTER_UNTAGGED(string);
- F_STRING *new_string = allot_string_internal(capacity);
- UNREGISTER_UNTAGGED(string);
-
- memcpy(new_string + 1,string + 1,to_copy);
-
- if(string->aux != F)
- {
- REGISTER_UNTAGGED(string);
- REGISTER_UNTAGGED(new_string);
- F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16));
- UNREGISTER_UNTAGGED(new_string);
- UNREGISTER_UNTAGGED(string);
-
- write_barrier((CELL)new_string);
- new_string->aux = tag_object(new_aux);
-
- F_BYTE_ARRAY *aux = untag_object(string->aux);
- memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16));
- }
-
- REGISTER_UNTAGGED(string);
- REGISTER_UNTAGGED(new_string);
- fill_string(new_string,to_copy,capacity,'\0');
- UNREGISTER_UNTAGGED(new_string);
- UNREGISTER_UNTAGGED(string);
-
- return new_string;
-}
-
-void primitive_resize_string(void)
-{
- F_STRING* string = untag_string(dpop());
- CELL capacity = unbox_array_size();
- dpush(tag_object(reallot_string(string,capacity)));
-}
-
-/* Some ugly macros to prevent a 2x code duplication */
-
-#define MEMORY_TO_STRING(type,utype) \
- F_STRING *memory_to_##type##_string(const type *string, CELL length) \
- { \
- REGISTER_C_STRING(string); \
- F_STRING* s = allot_string_internal(length); \
- UNREGISTER_C_STRING(string); \
- CELL i; \
- for(i = 0; i < length; i++) \
- { \
- REGISTER_UNTAGGED(s); \
- set_string_nth(s,i,(utype)*string); \
- UNREGISTER_UNTAGGED(s); \
- string++; \
- } \
- return s; \
- } \
- F_STRING *from_##type##_string(const type *str) \
- { \
- CELL length = 0; \
- const type *scan = str; \
- while(*scan++) length++; \
- return memory_to_##type##_string(str,length); \
- } \
- void box_##type##_string(const type *str) \
- { \
- dpush(str ? tag_object(from_##type##_string(str)) : F); \
- }
-
-MEMORY_TO_STRING(char,u8)
-MEMORY_TO_STRING(u16,u16)
-MEMORY_TO_STRING(u32,u32)
-
-bool check_string(F_STRING *s, CELL max)
-{
- CELL capacity = string_capacity(s);
- CELL i;
- for(i = 0; i < capacity; i++)
- {
- CELL ch = string_nth(s,i);
- if(ch == '\0' || ch >= (1 << (max * 8)))
- return false;
- }
- return true;
-}
-
-F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
-{
- return allot_byte_array((capacity + 1) * size);
-}
-
-#define STRING_TO_MEMORY(type) \
- void type##_string_to_memory(F_STRING *s, type *string) \
- { \
- CELL i; \
- CELL capacity = string_capacity(s); \
- for(i = 0; i < capacity; i++) \
- string[i] = string_nth(s,i); \
- } \
- void primitive_##type##_string_to_memory(void) \
- { \
- type *address = unbox_alien(); \
- F_STRING *str = untag_string(dpop()); \
- type##_string_to_memory(str,address); \
- } \
- F_BYTE_ARRAY *string_to_##type##_alien(F_STRING *s, bool check) \
- { \
- CELL capacity = string_capacity(s); \
- F_BYTE_ARRAY *_c_str; \
- if(check && !check_string(s,sizeof(type))) \
- general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
- REGISTER_UNTAGGED(s); \
- _c_str = allot_c_string(capacity,sizeof(type)); \
- UNREGISTER_UNTAGGED(s); \
- type *c_str = (type*)(_c_str + 1); \
- type##_string_to_memory(s,c_str); \
- c_str[capacity] = 0; \
- return _c_str; \
- } \
- type *to_##type##_string(F_STRING *s, bool check) \
- { \
- return (type*)(string_to_##type##_alien(s,check) + 1); \
- } \
- type *unbox_##type##_string(void) \
- { \
- return to_##type##_string(untag_string(dpop()),true); \
- }
-
-STRING_TO_MEMORY(char);
-STRING_TO_MEMORY(u16);
-
-void primitive_string_nth(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- dpush(tag_fixnum(string_nth(string,index)));
-}
-
-void primitive_set_string_nth(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth(string,index,value);
-}
-
-void primitive_set_string_nth_fast(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth_fast(string,index,value);
-}
-
-void primitive_set_string_nth_slow(void)
-{
- F_STRING *string = untag_object(dpop());
- CELL index = untag_fixnum_fast(dpop());
- CELL value = untag_fixnum_fast(dpop());
- set_string_nth_slow(string,index,value);
-}
diff --git a/vm/types.h b/vm/types.h
deleted file mode 100755
index 2775f57bb2..0000000000
--- a/vm/types.h
+++ /dev/null
@@ -1,196 +0,0 @@
-/* Inline functions */
-INLINE CELL array_size(CELL size)
-{
- return sizeof(F_ARRAY) + size * CELLS;
-}
-
-INLINE CELL string_capacity(F_STRING* str)
-{
- return untag_fixnum_fast(str->length);
-}
-
-INLINE CELL string_size(CELL size)
-{
- return sizeof(F_STRING) + size;
-}
-
-DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
-
-INLINE CELL byte_array_capacity(F_BYTE_ARRAY *array)
-{
- return untag_fixnum_fast(array->capacity);
-}
-
-INLINE CELL byte_array_size(CELL size)
-{
- return sizeof(F_BYTE_ARRAY) + size;
-}
-
-INLINE CELL callstack_size(CELL size)
-{
- return sizeof(F_CALLSTACK) + size;
-}
-
-DEFINE_UNTAG(F_CALLSTACK,CALLSTACK_TYPE,callstack)
-
-INLINE CELL tag_boolean(CELL untagged)
-{
- return (untagged == false ? F : T);
-}
-
-DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array)
-
-#define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
-#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
-
-INLINE CELL array_nth(F_ARRAY *array, CELL slot)
-{
- return get(AREF(array,slot));
-}
-
-INLINE void set_array_nth(F_ARRAY *array, CELL slot, CELL value)
-{
- put(AREF(array,slot),value);
- write_barrier((CELL)array);
-}
-
-INLINE CELL array_capacity(F_ARRAY* array)
-{
- return array->capacity >> TAG_BITS;
-}
-
-#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index))
-#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index))
-
-INLINE F_STRING* untag_string(CELL tagged)
-{
- type_check(STRING_TYPE,tagged);
- return untag_object(tagged);
-}
-
-DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation)
-
-DEFINE_UNTAG(F_WORD,WORD_TYPE,word)
-
-INLINE CELL tag_tuple(F_TUPLE *tuple)
-{
- return RETAG(tuple,TUPLE_TYPE);
-}
-
-INLINE F_TUPLE *untag_tuple(CELL object)
-{
- type_check(TUPLE_TYPE,object);
- return untag_object(object);
-}
-
-INLINE CELL tuple_size(F_TUPLE_LAYOUT *layout)
-{
- CELL size = untag_fixnum_fast(layout->size);
- return sizeof(F_TUPLE) + size * CELLS;
-}
-
-INLINE CELL tuple_nth(F_TUPLE *tuple, CELL slot)
-{
- return get(AREF(tuple,slot));
-}
-
-INLINE void set_tuple_nth(F_TUPLE *tuple, CELL slot, CELL value)
-{
- put(AREF(tuple,slot),value);
- write_barrier((CELL)tuple);
-}
-
-/* Prototypes */
-DLLEXPORT void box_boolean(bool value);
-DLLEXPORT bool to_boolean(CELL value);
-
-F_ARRAY *allot_array_internal(CELL type, CELL capacity);
-F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill);
-F_BYTE_ARRAY *allot_byte_array(CELL size);
-
-CELL allot_array_1(CELL obj);
-CELL allot_array_2(CELL v1, CELL v2);
-CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
-
-void primitive_array(void);
-void primitive_tuple(void);
-void primitive_tuple_boa(void);
-void primitive_tuple_layout(void);
-void primitive_byte_array(void);
-void primitive_uninitialized_byte_array(void);
-void primitive_clone(void);
-
-F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity);
-F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity);
-void primitive_resize_array(void);
-void primitive_resize_byte_array(void);
-
-F_STRING* allot_string_internal(CELL capacity);
-F_STRING* allot_string(CELL capacity, CELL fill);
-void primitive_uninitialized_string(void);
-void primitive_string(void);
-F_STRING *reallot_string(F_STRING *string, CELL capacity);
-void primitive_resize_string(void);
-
-F_STRING *memory_to_char_string(const char *string, CELL length);
-F_STRING *from_char_string(const char *c_string);
-DLLEXPORT void box_char_string(const char *c_string);
-
-F_STRING *memory_to_u16_string(const u16 *string, CELL length);
-F_STRING *from_u16_string(const u16 *c_string);
-DLLEXPORT void box_u16_string(const u16 *c_string);
-
-void char_string_to_memory(F_STRING *s, char *string);
-F_BYTE_ARRAY *string_to_char_alien(F_STRING *s, bool check);
-char* to_char_string(F_STRING *s, bool check);
-DLLEXPORT char *unbox_char_string(void);
-
-void u16_string_to_memory(F_STRING *s, u16 *string);
-F_BYTE_ARRAY *string_to_u16_alien(F_STRING *s, bool check);
-u16* to_u16_string(F_STRING *s, bool check);
-DLLEXPORT u16 *unbox_u16_string(void);
-
-/* String getters and setters */
-CELL string_nth(F_STRING* string, CELL index);
-void set_string_nth(F_STRING* string, CELL index, CELL value);
-
-void primitive_string_nth(void);
-void primitive_set_string_nth_slow(void);
-void primitive_set_string_nth_fast(void);
-
-F_WORD *allot_word(CELL vocab, CELL name);
-void primitive_word(void);
-void primitive_word_xt(void);
-
-void primitive_wrapper(void);
-
-/* Macros to simulate a vector in C */
-#define GROWABLE_ARRAY(result) \
- CELL result##_count = 0; \
- CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
-
-F_ARRAY *growable_array_add(F_ARRAY *result, CELL elt, CELL *result_count);
-
-#define GROWABLE_ARRAY_ADD(result,elt) \
- result = tag_object(growable_array_add(untag_object(result),elt,&result##_count))
-
-F_ARRAY *growable_array_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count);
-
-#define GROWABLE_ARRAY_APPEND(result,elts) \
- result = tag_object(growable_array_append(untag_object(result),elts,&result##_count))
-
-#define GROWABLE_ARRAY_TRIM(result) \
- result = tag_object(reallot_array(untag_object(result),result##_count))
-
-/* Macros to simulate a byte vector in C */
-#define GROWABLE_BYTE_ARRAY(result) \
- CELL result##_count = 0; \
- CELL result = tag_object(allot_byte_array(100))
-
-F_ARRAY *growable_byte_array_append(F_BYTE_ARRAY *result, void *elts, CELL len, CELL *result_count);
-
-#define GROWABLE_BYTE_ARRAY_APPEND(result,elts,len) \
- result = tag_object(growable_byte_array_append(untag_object(result),elts,len,&result##_count))
-
-#define GROWABLE_BYTE_ARRAY_TRIM(result) \
- result = tag_object(reallot_byte_array(untag_object(result),result##_count))
diff --git a/vm/utilities.c b/vm/utilities.cpp
similarity index 57%
rename from vm/utilities.c
rename to vm/utilities.cpp
index d97b540884..532de80ed1 100755
--- a/vm/utilities.c
+++ b/vm/utilities.cpp
@@ -1,4 +1,7 @@
-#include "master.h"
+#include "master.hpp"
+
+namespace factor
+{
/* If memory allocation fails, bail out */
void *safe_malloc(size_t size)
@@ -8,9 +11,9 @@ void *safe_malloc(size_t size)
return ptr;
}
-F_CHAR *safe_strdup(const F_CHAR *str)
+vm_char *safe_strdup(const vm_char *str)
{
- F_CHAR *ptr = STRDUP(str);
+ vm_char *ptr = STRDUP(str);
if(!ptr) fatal_error("Out of memory in safe_strdup", 0);
return ptr;
}
@@ -27,29 +30,31 @@ void print_string(const char *str)
fputs(str,stdout);
}
-void print_cell(CELL x)
+void print_cell(cell x)
{
- printf(CELL_FORMAT,x);
+ printf(cell_FORMAT,x);
}
-void print_cell_hex(CELL x)
+void print_cell_hex(cell x)
{
- printf(CELL_HEX_FORMAT,x);
+ printf(cell_HEX_FORMAT,x);
}
-void print_cell_hex_pad(CELL x)
+void print_cell_hex_pad(cell x)
{
- printf(CELL_HEX_PAD_FORMAT,x);
+ printf(cell_HEX_PAD_FORMAT,x);
}
-void print_fixnum(F_FIXNUM x)
+void print_fixnum(fixnum x)
{
printf(FIXNUM_FORMAT,x);
}
-CELL read_cell_hex(void)
+cell read_cell_hex(void)
{
- CELL cell;
- scanf(CELL_HEX_FORMAT,&cell);
+ cell cell;
+ if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1);
return cell;
};
+
+}
diff --git a/vm/utilities.h b/vm/utilities.h
deleted file mode 100755
index d2b3223ce4..0000000000
--- a/vm/utilities.h
+++ /dev/null
@@ -1,10 +0,0 @@
-void *safe_malloc(size_t size);
-F_CHAR *safe_strdup(const F_CHAR *str);
-
-void nl(void);
-void print_string(const char *str);
-void print_cell(CELL x);
-void print_cell_hex(CELL x);
-void print_cell_hex_pad(CELL x);
-void print_fixnum(F_FIXNUM x);
-CELL read_cell_hex(void);
diff --git a/vm/utilities.hpp b/vm/utilities.hpp
new file mode 100755
index 0000000000..d311b954ed
--- /dev/null
+++ b/vm/utilities.hpp
@@ -0,0 +1,15 @@
+namespace factor
+{
+
+void *safe_malloc(size_t size);
+vm_char *safe_strdup(const vm_char *str);
+
+void nl(void);
+void print_string(const char *str);
+void print_cell(cell x);
+void print_cell_hex(cell x);
+void print_cell_hex_pad(cell x);
+void print_fixnum(fixnum x);
+cell read_cell_hex(void);
+
+}
diff --git a/vm/words.cpp b/vm/words.cpp
new file mode 100644
index 0000000000..cb2fdf0dd6
--- /dev/null
+++ b/vm/words.cpp
@@ -0,0 +1,78 @@
+#include "master.hpp"
+
+namespace factor
+{
+
+word *allot_word(cell vocab_, cell name_)
+{
+ gc_root<object> vocab(vocab_);
+ gc_root<object> name(name_);
+
+ gc_root<word> new_word(allot<word>(sizeof(word)));
+
+ new_word->hashcode = tag_fixnum((rand() << 16) ^ rand());
+ new_word->vocabulary = vocab.value();
+ new_word->name = name.value();
+ new_word->def = userenv[UNDEFINED_ENV];
+ new_word->props = F;
+ new_word->counter = tag_fixnum(0);
+ new_word->direct_entry_def = F;
+ new_word->subprimitive = F;
+ new_word->profiling = NULL;
+ new_word->code = NULL;
+
+ jit_compile_word(new_word.value(),new_word->def,true);
+ update_word_xt(new_word.value());
+
+ if(profiling_p)
+ relocate_code_block(new_word->profiling);
+
+ return new_word.untagged();
+}
+
+/* <word> ( name vocabulary -- word ) */
+PRIMITIVE(word)
+{
+ cell vocab = dpop();
+ cell name = dpop();
+ dpush(tag<word>(allot_word(vocab,name)));
+}
+
+/* word-xt ( word -- start end ) */
+PRIMITIVE(word_xt)
+{
+ word *w = untag_check<word>(dpop());
+ code_block *code = (profiling_p ? w->profiling : w->code);
+ dpush(allot_cell((cell)code->xt()));
+ dpush(allot_cell((cell)code + code->block.size));
+}
+
+/* Allocates memory */
+void update_word_xt(cell w_)
+{
+ gc_root<word> w(w_);
+
+ if(profiling_p)
+ {
+ if(!w->profiling)
+ w->profiling = compile_profiling_stub(w.value());
+
+ w->xt = w->profiling->xt();
+ }
+ else
+ w->xt = w->code->xt();
+}
+
+PRIMITIVE(optimized_p)
+{
+ drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
+}
+
+PRIMITIVE(wrapper)
+{
+ wrapper *new_wrapper = allot<wrapper>(sizeof(wrapper));
+ new_wrapper->object = dpeek();
+ drepl(tag<wrapper>(new_wrapper));
+}
+
+}
diff --git a/vm/words.hpp b/vm/words.hpp
new file mode 100644
index 0000000000..9c8e7ad57a
--- /dev/null
+++ b/vm/words.hpp
@@ -0,0 +1,19 @@
+namespace factor
+{
+
+word *allot_word(cell vocab, cell name);
+
+PRIMITIVE(word);
+PRIMITIVE(word_xt);
+void update_word_xt(cell word);
+
+inline bool word_optimized_p(word *word)
+{
+ return word->code->block.type == WORD_TYPE;
+}
+
+PRIMITIVE(optimized_p);
+
+PRIMITIVE(wrapper);
+
+}
diff --git a/vm/write_barrier.cpp b/vm/write_barrier.cpp
new file mode 100644
index 0000000000..4137b0a6eb
--- /dev/null
+++ b/vm/write_barrier.cpp
@@ -0,0 +1,7 @@
+#include "master.hpp"
+
+using namespace factor;
+
+cell cards_offset;
+cell decks_offset;
+cell allot_markers_offset;
diff --git a/vm/write_barrier.h b/vm/write_barrier.h
deleted file mode 100644
index be75d189de..0000000000
--- a/vm/write_barrier.h
+++ /dev/null
@@ -1,66 +0,0 @@
-/* card marking write barrier. a card is a byte storing a mark flag,
-and the offset (in cells) of the first object in the card.
-
-the mark flag is set by the write barrier when an object in the
-card has a slot written to.
-
-the offset of the first object is set by the allocator. */
-
-/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
-#define CARD_POINTS_TO_NURSERY 0x80
-#define CARD_POINTS_TO_AGING 0x40
-#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
-typedef u8 F_CARD;
-
-#define CARD_BITS 8
-#define CARD_SIZE (1<<CARD_BITS)
-#define ADDR_CARD_MASK (CARD_SIZE-1)
-
-DLLEXPORT CELL cards_offset;
-
-#define ADDR_TO_CARD(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + cards_offset)
-#define CARD_TO_ADDR(c) (CELL*)(((CELL)(c) - cards_offset)<<CARD_BITS)
-
-typedef u8 F_DECK;
-
-#define DECK_BITS (CARD_BITS + 10)
-#define DECK_SIZE (1<<DECK_BITS)
-#define ADDR_DECK_MASK (DECK_SIZE-1)
-
-DLLEXPORT CELL decks_offset;
-
-#define ADDR_TO_DECK(a) (F_DECK*)(((CELL)(a) >> DECK_BITS) + decks_offset)
-#define DECK_TO_ADDR(c) (CELL*)(((CELL)(c) - decks_offset) << DECK_BITS)
-
-#define DECK_TO_CARD(d) (F_CARD*)((((CELL)(d) - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset)
-
-#define ADDR_TO_ALLOT_MARKER(a) (F_CARD*)(((CELL)(a) >> CARD_BITS) + allot_markers_offset)
-#define CARD_OFFSET(c) (*((c) - (CELL)data_heap->cards + (CELL)data_heap->allot_markers))
-
-#define INVALID_ALLOT_MARKER 0xff
-
-DLLEXPORT CELL allot_markers_offset;
-
-/* the write barrier must be called any time we are potentially storing a
-pointer from an older generation to a younger one */
-INLINE void write_barrier(CELL address)
-{
- *ADDR_TO_CARD(address) = CARD_MARK_MASK;
- *ADDR_TO_DECK(address) = CARD_MARK_MASK;
-}
-
-#define SLOT(obj,slot) (UNTAG(obj) + (slot) * CELLS)
-
-INLINE void set_slot(CELL obj, CELL slot, CELL value)
-{
- put(SLOT(obj,slot),value);
- write_barrier(obj);
-}
-
-/* we need to remember the first object allocated in the card */
-INLINE void allot_barrier(CELL address)
-{
- F_CARD *ptr = ADDR_TO_ALLOT_MARKER(address);
- if(*ptr == INVALID_ALLOT_MARKER)
- *ptr = (address & ADDR_CARD_MASK);
-}
diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp
new file mode 100644
index 0000000000..ae7fbb25dd
--- /dev/null
+++ b/vm/write_barrier.hpp
@@ -0,0 +1,87 @@
+/* card marking write barrier. a card is a byte storing a mark flag,
+and the offset (in cells) of the first object in the card.
+
+the mark flag is set by the write barrier when an object in the
+card has a slot written to.
+
+the offset of the first object is set by the allocator. */
+
+namespace factor
+{
+
+/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
+#define CARD_POINTS_TO_NURSERY 0x80
+#define CARD_POINTS_TO_AGING 0x40
+#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
+typedef u8 card;
+
+#define CARD_BITS 8
+#define CARD_SIZE (1<<CARD_BITS)
+#define ADDR_CARD_MASK (CARD_SIZE-1)
+
+VM_C_API cell cards_offset;
+
+inline static card *addr_to_card(cell a)
+{
+ return (card*)(((cell)(a) >> CARD_BITS) + cards_offset);
+}
+
+inline static cell card_to_addr(card *c)
+{
+ return ((cell)c - cards_offset) << CARD_BITS;
+}
+
+inline static cell card_offset(card *c)
+{
+ return *(c - (cell)data->cards + (cell)data->allot_markers);
+}
+
+typedef u8 card_deck;
+
+#define DECK_BITS (CARD_BITS + 10)
+#define DECK_SIZE (1<<DECK_BITS)
+#define ADDR_DECK_MASK (DECK_SIZE-1)
+
+VM_C_API cell decks_offset;
+
+inline static card_deck *addr_to_deck(cell a)
+{
+ return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset);
+}
+
+inline static cell deck_to_addr(card_deck *c)
+{
+ return ((cell)c - decks_offset) << DECK_BITS;
+}
+
+inline static card *deck_to_card(card_deck *d)
+{
+ return (card *)((((cell)d - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset);
+}
+
+#define INVALID_ALLOT_MARKER 0xff
+
+VM_C_API cell allot_markers_offset;
+
+inline static card *addr_to_allot_marker(object *a)
+{
+ return (card *)(((cell)a >> CARD_BITS) + allot_markers_offset);
+}
+
+/* the write barrier must be called any time we are potentially storing a
+pointer from an older generation to a younger one */
+inline static void write_barrier(object *obj)
+{
+ *addr_to_card((cell)obj) = CARD_MARK_MASK;
+ *addr_to_deck((cell)obj) = CARD_MARK_MASK;
+}
+
+/* we need to remember the first object allocated in the card */
+inline static void allot_barrier(object *address)
+{
+ card *ptr = addr_to_allot_marker(address);
+ if(*ptr == INVALID_ALLOT_MARKER)
+ *ptr = ((cell)address & ADDR_CARD_MASK);
+}
+
+}