.#*
*.swo
checksums.txt
+*.so
+a.out
CC = gcc
+CPP = g++
AR = ar
LD = ld
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
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)
@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
.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
* 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
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:
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
[ resume ] curry instant later drop\r
] "test" suspend drop\r
] unit-test\r
-\r
-\ alarm-thread-loop must-infer\r
] 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 ;
-! 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 ;
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
+
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 } }
{ $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
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
! 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>
: 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 ;
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 ( -- )
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 ;
{ $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" }
"} 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." ;
! 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
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
-! 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 )
: 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 ;
"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
+++ /dev/null
-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"
+++ /dev/null
-USING: alien.strings 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
-
-[ "\u0000ff" ]
-[ "\u0000ff" latin1 string>alien latin1 alien>string ]
-unit-test
-
-[ "hello world" ]
-[ "hello world" latin1 string>alien latin1 alien>string ]
-unit-test
-
-[ "hello\u00abcdworld" ]
-[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
-unit-test
-
-[ t ] [ f expired? ] unit-test
-
-[ "hello world" ] [
- "hello world" ascii malloc-string
- dup ascii alien>string swap free
-] unit-test
-
-[ "hello world" ] [
- "hello world" utf16n malloc-string
- dup utf16n alien>string swap free
-] unit-test
-
-[ f ] [ f utf8 alien>string ] unit-test
-
-[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
-
-[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test
+++ /dev/null
-! 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
+++ /dev/null
-Passing Factor strings as C strings and vice versa
+++ /dev/null
-Default string encoding on Unix
+++ /dev/null
-! 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 ;
+++ /dev/null
-Default string encoding on Windows
+++ /dev/null
-unportable
+++ /dev/null
-! 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
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 ;
--- /dev/null
+extensions
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
sequences strings io.crlf ;
IN: base64
+ERROR: malformed-base64 ;
+
<PRIVATE
: read1-ignoring ( ignoring -- ch )
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
[ 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*
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
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
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
"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
"." write flush
-{ (compile) } compile-unoptimized
+{ compile-word } compile-unoptimized
"." write flush
(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*
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
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 )
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
SYMBOL: bootstrap-boot-quot
! JIT parameters
-SYMBOL: jit-code-format
SYMBOL: jit-prolog
SYMBOL: jit-primitive-word
SYMBOL: jit-primitive
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
H{
{ bootstrap-boot-quot 20 }
{ bootstrap-global 21 }
- { jit-code-format 22 }
{ jit-prolog 23 }
{ jit-primitive-word 24 }
{ jit-primitive 25 }
{ 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
: 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.
M: bignum '
[
- bignum tag-number dup [ emit-bignum ] emit-object
+ bignum [ emit-bignum ] emit-object
] cache-object ;
! Fixnums
M: float '
[
- float tag-number dup [
+ float [
align-here double>bits emit-64
] emit-object
] cache-object ;
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
- [ drop f , ]
+ [ direct-entry-def>> , ] ! direct-entry-def
[ drop 0 , ] ! count
[ word-sub-primitive , ]
[ drop 0 , ] ! xt
} 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 -- * )
! Wrappers
M: wrapper '
- wrapped>> ' wrapper type-number object tag-number
- [ emit ] emit-object ;
+ wrapped>> ' wrapper [ emit ] emit-object ;
! Strings
: native> ( object -- object )
: 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 ]
: 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 ;
: (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" =
! 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 ;
M: quotation '
[
array>> '
- quotation type-number object tag-number [
+ quotation [
emit ! array
f ' emit ! compiled
f ' emit ! cached-effect
: 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
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 ;
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
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@
"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
(command-line) parse-command-line
- do-crossref
-
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
"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
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
"bootstrap.image"
"tools.annotations"
"tools.crossref"
+ "tools.errors"
"tools.deploy"
"tools.disassembler"
"tools.memory"
"tools.test"
"tools.time"
"tools.threads"
- "tools.vocabs"
- "tools.vocabs.monitor"
+ "vocabs.hierarchy"
+ "vocabs.refresh"
+ "vocabs.refresh.monitor"
"editors"
} [ require ] each
+++ /dev/null
-USING: arrays byte-arrays help.markup help.syntax kernel combinators ;\r
-IN: byte-vectors\r
-\r
-ARTICLE: "byte-vectors" "Byte vectors"\r
-"The " { $vocab-link "byte-vectors" } " vocabulary implements resizable mutable sequence of unsigned bytes. Byte vectors implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them."\r
-$nl\r
-"Byte vectors form a class:"\r
-{ $subsection byte-vector }\r
-{ $subsection byte-vector? }\r
-"Creating byte vectors:"\r
-{ $subsection >byte-vector }\r
-{ $subsection <byte-vector> }\r
-"Literal syntax:"\r
-{ $subsection POSTPONE: BV{ }\r
-"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
-{ $code "BV{ } clone" } ;\r
-\r
-ABOUT: "byte-vectors"\r
-\r
-HELP: byte-vector\r
-{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
-\r
-HELP: <byte-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
-{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
-\r
-HELP: >byte-vector\r
-{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
-{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
-{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
-\r
-HELP: BV{\r
-{ $syntax "BV{ elements... }" }\r
-{ $values { "elements" "a list of bytes" } }\r
-{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
-{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
+++ /dev/null
-IN: byte-vectors.tests\r
-USING: tools.test byte-vectors vectors sequences kernel\r
-prettyprint ;\r
-\r
-[ 0 ] [ 123 <byte-vector> length ] unit-test\r
-\r
-: do-it ( seq -- seq )\r
- 123 [ over push ] each ;\r
-\r
-[ t ] [\r
- 3 <byte-vector> do-it\r
- 3 <vector> do-it sequence=\r
-] unit-test\r
-\r
-[ t ] [ BV{ } byte-vector? ] unit-test\r
-\r
-[ "BV{ }" ] [ BV{ } unparse ] unit-test\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays kernel kernel.private math sequences\r
-sequences.private growable byte-arrays accessors parser\r
-prettyprint.custom ;\r
-IN: byte-vectors\r
-\r
-TUPLE: byte-vector\r
-{ underlying byte-array }\r
-{ length array-capacity } ;\r
-\r
-: <byte-vector> ( n -- byte-vector )\r
- (byte-array) 0 byte-vector boa ; inline\r
-\r
-: >byte-vector ( seq -- byte-vector )\r
- T{ byte-vector f B{ } 0 } clone-like ;\r
-\r
-M: byte-vector like\r
- drop dup byte-vector? [\r
- dup byte-array?\r
- [ dup length byte-vector boa ] [ >byte-vector ] if\r
- ] unless ;\r
-\r
-M: byte-vector new-sequence\r
- drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
-\r
-M: byte-vector equal?\r
- over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: byte-array like\r
- #! If we have an byte-array, we're done.\r
- #! If we have a byte-vector, and it's at full capacity,\r
- #! we're done. Otherwise, call resize-byte-array, which is a\r
- #! relatively fast primitive.\r
- drop dup byte-array? [\r
- dup byte-vector? [\r
- [ length ] [ underlying>> ] bi\r
- 2dup length eq?\r
- [ nip ] [ resize-byte-array ] if\r
- ] [ >byte-array ] if\r
- ] unless ;\r
-\r
-M: byte-array new-resizable drop <byte-vector> ;\r
-\r
-SYNTAX: BV{ \ } [ >byte-vector ] parse-literal ;\r
-\r
-M: byte-vector pprint* pprint-object ;\r
-M: byte-vector pprint-delims drop \ BV{ \ } ;\r
-M: byte-vector >pprint-sequence ;\r
-\r
-INSTANCE: byte-vector growable\r
+++ /dev/null
-Growable byte arrays
+++ /dev/null
-collections
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
[ 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
! 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 )
:: 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 ;
-USING: tools.test kernel ;
+USING: tools.test kernel accessors ;
IN: calendar.format.macros
[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test
: 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
-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 )
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
IN: cocoa
: (remember-send) ( selector variable -- )
- global [ dupd ?set-at ] change-at ;
+ [ dupd ?set-at ] change-global ;
SYMBOL: sent-messages
dup 1 -> setResolvesAliases:
dup 1 -> setAllowsMultipleSelection: ;
+: <NSDirPanel> ( -- panel ) <NSOpenPanel>
+ dup 1 -> setCanChooseDirectories: ;
+
: <NSSavePanel> ( -- panel )
NSSavePanel -> savePanel
dup 1 -> setCanChooseFiles:
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@ ;
-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" } }
{ $description "Outputs the current mouse location." } ;
ARTICLE: "cocoa-view-utils" "Cocoa view utilities"
-{ $subsection <PixelFormat> }
{ $subsection <GLView> }
{ $subsection view-dim }
{ $subsection mouse-location } ;
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: ;
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:"
--- /dev/null
+extensions
--- /dev/null
+extensions
! 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
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"
! 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 )
: 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
[ 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 ;
--- /dev/null
+extensions
-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
{ { $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)." ;
-! 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
: default-cli-args ( -- )
global [
"quiet" off
- "script" off
"e" off
"user-init" on
embedded? "quiet" set
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 ;
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?
[ 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 ;
[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
: 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 ;
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
{ \ 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 ] }
: 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.
USING: compiler.cfg.linear-scan.assignment tools.test ;
IN: compiler.cfg.linear-scan.assignment.tests
-\ assign-registers must-infer
+
IN: compiler.cfg.linearization.tests
USING: compiler.cfg.linearization tools.test ;
-\ build-mr must-infer
+
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
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
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
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
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
SYMBOL: compiling-word
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
+: compiled-stack-traces? ( -- ? ) 67 getenv ;
! Mapping _label IDs to label instances
SYMBOL: labels
: 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>>
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
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 ;
: 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 ;
literal-table get >array
relocation-table get >byte-array
label-table get resolve-labels
- ] { } make 4array ;
+ ] B{ } make 4array ;
-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
{ "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"
{ $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." } ;
! 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
SYMBOL: compile-queue
SYMBOL: compiled
-: queue-compile? ( word -- ? )
+: compile? ( word -- ? )
+ #! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
[ compiled get key? ]
} 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 ;
+ #! Ignore some errors on inline combinators, macros, and special
+ #! words such as 'call'.
+ [
+ {
+ [ macro? ]
+ [ inline? ]
+ [ no-compile? ]
+ [ "special" word-prop ]
+ } 1||
+ ] [
+ {
+ [ do-not-compile? ]
+ [ literal-expected? ]
+ } 1||
+ ] bi* and ;
-: fail ( word error -- * )
- [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
+: 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 ]
[
- drop
- [ compiled-unxref ]
- [ f swap compiled get set-at ]
- [ +unoptimized+ save-compiled-status ]
- tri
- ] 2bi
- return ;
+ 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 -- )
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 ]
] 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 ;
-! 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
! 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
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 = ]
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: compiler.errors
+USING: help.markup help.syntax vocabs.loader words io
+quotations words.symbol ;
+
+ABOUT: "compiler-errors"
--- /dev/null
+! 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
--- /dev/null
+Compiler warning and error reporting
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 )
--- /dev/null
+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
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
[ 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
: foo ( -- ) ;
-[ 5 5 ]
+[ 3 3 ]
[ 1.2 [ tag [ foo ] keep ] compile-call ]
unit-test
{ 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
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
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
-IN: compiler.tests
+IN: compiler.tests.float
USING: compiler.units compiler kernel kernel.private memory math
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
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.
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USING: math arrays ;
IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ t ] [
--- /dev/null
+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
+++ /dev/null
-IN: compiler.tests
-USING: words kernel stack-checker alien.strings tools.test
-compiler.units ;
-
-[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test
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
] 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
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 )
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage optimized>> ] unit-test
+[ t ] [ \ breakage optimized? ] unit-test
[ breakage ] must-fail
! regression
! 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 ;
: 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
] 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
: 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
: 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
: 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
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
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
-IN: compiler.tests
+IN: compiler.tests.peg-regression-2
USING: peg.ebnf strings tools.test ;
GENERIC: <times> ( times -- term' )
;EBNF
-[ "foo" ] [ "a" parse-regexp ] unit-test
\ No newline at end of file
+[ "foo" ] [ "a" parse-regexp ] unit-test
! 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 ;
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
--- /dev/null
+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
--- /dev/null
+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
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 )
[ 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
[ 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
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
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.
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
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.
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
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
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
[ \ 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
--- /dev/null
+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
--- /dev/null
+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
-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
-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 ;
: 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
[ ] [ [ 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
-IN: compiler.tests
+IN: compiler.tests.redefine4
USING: io.streams.string kernel tools.test eval ;
: declaration-test-1 ( -- a ) 3 ; flushable
[ "" ] [ [ 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
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.
GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ;
: my-inline ( a -- b ) my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
IN: compiler.tests.redefine5
TUPLE: my-tuple ;
M: my-tuple my-generic drop 0 ;
- "> eval
+ "> eval( -- )
] unit-test
[ 0 ] [
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.
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 1 ] [
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.
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
- "> eval
+ "> eval( -- )
] unit-test
[ ] [
USE: math
IN: compiler.tests.redefine7
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
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.
! 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
[ ] [
USE: math
IN: compiler.tests.redefine8
INSTANCE: float my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[ 2.0 ] [
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.
! 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
[ ] [
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin
- "> eval
+ "> eval( -- )
] unit-test
[
-IN: compiler.tests
+IN: compiler.tests.reload
USE: vocabs.loader
! "parser" reload
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
! 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
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
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 )
{
[ 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 )
{
[ 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< [
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
-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 ;
-IN: compiler.tests
+IN: compiler.tests.tuples
USING: kernel tools.test compiler.units compiler ;
TUPLE: color red green blue ;
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." } ;
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
-! 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
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 ;
+
+: 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-from-word ( word -- nodes )
+: 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? ;
IN: compiler.tree.checker.tests
USING: compiler.tree.checker tools.test ;
-\ check-nodes must-infer
+
[ 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 ]
] unit-test
[ t ] [
- [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+ [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )
[ t ] [
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
-] unit-test
\ No newline at end of file
+] unit-test
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
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
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 . ;
: 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
[ 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 ]
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 {
M: #call run-escape-analysis*
{
- { [ dup word>> \ <complex> eq? ] [ t ] }
{ [ dup immutable-tuple-boa? ] [ t ] }
[ f ]
} cond nip ;
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*
[ 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
[ 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>> ]
M: #call escape-analysis*
dup word>> {
{ \ <tuple-boa> [ record-tuple-allocation ] }
- { \ <complex> [ record-complex-allocation ] }
{ \ slot [ record-slot-call ] }
[ drop record-unknown-allocation ]
} case ;
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
[ 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
[ ] [ [ [ 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
USING: compiler.tree.optimizer tools.test ;
IN: compiler.tree.optimizer.tests
-\ optimize-tree must-infer
+
SYMBOL: check-optimizer?
+: ?check ( nodes -- nodes' )
+ check-optimizer? get [
+ compute-def-use
+ dup check-nodes
+ ] when ;
+
: optimize-tree ( nodes -- nodes' )
analyze-recursive
normalize
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 ;
: <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 )
: 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 -- ? )
{
! 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
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 ] [
[
[ 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
[ 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 ;
{ 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 ;
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
#! 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 ] }
] [ 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? ].
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
] unit-test
[ V{ complex } ] [
- [ <complex> ] final-classes
+ [ complex boa ] final-classes
] unit-test
[ V{ complex } ] [
[ V{ complex } ] [
[
{ float float object } declare
- [ "Oops" throw ] [ <complex> ] if
+ [ "Oops" throw ] [ complex boa ] if
] final-classes
] unit-test
[ V{ float } ] [
[
- [ { float float } declare <complex> ]
+ [ { float float } declare complex boa ]
[ 2drop C{ 0.0 0.0 } ]
if real-part
] final-classes
: (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
{
{ [ 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 ;
: 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 ] }
-! 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
! 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 -- ? )
[ 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
[ { 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 -- ? )
[
{
} 2&&
] curry contains-node? ;
-\ label-is-loop? must-infer
-
: label-is-not-loop? ( nodes word -- ? )
[
{
} 2&&
] curry contains-node? ;
-\ label-is-not-loop? must-infer
-
: loop-test-1 ( a -- )
dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive
\ (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 ] [
math.private sorting math.order binary-search sequences.private
slots.private ;
-\ unbox-tuples must-infer
-
: test-unboxing ( quot -- )
build-tree
analyze-recursive
[ 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 ]
: 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
M: #call unbox-tuples*
dup word>> {
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
- { \ <complex> [ unbox-<complex> ] }
{ \ slot [ unbox-slot-access ] }
[ drop ]
} case ;
]\r
] dip later ;\r
\r
+ERROR: wait-timeout ;\r
+\r
: wait ( queue timeout status -- )\r
over [\r
[ queue-timeout [ drop ] ] dip suspend\r
- [ "Timeout" throw ] [ cancel-alarm ] if\r
+ [ wait-timeout ] [ cancel-alarm ] if\r
] [\r
[ drop '[ _ push-front ] ] dip suspend drop\r
] if ;\r
concurrency.count-downs concurrency.promises locals kernel\r
threads ;\r
\r
-:: exchanger-test ( -- )\r
+:: exchanger-test ( -- string )\r
[let |\r
ex [ <exchanger> ]\r
c [ 2 <count-down> ]\r
\r
[ f ] [ flag-test-1 ] unit-test\r
\r
-:: flag-test-2 ( -- )\r
+:: flag-test-2 ( -- ? )\r
[let | f [ <flag> ] |\r
[ 1 seconds sleep f raise-flag ] "Flag test" spawn drop\r
f lower-flag\r
IN: concurrency.mailboxes.tests\r
-USING: concurrency.mailboxes concurrency.count-downs vectors\r
-sequences threads tools.test math kernel strings namespaces\r
+USING: concurrency.mailboxes concurrency.count-downs concurrency.conditions\r
+vectors sequences threads tools.test math kernel strings namespaces\r
continuations calendar destructors ;\r
\r
{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as\r
[ ] [ "d" get 5 seconds await-timeout ] unit-test\r
\r
[ ] [ "m" get dispose ] unit-test\r
+\r
+[ { "foo" "bar" } ] [\r
+ <mailbox>\r
+ "foo" over mailbox-put\r
+ "bar" over mailbox-put\r
+ mailbox-get-all\r
+] unit-test\r
+\r
+[\r
+ <mailbox> 1 seconds mailbox-get-timeout\r
+] [ wait-timeout? ] must-fail-with\r
+
\ No newline at end of file
\r
: mailbox-get-all-timeout ( mailbox timeout -- array )\r
block-if-empty\r
- [ dup mailbox-empty? ]\r
+ [ dup mailbox-empty? not ]\r
[ dup data>> pop-back ]\r
produce nip ;\r
\r
HELP: promise\r
{ $class-description "The class of write-once promises." } ;\r
\r
+HELP: <promise>\r
+{ $values { "promise" promise } }\r
+{ $description "Creates a new promise which may be fulfilled by calling " { $link fulfill } "." } ;\r
+\r
HELP: promise-fulfilled?\r
{ $values { "promise" promise } { "?" "a boolean" } }\r
{ $description "Tests if " { $link fulfill } " has previously been called on the promise, in which case " { $link ?promise } " will return immediately without blocking." } ;\r
\ 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 )
{ 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
! See http://factorcode.org/license.txt for BSD license.\r
USING: bootstrap.image.private kernel kernel.private namespaces\r
system cpu.ppc.assembler compiler.codegen.fixup compiler.units\r
-compiler.constants math math.private layouts words words.private\r
+compiler.constants math math.private layouts words\r
vocabs slots.private locals.backend ;\r
IN: bootstrap.ppc\r
\r
4 \ cell set\r
big-endian on\r
\r
-4 jit-code-format set\r
-\r
CONSTANT: ds-reg 29\r
CONSTANT: rs-reg 30\r
\r
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
11 6 profile-count-offset LWZ\r
11 11 1 tag-fixnum ADDI\r
11 6 profile-count-offset STW\r
11 11 compiled-header-size ADDI\r
11 MTCTR\r
BCTR\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-profiling jit-define\r
+] jit-profiling jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel\r
0 MFLR\r
1 1 stack-frame SUBI\r
6 1 xt-save STW\r
stack-frame 6 LI\r
6 1 next-save STW\r
0 1 lr-save stack-frame + STW\r
-] rc-absolute-ppc-2/2 rt-this 1 jit-prolog jit-define\r
+] jit-prolog jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
6 ds-reg 4 STWU\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define\r
+] jit-push-immediate jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel\r
7 6 0 LWZ\r
1 7 0 STW\r
-] rc-absolute-ppc-2/2 rt-stack-chain 1 jit-save-stack jit-define\r
+] jit-save-stack jit-define\r
\r
[\r
- 0 6 LOAD32\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel\r
6 MTCTR\r
BCTR\r
-] rc-absolute-ppc-2/2 rt-primitive 1 jit-primitive jit-define\r
+] jit-primitive jit-define\r
\r
-[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define\r
+[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define\r
\r
-[ 0 B ] rc-relative-ppc-3 rt-xt 0 jit-word-jump jit-define\r
+[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
0 3 \ f tag-number CMPI\r
2 BEQ\r
- 0 B\r
-] rc-relative-ppc-3 rt-xt 4 jit-if-1 jit-define\r
-\r
-[\r
- 0 B\r
-] rc-relative-ppc-3 rt-xt 0 jit-if-2 jit-define\r
-\r
-: jit-jump-quot ( -- )\r
- 4 3 quot-xt-offset LWZ\r
- 4 MTCTR\r
- BCTR ;\r
+ 0 B rc-relative-ppc-3 rt-xt jit-rel\r
+] jit-if-1 jit-define\r
\r
[\r
- 0 3 LOAD32\r
- 6 ds-reg 0 LWZ\r
- 6 6 1 SRAWI\r
- 3 3 6 ADD\r
- 3 3 array-start-offset LWZ\r
- ds-reg dup 4 SUBI\r
- jit-jump-quot\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-dispatch jit-define\r
+ 0 B rc-relative-ppc-3 rt-xt jit-rel\r
+] jit-if-2 jit-define\r
\r
: jit->r ( -- )\r
4 ds-reg 0 LWZ\r
\r
[\r
jit->r\r
- 0 BL\r
+ 0 BL rc-relative-ppc-3 rt-xt jit-rel\r
jit-r>\r
-] rc-relative-ppc-3 rt-xt 3 jit-dip jit-define\r
+] jit-dip jit-define\r
\r
[\r
jit-2>r\r
- 0 BL\r
+ 0 BL rc-relative-ppc-3 rt-xt jit-rel\r
jit-2r>\r
-] rc-relative-ppc-3 rt-xt 6 jit-2dip jit-define\r
+] jit-2dip jit-define\r
\r
[\r
jit-3>r\r
- 0 BL\r
+ 0 BL rc-relative-ppc-3 rt-xt jit-rel\r
jit-3r>\r
-] rc-relative-ppc-3 rt-xt 8 jit-3dip jit-define\r
+] jit-3dip jit-define\r
\r
[\r
0 1 lr-save stack-frame + LWZ\r
1 1 stack-frame ADDI\r
0 MTLR\r
-] f f f jit-epilog jit-define\r
+] jit-epilog jit-define\r
\r
-[ BLR ] f f f jit-return jit-define\r
+[ BLR ] jit-return jit-define\r
\r
! Sub-primitives\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- jit-jump-quot\r
-] f f f \ (call) define-sub-primitive\r
+ 4 3 quot-xt-offset LWZ\r
+ 4 MTCTR\r
+ BCTR\r
+] \ (call) define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 3 word-xt-offset LWZ\r
4 MTCTR\r
BCTR\r
-] f f f \ (execute) define-sub-primitive\r
+] \ (execute) define-sub-primitive\r
\r
! Objects\r
[\r
3 3 tag-mask get ANDI\r
3 3 tag-bits get SLWI\r
3 ds-reg 0 STW\r
-] f f f \ tag define-sub-primitive\r
+] \ tag define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 4 0 0 31 tag-bits get - RLWINM\r
4 3 3 LWZX\r
3 ds-reg 0 STW\r
-] f f f \ slot define-sub-primitive\r
+] \ slot define-sub-primitive\r
\r
! Shufflers\r
[\r
ds-reg dup 4 SUBI\r
-] f f f \ drop define-sub-primitive\r
+] \ drop define-sub-primitive\r
\r
[\r
ds-reg dup 8 SUBI\r
-] f f f \ 2drop define-sub-primitive\r
+] \ 2drop define-sub-primitive\r
\r
[\r
ds-reg dup 12 SUBI\r
-] f f f \ 3drop define-sub-primitive\r
+] \ 3drop define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg 4 STWU\r
-] f f f \ dup define-sub-primitive\r
+] \ dup define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 8 ADDI\r
3 ds-reg 0 STW\r
4 ds-reg -4 STW\r
-] f f f \ 2dup define-sub-primitive\r
+] \ 2dup define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg 0 STW\r
4 ds-reg -4 STW\r
5 ds-reg -8 STW\r
-] f f f \ 3dup define-sub-primitive\r
+] \ 3dup define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
3 ds-reg 0 STW\r
-] f f f \ nip define-sub-primitive\r
+] \ nip define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 8 SUBI\r
3 ds-reg 0 STW\r
-] f f f \ 2nip define-sub-primitive\r
+] \ 2nip define-sub-primitive\r
\r
[\r
3 ds-reg -4 LWZ\r
3 ds-reg 4 STWU\r
-] f f f \ over define-sub-primitive\r
+] \ over define-sub-primitive\r
\r
[\r
3 ds-reg -8 LWZ\r
3 ds-reg 4 STWU\r
-] f f f \ pick define-sub-primitive\r
+] \ pick define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZ\r
4 ds-reg 0 STW\r
3 ds-reg 4 STWU\r
-] f f f \ dupd define-sub-primitive\r
+] \ dupd define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg 4 STWU\r
4 ds-reg -4 STW\r
3 ds-reg -8 STW\r
-] f f f \ tuck define-sub-primitive\r
+] \ tuck define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZ\r
3 ds-reg -4 STW\r
4 ds-reg 0 STW\r
-] f f f \ swap define-sub-primitive\r
+] \ swap define-sub-primitive\r
\r
[\r
3 ds-reg -4 LWZ\r
4 ds-reg -8 LWZ\r
3 ds-reg -8 STW\r
4 ds-reg -4 STW\r
-] f f f \ swapd define-sub-primitive\r
+] \ swapd define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 ds-reg -8 STW\r
3 ds-reg -4 STW\r
5 ds-reg 0 STW\r
-] f f f \ rot define-sub-primitive\r
+] \ rot define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 ds-reg -8 STW\r
5 ds-reg -4 STW\r
4 ds-reg 0 STW\r
-] f f f \ -rot define-sub-primitive\r
+] \ -rot define-sub-primitive\r
\r
-[ jit->r ] f f f \ load-local define-sub-primitive\r
+[ jit->r ] \ load-local define-sub-primitive\r
\r
! Comparisons\r
: jit-compare ( insn -- )\r
- 0 3 LOAD32\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
4 ds-reg 0 LWZ\r
5 ds-reg -4 LWZU\r
5 0 4 CMP\r
- 2 swap execute ! magic number\r
+ 2 swap execute( offset -- ) ! magic number\r
\ f tag-number 3 LI\r
3 ds-reg 0 STW ;\r
\r
: define-jit-compare ( insn word -- )\r
- [ [ jit-compare ] curry rc-absolute-ppc-2/2 rt-immediate 1 ] dip\r
- define-sub-primitive ;\r
+ [ [ jit-compare ] curry ] dip define-sub-primitive ;\r
\r
\ BEQ \ eq? define-jit-compare\r
\ BGE \ fixnum>= define-jit-compare\r
2 BNE\r
1 tag-fixnum 4 LI\r
4 ds-reg 0 STW\r
-] f f f \ both-fixnums? define-sub-primitive\r
+] \ both-fixnums? define-sub-primitive\r
\r
: jit-math ( insn -- )\r
3 ds-reg 0 LWZ\r
4 ds-reg -4 LWZU\r
- [ 5 3 4 ] dip execute\r
+ [ 5 3 4 ] dip execute( dst src1 src2 -- )\r
5 ds-reg 0 STW ;\r
\r
-[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive\r
+[ \ ADD jit-math ] \ fixnum+fast define-sub-primitive\r
\r
-[ \ SUBF jit-math ] f f f \ fixnum-fast define-sub-primitive\r
+[ \ SUBF jit-math ] \ fixnum-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
4 4 tag-bits get SRAWI\r
5 3 4 MULLW\r
5 ds-reg 0 STW\r
-] f f f \ fixnum*fast define-sub-primitive\r
+] \ fixnum*fast define-sub-primitive\r
\r
-[ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive\r
+[ \ AND jit-math ] \ fixnum-bitand define-sub-primitive\r
\r
-[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive\r
+[ \ OR jit-math ] \ fixnum-bitor define-sub-primitive\r
\r
-[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive\r
+[ \ XOR jit-math ] \ fixnum-bitxor define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 3 NOT\r
3 3 tag-mask get XORI\r
3 ds-reg 0 STW\r
-] f f f \ fixnum-bitnot define-sub-primitive\r
+] \ fixnum-bitnot define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
2 BGT\r
5 7 MR\r
5 ds-reg 0 STW\r
-] f f f \ fixnum-shift-fast define-sub-primitive\r
+] \ fixnum-shift-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
6 5 3 MULLW\r
7 6 4 SUBF\r
7 ds-reg 0 STW\r
-] f f f \ fixnum-mod define-sub-primitive\r
+] \ fixnum-mod define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
5 4 3 DIVW\r
5 5 tag-bits get SLWI\r
5 ds-reg 0 STW\r
-] f f f \ fixnum/i-fast define-sub-primitive\r
+] \ fixnum/i-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
5 5 tag-bits get SLWI\r
5 ds-reg -4 STW\r
7 ds-reg 0 STW\r
-] f f f \ fixnum/mod-fast define-sub-primitive\r
+] \ fixnum/mod-fast define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
3 3 1 SRAWI\r
rs-reg 3 3 LWZX\r
3 ds-reg 0 STW\r
-] f f f \ get-local define-sub-primitive\r
+] \ get-local define-sub-primitive\r
\r
[\r
3 ds-reg 0 LWZ\r
ds-reg ds-reg 4 SUBI\r
3 3 1 SRAWI\r
rs-reg 3 rs-reg SUBF\r
-] f f f \ drop-locals define-sub-primitive\r
+] \ drop-locals define-sub-primitive\r
\r
[ "bootstrap.ppc" forget-vocab ] with-compilation-unit\r
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? [
: 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
: 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
[ { 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
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 ;
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) ;
-! 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
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
! 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
[
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 ] jit-return jit-define
-[ 0 RET ] f f f jit-return jit-define
+! ! ! Polymorphic inline caches
-! Sub-primitives
+! 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
[
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
[
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
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
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
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
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
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
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
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
! 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
! 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
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
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
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
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
! 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
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
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
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
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 ;
=> [[ table >string message sqlite-table-error ]]
| "no such table: " .+:table
=> [[ table >string <sql-table-missing> ]]
+ | .*:error
+ => [[ error >string <unparsed-sqlite-error> ]]
;EBNF
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
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 -- )
[ " 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% ;
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 )
{ "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 -- )
[
[
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
<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
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
[
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
[
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
[
[ 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
[ 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
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
USING: debugger kernel continuations tools.test ;\r
\r
[ ] [ [ drop ] [ error. ] recover ] unit-test\r
+\r
+[ f ] [ { } vm-error? ] unit-test\r
+[ f ] [ { "A" "B" } vm-error? ] unit-test
\ No newline at end of file
! 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 ;
"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
: 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 .
"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 ;
: 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. ] }
{ 15 [ memory-error. ] }
} ; inline
-M: kernel-error error. dup kernel-errors case ;
+M: vm-error summary drop "VM error" ;
+
+M: vm-error error. dup vm-errors case ;
-M: kernel-error error-help kernel-errors at first ;
+M: vm-error error-help vm-errors at first ;
M: no-method summary
drop "No suitable method" ;
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" ;
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" ;
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" ;
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
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
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
[ 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
[ 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 ;
seq-delegate
sequence-protocol \ protocol-consult word-prop
key?
-] unit-test
\ No newline at end of file
+] unit-test
! 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
PROTOCOL: output-stream-protocol
stream-flush stream-write1 stream-write stream-nl ;
-
-PROTOCOL: definition-protocol
-where set-where forget uses
-synopsis* definer definition ;
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
-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"
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" } "." }
"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" }
} ;
! 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 ;
[ 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 ;
: :edit ( -- )
error get (:edit) ;
+: edit-error ( error -- )
+ [ file>> ] [ line#>> ] bi 2dup and [ edit-location ] [ 2drop ] if ;
+
: edit-each ( seq -- )
[
[ "Editing " write . ]
Eduardo Cavazos
+Doug Coleman
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"
: 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 ,
,
-Doug Coleman
+Slava Pestov
--- /dev/null
+unportable
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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
--- /dev/null
+gedit integration
--- /dev/null
+unportable
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"
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
! 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 )
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
: sprintf ( format-string -- result )
[ printf ] with-string-writer ; inline
-
<PRIVATE
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
[ 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
MACRO: strftime ( format-string -- )
parse-strftime [ length ] keep [ ] join
'[ _ <vector> @ reverse concat nip ] ;
-
-
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 } } ] [
: list ( url -- ftp-response )
utf8 open-passive-client
ftp-list
- lines
+ stream-lines
<ftp-response> swap >>strings
read-response 226 ftp-assert
parse-list ;
>>
-\ sqsq must-infer
-
[ 16 ] [ 2 sqsq ] unit-test
<<
[ 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?
[ [ ] ] [
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
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
"> <string-reader> "functors-test" parse-stream
] unit-test
-test-redefinition
\ No newline at end of file
+test-redefinition
+
! 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
: 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 )
M: object >fake-quotations ;
-GENERIC: fake-quotations> ( fake -- quot )
+GENERIC: (fake-quotations>) ( fake -- )
+
+: fake-quotations> ( fake -- quot )
+ [ (fake-quotations>) ] [ ] make ;
-M: fake-quotation fake-quotations>
- seq>> [ fake-quotations> ] [ ] map-as ;
+M: fake-quotation (fake-quotations>)
+ [ seq>> [ (fake-quotations>) ] each ] [ ] make , ;
-M: array fake-quotations> [ fake-quotations> ] map ;
+M: array (fake-quotations>)
+ [ [ (fake-quotations>) ] each ] { } make , ;
-M: object fake-quotations> ;
+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
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 ;
parse-declared*
\ define-declared* parsed ;
+SYNTAX: `SYMBOL:
+ scan-param parsed
+ \ define-symbol parsed ;
+
SYNTAX: `SYNTAX:
scan-param parsed
parse-definition*
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 ;
{ "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 ( -- )
furnace.utilities\r
furnace.redirection\r
furnace.conversations\r
+furnace.chloe-tags\r
html.forms\r
html.components\r
html.components\r
USING: furnace.auth tools.test ;
IN: furnace.auth.tests
-\ logged-in-username must-infer
-\ <protected> must-infer
-\ new-realm must-infer
IN: furnace.auth.features.edit-profile.tests
USING: tools.test furnace.auth.features.edit-profile ;
-\ allow-edit-profile must-infer
+
IN: furnace.auth.features.recover-password
USING: tools.test furnace.auth.features.recover-password ;
-\ allow-password-recovery must-infer
+
IN: furnace.auth.features.registration.tests
USING: tools.test furnace.auth.features.registration ;
-\ allow-registration must-infer
+
IN: furnace.auth.login.tests\r
USING: tools.test furnace.auth.login ;\r
\r
-\ <login-realm> must-infer\r
+\r
: 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 ;
IN: furnace.db.tests
USING: tools.test furnace.db ;
-\ <db-persistence> must-infer
+
"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
! 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
"x" [ 1+ ] schange\r
"x" sget number>string "text/html" <content> ;\r
\r
-: url-responder-mock-test ( -- )\r
+: url-responder-mock-test ( -- string )\r
[\r
<request>\r
"GET" >>method\r
[ write-response-body drop ] with-string-writer\r
] with-destructors ;\r
\r
-: sessions-mock-test ( -- )\r
+: sessions-mock-test ( -- string )\r
[\r
<request>\r
"GET" >>method\r
\r
HELP: n*quot\r
{ $values\r
- { "n" integer } { "seq" sequence }\r
- { "seq'" sequence }\r
+ { "n" integer } { "quot" quotation }\r
+ { "quot'" quotation }\r
}\r
{ $examples\r
{ $example "USING: generalizations prettyprint math ;"\r
<<
-: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
+: n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
: repeat ( n obj quot -- ) swapd times ; inline
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 -- )
: 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
[ 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
-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
: 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
: 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
: sort-entries ( entries -- entries' )
[ [ key>> ] compare ] sort ;
-: delete-test ( n -- ? )
+: delete-test ( n -- obj1 obj2 )
[
random-alist
<min-heap> [ heap-push-all ] keep
-! 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
$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
"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"
}
{ $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"
} ;
"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"
}
{ "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 } "." }
"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
{ "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." }
} ;
{ $subsection "cookbook-combinators" }
{ $subsection "cookbook-variables" }
{ $subsection "cookbook-vocabs" }
-{ $subsection "cookbook-io" }
{ $subsection "cookbook-application" }
{ $subsection "cookbook-scripts" }
{ $subsection "cookbook-philosophy" }
{ $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 ;
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 ] [
] 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
[ ] [
-! 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
: article-children ( topic -- seq )
{ $subsection } article-links ;
-M: link uses
- { $subsection $link $see-also } article-links ;
-
: help-path ( topic -- seq )
[ article-parent ] follow rest ;
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
"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
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"
{ $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
{ { $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
{ "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" } } }
$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" } }
"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" }
"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" }
{ $subsection "growable" }
{ $heading "Associative mappings" }
{ $subsection "assocs" }
-{ $subsection "namespaces" }
+{ $subsection "linked-assocs" }
+{ $subsection "biassocs" }
{ $subsection "refs" }
"Implementations:"
{ $subsection "hashtables" }
{ $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." ;
{ $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 ] } ;
{ $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" }
-{ $subsection "cli" }
-{ $subsection "rc-files" }
-{ $subsection "help" }
-{ $subsection "inference" }
+ARTICLE: "handbook-system-reference" "The implementation"
+{ $heading "Parse time and compile time" }
+{ $subsection "parser" }
+{ $subsection "definitions" }
+{ $subsection "vocabularies" }
+{ $subsection "source-files" }
{ $subsection "compiler" }
-{ $subsection "system" }
+{ $subsection "tools.errors" }
+{ $heading "Virtual machine" }
{ $subsection "images" }
-{ $subsection "alien" }
+{ $subsection "cli" }
+{ $subsection "rc-files" }
{ $subsection "init" }
-{ $subsection "layouts" }
-{ $see-also "program-org" } ;
+{ $subsection "system" }
+{ $subsection "layouts" } ;
+
+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" "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-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" }
dup [ parsing-word? ] [ symbol? ] bi or [
name>>
] [
- [ name>> ]
+ [ unparse ]
[ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
append
] if ;
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
xref-article ;
: remove-word-help ( word -- )
- dup word-help [ dup unxref-article ] when
f "help" set-word-prop ;
: set-word-help ( content word -- )
{ $link "handbook" }
{ $link "vocab-index" }
{ $link "ui-tools" }
- { $link "handbook-library-reference" }
+ { $link "ui-listener" }
}
{ $heading "Recently visited" }
{ $table
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 ;
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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
"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"
! 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
-
-: 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" throw ] unless ;
-
-: check-nulls ( element -- )
- \ $values swap elements
- null swap deep-member?
- [ "$values should not contain null" throw ] 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" 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
+SYMBOL: lint-failures
+
+lint-failures [ H{ } clone ] initialize
+
+TUPLE: help-lint-error < source-file-error ;
+
+SYMBOL: +help-lint-failure+
+
+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
+
+M: help-lint-error error-type drop +help-lint-failure+ ;
+
+<PRIVATE
+
+: <help-lint-error> ( error topic -- help-lint-error )
+ \ help-lint-error <definition-error> ;
+
+PRIVATE>
+
+: help-lint-error ( error topic -- )
+ lint-failures get pick
+ [ [ [ <help-lint-error> ] keep ] dip set-at ] [ delete-at drop ] if
+ notify-error-observers ;
+
+<PRIVATE
+
+:: 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 ]
: 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 values errors. ;
+
: unlinked-words ( words -- seq )
all-word-help [ article-parent not ] filter ;
all-words
[ word-help not ] filter
[ article-parent ] filter
- [ "predicating" word-prop not ] filter ;
+ [ predicate? not ] filter ;
MAIN: help-lint
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
[ "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
! Images
: $image ( element -- )
- [ [ "" ] dip first image associate format ] ($span) ;
+ [ first write-image ] ($span) ;
: <$image> ( path -- element )
1array \ $image prefix ;
dup name>> a/an write bl ($link) ;
M: string ($instance)
- dup a/an write bl $snippet ;
+ write ;
M: f ($instance)
drop { f } $link ;
[
[ "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
--- /dev/null
+extensions
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
} "\n" join
[
"testfile" source-file file set
- eval
+ eval( -- )
] with-scope
] unit-test
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
{ $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
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 -- )
-! 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 )
[ 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 )
: 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* ;
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 }
\ >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
+
+M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-prop
-\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop
+M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
html.components html.forms namespaces
xml.writer ;
-\ render must-infer
-
[ ] [ begin-form ] unit-test
[ ] [ 3 "hi" set-value ] unit-test
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
{ $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" }
{ $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:"
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
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
: 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 )
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 ;
: 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
--- /dev/null
+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." } ;
-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
! 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
assocs arrays classes words urls ;
IN: http.server.dispatchers.tests
-\ find-responder must-infer
-
TUPLE: mock-responder path ;
C: <mock-responder> mock-responder
USING: http http.server.redirection urls accessors
namespaces tools.test present kernel ;
-\ relative-to-request must-infer
-
[
<request>
<url>
-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
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
-\ make-http-error must-infer
-
[ "text/plain; charset=UTF-8" ] [
<response>
"text/plain" >>content-type
-! 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
if ;\r
\r
: serving-path ( filename -- filename )\r
- [ file-responder get root>> trim-tail-separators "/" ] dip\r
- "" or trim-head-separators 3append ;\r
+ [ file-responder get root>> trim-tail-separators ] dip\r
+ [ "/" swap trim-head-separators 3append ] unless-empty ;\r
\r
: serve-file ( filename -- response )\r
dup mime-type\r
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"
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
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 ;
: 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 ;
[ 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 ]
} 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
[ drop 0 write4 ]
! size-image
- [ bitmap>> bitmap>color-index length write4 ]
+ [ bitmap>color-index length write4 ]
! x-pels
[ drop 0 write4 ]
! rgb-quads
[
- [ bitmap>> bitmap>color-index ] [ dim>> first ] bi
+ [ bitmap>color-index ]
+ [ dim>> first 3 * ]
+ [ dim>> first bitmap-padding + ] tri
reverse-lines write
]
} cleave
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 ;
: bytes-per-pixel ( component-order -- n )
{
{ L [ 1 ] }
+ { LA [ 2 ] }
{ BGR [ 3 ] }
{ RGB [ 3 ] }
{ BGRA [ 4 ] }
: 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 )
! 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 ;
} case ;
: load-image ( path -- image )
- dup image-class new load-image* normalize-image ;
+ dup image-class new load-image* ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators
-math specialized-arrays.direct.uint byte-arrays fry
-specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float images ;
-IN: images.normalization
-
-<PRIVATE
-
-: add-dummy-alpha ( seq -- seq' )
- 3 <groups> [ 255 suffix ] map concat ;
-
-: normalize-floats ( byte-array -- byte-array )
- byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
-
-GENERIC: normalize-component-order* ( image component-order -- image )
-
-: normalize-component-order ( image -- image )
- dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
-
-M: RGBA normalize-component-order* drop ;
-
-M: R32G32B32A32 normalize-component-order*
- drop normalize-floats ;
-
-M: R32G32B32 normalize-component-order*
- drop normalize-floats add-dummy-alpha ;
-
-: RGB16>8 ( bitmap -- bitmap' )
- byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
-
-M: R16G16B16A16 normalize-component-order*
- drop RGB16>8 ;
-
-M: R16G16B16 normalize-component-order*
- drop RGB16>8 add-dummy-alpha ;
-
-: BGR>RGB ( bitmap -- pixels )
- 3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
-
-: BGRA>RGBA ( bitmap -- pixels )
- 4 <sliced-groups>
- [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
-
-M: BGRA normalize-component-order*
- drop BGRA>RGBA ;
-
-M: RGB normalize-component-order*
- drop add-dummy-alpha ;
-
-M: BGR normalize-component-order*
- drop BGR>RGB add-dummy-alpha ;
-
-: ARGB>RGBA ( bitmap -- bitmap' )
- 4 <groups> [ unclip suffix ] map B{ } join ; inline
-
-M: ARGB normalize-component-order*
- drop ARGB>RGBA ;
-
-M: ABGR normalize-component-order*
- drop ARGB>RGBA BGRA>RGBA ;
-
-: fix-XBGR ( bitmap -- bitmap' )
- dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
-
-M: XBGR normalize-component-order*
- drop fix-XBGR ABGR normalize-component-order* ;
-
-: fix-BGRX ( bitmap -- bitmap' )
- dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
-
-M: BGRX normalize-component-order*
- drop fix-BGRX BGRA normalize-component-order* ;
-
-: normalize-scan-line-order ( image -- image )
- dup upside-down?>> [
- dup dim>> first 4 * '[
- _ <groups> reverse concat
- ] change-bitmap
- f >>upside-down?
- ] when ;
-
-PRIVATE>
-
-: normalize-image ( image -- image )
- [ >byte-array ] change-bitmap
- normalize-component-order
- normalize-scan-line-order
- RGBA >>component-order ;
{ { 16 16 16 } [ 2 seq>native-endianness ] }
{ { 8 8 8 8 } [ ] }
{ { 8 8 8 } [ ] }
+ { 8 [ ] }
[ unknown-component-order ]
} case >>bitmap ;
{ { 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>
--- /dev/null
+extensions
+! 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
[ 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
[ [ 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
-! 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
: 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 ;
\ 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
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? }
{ >string string? }
{ >sbuf sbuf? }
{ >quotation quotation? }
-} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
+} [ '[ dup _ execute assure ] define-inverse ] assoc-each
+
+: assure-length ( seq length -- )
+ swap length =/fail ; inline
+
+: assure-array ( array -- array )
+ dup array? assure ; inline
-! 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
+: 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
\ 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 ;
] recover ; inline
: true-out ( quot effect -- quot' )
- out>> '[ @ __ ndrop t ] ;
+ out>> '[ @ _ ndrop t ] ;
: false-recover ( effect -- quot )
in>> [ ndrop f ] curry [ recover-fail ] curry ;
{ [ 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 ;
GetLastError {
{ [ dup expected-io-error? ] [ drop f ] }
{ [ dup eof? ] [ drop t ] }
- [ (win32-error-string) throw ]
+ [ n>win32-error-string throw ]
} cond
] [ f ] if ;
destructors generic io.mmap io.ports io.backend.windows io.files.windows\r
kernel libc math math.bitwise namespaces quotations sequences windows\r
windows.advapi32 windows.kernel32 io.backend system accessors\r
-io.backend.windows.privileges ;\r
+io.backend.windows.privileges windows.errors ;\r
IN: io.backend.windows.nt.privileges\r
\r
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES\r
! 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 ? -- )
: 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 ;
swap >>fill 0 >>pos drop ;
: buffer-capacity ( buffer -- n )
- [ size>> ] [ fill>> ] bi - ; inline
+ [ size>> ] [ fill>> ] bi - >fixnum ; inline
: buffer-empty? ( buffer -- ? )
fill>> zero? ; inline
--- /dev/null
+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
! 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 ( -- )
: read-crlf ( -- seq )
"\r" read-until
- [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
+ [ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;
}
} ;
-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 }
{ "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." } ;
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 }
-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 ] [
[ 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
! 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
+
+: 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 ;
-: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
- '[ _ _ find-all-files ] map concat ; inline
+: 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
[ 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
[ 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
[ "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 } ]
[ { 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
! 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
] [ 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
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 ;
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-UTF16 encoding/decoding
+++ /dev/null
-! Copyright (C) 2008 Daniel Ehrenberg
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.encodings strings ;
-IN: io.encodings.utf16
-
-ARTICLE: "io.encodings.utf16" "UTF-16 encoding"
-"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
-{ $subsection utf16 }
-{ $subsection utf16le }
-{ $subsection utf16be } ;
-
-ABOUT: "io.encodings.utf16"
-
-HELP: utf16le
-{ $class-description "The encoding descriptor for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: utf16be
-{ $class-description "The encoding descriptor for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
-{ $see-also "encodings-introduction" } ;
-
-HELP: utf16
-{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
-{ $see-also "encodings-introduction" } ;
-
-{ utf16 utf16le utf16be } related-words
+++ /dev/null
-! 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
+++ /dev/null
-! 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 ;
-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
-
-! UTF-16BE decoding
-
-: append-nums ( byte ch -- ch )
- over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
-
-: double-be ( stream byte -- stream char )
- over stream-read1 swap append-nums ;
-
-: quad-be ( stream byte -- stream char )
- double-be over stream-read1 [
- dup -2 shift BIN: 110111 number= [
- [ 2 shift ] dip BIN: 11 bitand bitor
- over stream-read1 swap append-nums HEX: 10000 +
- ] [ 2drop dup stream-read1 drop replacement-char ] if
- ] when* ;
-
-: ignore ( stream -- stream char )
- dup stream-read1 drop replacement-char ;
-
-: begin-utf16be ( stream byte -- stream char )
- dup -3 shift BIN: 11011 number= [
- dup BIN: 00000100 bitand zero?
- [ BIN: 11 bitand quad-be ]
- [ drop ignore ] if
- ] [ double-be ] if ;
-
-M: utf16be decode-char
- drop dup stream-read1 dup [ begin-utf16be ] when nip ;
-
-! UTF-16LE decoding
-
-: quad-le ( stream ch -- stream char )
- over stream-read1 swap 10 shift bitor
- over stream-read1 dup -2 shift BIN: 110111 = [
- BIN: 11 bitand append-nums HEX: 10000 +
- ] [ 2drop replacement-char ] if ;
-
-: double-le ( stream byte1 byte2 -- stream char )
- dup -3 shift BIN: 11011 = [
- dup BIN: 100 bitand 0 number=
- [ BIN: 11 bitand 8 shift bitor quad-le ]
- [ 2drop replacement-char ] if
- ] [ append-nums ] if ;
-
-: begin-utf16le ( stream byte -- stream char )
- over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
-
-M: utf16le decode-char
- drop dup stream-read1 dup [ begin-utf16le ] when nip ;
-
-! UTF-16LE/BE encoding
-
-: encode-first ( char -- byte1 byte2 )
- -10 shift
- dup -8 shift BIN: 11011000 bitor
- swap HEX: FF bitand ;
-
-: encode-second ( char -- byte3 byte4 )
- BIN: 1111111111 bitand
- dup -8 shift BIN: 11011100 bitor
- swap BIN: 11111111 bitand ;
-
-: stream-write2 ( stream char1 char2 -- )
- rot [ stream-write1 ] curry bi@ ;
-
-: char>utf16be ( stream char -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- 2dup encode-first stream-write2
- encode-second stream-write2
- ] [ h>b/b swap stream-write2 ] if ;
-
-M: utf16be encode-char ( char stream encoding -- )
- drop swap char>utf16be ;
-
-: char>utf16le ( char stream -- )
- dup HEX: FFFF > [
- HEX: 10000 -
- 2dup encode-first swap stream-write2
- encode-second swap stream-write2
- ] [ h>b/b stream-write2 ] if ;
-
-M: utf16le encode-char ( char stream encoding -- )
- drop swap char>utf16le ;
-
-! UTF-16
-
-CONSTANT: bom-le B{ HEX: ff HEX: fe }
-
-CONSTANT: bom-be B{ HEX: fe HEX: ff }
-
-: bom>le/be ( bom -- le/be )
- dup bom-le sequence= [ drop utf16le ] [
- bom-be sequence= [ utf16be ] [ missing-bom ] if
- ] if ;
-
-M: utf16 <decoder> ( stream utf16 -- decoder )
- drop 2 over stream-read bom>le/be <decoder> ;
-
-M: utf16 <encoder> ( stream utf16 -- encoder )
- drop bom-le over stream-write utf16le <encoder> ;
-
-PRIVATE>
+++ /dev/null
-Daniel Ehrenberg
+++ /dev/null
-UTF16 encoding with native byte order
+++ /dev/null
-USING: help.markup help.syntax ;
-IN: io.encodings.utf16n
-
-HELP: utf16n
-{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
-{ $see-also "encodings-introduction" } ;
+++ /dev/null
-USING: accessors alien.c-types kernel
-io.encodings.utf16 io.streams.byte-array tools.test ;
-IN: io.encodings.utf16n
-
-: correct-endian ( obj -- ? )
- code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
-
-[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
-[ t ] [ utf16n <byte-writer> correct-endian ] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types io.encodings io.encodings.utf16 kernel ;
-IN: io.encodings.utf16n
-
-! Native-order UTF-16
-
-SINGLETON: utf16n
-
-: utf16n ( -- descriptor )
- little-endian? utf16le utf16be ? ; foldable
-
-M: utf16n <decoder> drop utf16n <decoder> ;
-
-M: utf16n <encoder> drop utf16n <encoder> ;
! 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
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" =
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 )
{
{ [ 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
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
{
[ 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 )
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
{
] 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 ;
{ $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." } ;
HOOK: make-link os ( target symlink -- )
+HOOK: make-hard-link os ( target link -- )
+
HOOK: read-link os ( symlink -- path )
: copy-link ( target symlink -- )
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 ;
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." } ;
[ 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
[ unique-directory ] dip
'[ _ with-temporary-directory ] [ delete-tree ] bi ; inline
-: unique-file ( path -- path' )
+: unique-file ( prefix -- path )
"" make-unique-file ;
{
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
[ 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|| ;
{ "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 } }
"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:"
IN: io.launcher.tests
USING: tools.test io.launcher ;
-\ <process-stream> must-infer
-\ <process-reader> must-infer
-\ <process-writer> must-infer
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
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ]
} cond
+
+: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;
[ 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{
! 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
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] unit-test
[ ] [
"cat"
"launcher-test-1" temp-file
2array
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] unit-test
[ ] [
"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
"env" >>command
{ { "A" "B" } } >>environment
+replace-environment+ >>environment-mode
- ascii <process-reader> lines
+ ascii <process-reader> stream-lines
] unit-test
[ "hi\n" ] [
"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
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
os-envs =
] unit-test
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
os-envs =
] unit-test
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
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
- ] with-directory eval
+ ] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
] unit-test
: 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
: 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
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." } ;
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:"
[ ] [ "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
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 -- )
: 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 ] }
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 ;
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 )
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
C: <win32-mapped-file> win32-mapped-file
-M: windows (mapped-file)
+M: windows (mapped-file-r/w)
[
{ GENERIC_WRITE GENERIC_READ } flags
OPEN_ALWAYS
-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 ]
io.pathnames io.files.temp io.directories.hierarchy ;
IN: io.monitors.recursive.tests
-\ pump-thread must-infer
-
SINGLETON: mock-io-backend
TUPLE: counter i ;
IN: io.monitors.windows.nt.tests\r
USING: io.monitors.windows.nt tools.test ;\r
\r
-\ fill-queue-thread must-infer\r
+\r
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
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 } ;
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
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
: 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
}
"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" }
] with-destructors ;
: <client> ( remote encoding -- stream local )
- [ (client) -rot ] dip <encoder-duplex> swap ;
+ [ (client) ] dip swap [ <encoder-duplex> ] dip ;
SYMBOL: local-address
+++ /dev/null
-USING: help.syntax help.markup io byte-arrays quotations ;
-IN: io.streams.byte-array
-
-ABOUT: "io.streams.byte-array"
-
-ARTICLE: "io.streams.byte-array" "Byte-array streams"
-"Byte array streams:"
-{ $subsection <byte-reader> }
-{ $subsection <byte-writer> }
-"Utility combinators:"
-{ $subsection with-byte-reader }
-{ $subsection with-byte-writer } ;
-
-HELP: <byte-reader>
-{ $values { "byte-array" byte-array }
- { "encoding" "an encoding descriptor" }
- { "stream" "a new byte reader" } }
-{ $description "Creates an input stream reading from a byte array using an encoding." } ;
-
-HELP: <byte-writer>
-{ $values { "encoding" "an encoding descriptor" }
- { "stream" "a new byte writer" } }
-{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
-
-HELP: with-byte-reader
-{ $values { "encoding" "an encoding descriptor" }
- { "quot" quotation } { "byte-array" byte-array } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
-
-HELP: with-byte-writer
-{ $values { "encoding" "an encoding descriptor" }
- { "quot" quotation }
- { "byte-array" byte-array } }
-{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;
+++ /dev/null
-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 } ] [ { 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
-
-[ B{ 121 120 } 0 ] [
- B{ 0 121 120 0 0 0 0 0 0 } binary
- [ 1 read drop "\0" read-until ] with-byte-reader
-] unit-test
-
-[ 1 1 4 11 f ] [
- B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
- [
- read1
- 0 seek-absolute input-stream get stream-seek
- read1
- 2 seek-relative input-stream get stream-seek
- read1
- -2 seek-end input-stream get stream-seek
- read1
- 0 seek-end input-stream get stream-seek
- read1
- ] with-byte-reader
-] unit-test
\ No newline at end of file
+++ /dev/null
-! 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
-io.streams.sequence destructors math combinators ;
-IN: io.streams.byte-array
-
-M: byte-vector stream-element-type drop +byte+ ;
-
-: <byte-writer> ( encoding -- stream )
- 512 <byte-vector> swap <encoder> ;
-
-: with-byte-writer ( encoding quot -- byte-array )
- [ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
- dup encoder? [ stream>> ] when >byte-array ; inline
-
-TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
-
-M: byte-reader stream-element-type drop +byte+ ;
-
-M: byte-reader stream-read-partial stream-read ;
-M: byte-reader stream-read sequence-read ;
-M: byte-reader stream-read1 sequence-read1 ;
-M: byte-reader stream-read-until sequence-read-until ;
-M: byte-reader dispose drop ;
-
-M: byte-reader stream-seek ( n seek-type stream -- )
- swap {
- { seek-absolute [ (>>i) ] }
- { seek-relative [ [ + ] change-i drop ] }
- { seek-end [ [ underlying>> length + ] keep (>>i) ] }
- [ bad-seek-type ]
- } case ;
-
-: <byte-reader> ( byte-array encoding -- stream )
- [ B{ } like 0 byte-reader boa ] dip <decoder> ;
-
-: with-byte-reader ( byte-array encoding quot -- )
- [ <byte-reader> ] dip with-input-stream* ; inline
+++ /dev/null
-Streams for reading and writing bytes in a byte array
[ 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
[ clone ] 2dip '[ _ _ limit ] change-stream ;
M: object limit ( stream limit mode -- stream' )
- <limited-stream> ;
+ over [ <limited-stream> ] [ 2drop ] if ;
GENERIC: 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
+++ /dev/null
-! 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 ;
-IN: io.streams.memory
-
-TUPLE: memory-stream alien index ;
-
-: <memory-stream> ( alien -- stream )
- 0 memory-stream boa ;
-
-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 ;
+++ /dev/null
-Streams for reading data directly from memory
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
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."
$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" } "." }
$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." }
$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" } "." }
$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 ;
{ $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"
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
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> ;
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 ;
] "" make ;
: write-object ( str obj -- ) presented associate format ;
+
+: write-image ( image -- ) [ "" ] dip image associate format ;
! 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
! 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
0 1 ? + [ [ 1+ ] bi@ ] dip min min ;\r
\r
: lcs-step ( insert delete change same? -- next )\r
- 1 -1./0. ? + max max ; ! -1./0. is -inf (float)\r
+ 1 -1/0. ? + max max ; ! -1/0. is -inf (float)\r
\r
:: loop-step ( i j matrix old new step -- )\r
i j 1+ matrix nth nth ! insertion\r
-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"
{ $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 } "." } ;
"\\ + 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
[
[ ] [
- "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive
+ "IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive
drop
] unit-test
] with-file-vocabs
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 )
: 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 ;
10 max-stack-items set-global
+SYMBOL: error-summary?
+
+t error-summary? set-global
+
<PRIVATE
: title. ( string -- )
] 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.
+
+ [
+ read-quot [
+ '[ datastack _ with-datastack ]
+ [ call-error-hook datastack ]
+ recover
+ ] [ return ] if*
+ ] [
+ dup lexer-error?
+ [ call-error-hook datastack ]
+ [ rethrow ]
+ if
+ ] recover
-: until-quit ( -- )
- quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
+ (listener) ;
PRIVATE>
: listener ( -- )
- [ until-quit ] with-interactive-vocabs ;
+ [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
MAIN: listener
: 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 )
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel multiline ;
+IN: literals
+
+HELP: $
+{ $syntax "$ word" }
+{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
+{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
+{ $examples
+
+ { $example <"
+USING: kernel literals prettyprint ;
+IN: scratchpad
+
+CONSTANT: five 5
+{ $ five } .
+ "> "{ 5 }" }
+
+ { $example <"
+USING: kernel literals prettyprint ;
+IN: scratchpad
+
+<< : seven-eleven ( -- a b ) 7 11 ; >>
+{ $ seven-eleven } .
+ "> "{ 7 11 }" }
+
+} ;
+
+HELP: $[
+{ $syntax "$[ code ]" }
+{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
+{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
+{ $examples
+
+ { $example <"
+USING: kernel literals math prettyprint ;
+IN: scratchpad
+
+<< CONSTANT: five 5 >>
+{ $[ five dup 1+ dup 2 + ] } .
+ "> "{ 5 6 8 }" }
+
+} ;
+
+{ POSTPONE: $ POSTPONE: $[ } related-words
+
+ARTICLE: "literals" "Interpolating code results into literal values"
+"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
+{ $example <"
+USING: kernel literals math prettyprint ;
+IN: scratchpad
+
+<< CONSTANT: five 5 >>
+{ $ five $[ five dup 1+ dup 2 + ] } .
+ "> "{ 5 5 6 8 }" }
+{ $subsection POSTPONE: $ }
+{ $subsection POSTPONE: $[ }
+;
+
+ABOUT: "literals"
--- /dev/null
+USING: kernel literals math tools.test ;
+IN: literals.tests
+
+<<
+: six-six-six ( -- a b c ) 6 6 6 ;
+>>
+
+: five ( -- a ) 5 ;
+: seven-eleven ( -- b c ) 7 11 ;
+
+[ { 5 } ] [ { $ five } ] unit-test
+[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
+[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
+
+[ { 6 6 6 7 } ] [ { $ six-six-six 7 } ] unit-test
+
+[ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test
+
+[ { 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
--- /dev/null
+! (c) Joe Groff, see license for details
+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 ;
--- /dev/null
+Expression interpolation into sequence literals
--- /dev/null
+extensions
+syntax
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
{ $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
}
"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:"
[ { 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
SYMBOL: a
:: use-test ( a b c -- a b c )
- USE: kernel ;
+ USE: kernel
+ a b c ;
[ t ] [ a symbol? ] unit-test
[ ] [ \ 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
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
{ [ 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
:: 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
:: &&-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
]
] ;
-\ let-and-cond-test-1 must-infer
+\ let-and-cond-test-1 def>> must-infer
[ 20 ] [ let-and-cond-test-1 ] unit-test
]
] ;
-\ let-and-cond-test-2 must-infer
+\ let-and-cond-test-2 def>> must-infer
[ { 10 20 } ] [ let-and-cond-test-2 ] unit-test
{ 5 [ a a ^ ] }
} case ;
-\ big-case-test must-infer
+\ big-case-test def>> must-infer
[ 9 ] [ 3 big-case-test ] unit-test
[| 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
[| 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
[| 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
: 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
{ [ 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
: 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
:: 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
{ $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"
[ 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
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 ;
} 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 )
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
-\ foo must-infer
+\ foo def>> must-infer
[ 1 ] [ { 1 } flags ] unit-test
{
{ [ 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
{ $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." } ;
: 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/ ;
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" } "." } ;
[ 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
: >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
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 [
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 )
{
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 )
{
: 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
[ 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 )
} random ;
[ t ] [
- 80000 [
+ 80000 iota [
drop
random-interval-or-empty random-interval-or-empty
random-commutative-op
: [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
$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 }
--- /dev/null
+Slava Pestov
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: math.matrices.elimination.tests
+USING: kernel math.matrices math.matrices.elimination
+tools.test sequences ;
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 1 1 0 0 }
+ { 1 0 1 0 }
+ { 1 0 0 1 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 1 1 0 0 }
+ { 1 0 1 0 }
+ { 1 1 0 1 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 1 0 }
+ { 0 0 0 1 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 1 1 0 0 }
+ { 1 1 0 1 }
+ { 1 0 1 0 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 0 0 }
+ { 0 0 0 0 }
+ }
+] [
+ {
+ { 0 1 0 0 }
+ { 1 0 0 0 }
+ { 1 0 0 0 }
+ { 1 0 0 0 }
+ } [
+ [ 1 ] [ 0 0 pivot-row ] unit-test
+ 1 0 do-row
+ ] with-matrix
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 0 0 }
+ { 0 0 0 0 }
+ }
+] [
+ {
+ { 0 1 0 0 }
+ { 1 0 0 0 }
+ { 1 0 0 0 }
+ { 1 0 0 0 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 0 0 0 1 }
+ { 0 0 0 0 }
+ }
+] [
+ {
+ { 1 0 0 0 }
+ { 0 1 0 0 }
+ { 1 0 0 1 }
+ { 1 0 0 1 }
+ } echelon
+] unit-test
+
+[
+ {
+ { 1 0 0 1 }
+ { 0 1 0 1 }
+ { 0 0 0 -1 }
+ { 0 0 0 0 }
+ }
+] [
+ {
+ { 0 1 0 1 }
+ { 1 0 0 1 }
+ { 1 0 0 0 }
+ { 1 1 0 1 }
+ } echelon
+] unit-test
+
+[
+ 2
+] [
+ {
+ { 0 0 }
+ { 0 0 }
+ } nullspace length
+] unit-test
+
+[
+ 1 3
+] [
+ {
+ { 0 1 0 1 }
+ { 1 0 0 1 }
+ { 1 0 0 0 }
+ { 1 1 0 1 }
+ } null/rank
+] unit-test
+
+[
+ 1 3
+] [
+ {
+ { 0 0 0 0 0 1 0 1 }
+ { 0 0 0 0 1 0 0 1 }
+ { 0 0 0 0 1 0 0 0 }
+ { 0 0 0 0 1 1 0 1 }
+ } null/rank
+] unit-test
+
+[ { { 1 0 -1 } { 0 1 2 } } ]
+[ { { 1 2 3 } { 4 5 6 } } solution ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math math.vectors math.matrices namespaces
+sequences ;
+IN: math.matrices.elimination
+
+SYMBOL: matrix
+
+: with-matrix ( matrix quot -- )
+ [ swap matrix set call matrix get ] with-scope ; inline
+
+: nth-row ( row# -- seq ) matrix get nth ;
+
+: change-row ( row# quot: ( seq -- seq ) -- )
+ matrix get swap change-nth ; inline
+
+: exchange-rows ( row# row# -- ) matrix get exchange ;
+
+: rows ( -- n ) matrix get length ;
+
+: cols ( -- n ) 0 nth-row length ;
+
+: skip ( i seq quot -- n )
+ over [ find-from drop ] dip length or ; inline
+
+: first-col ( row# -- n )
+ #! First non-zero column
+ 0 swap nth-row [ zero? not ] skip ;
+
+: clear-scale ( col# pivot-row i-row -- n )
+ [ over ] dip nth dup zero? [
+ 3drop 0
+ ] [
+ [ nth dup zero? ] dip swap [
+ 2drop 0
+ ] [
+ swap / neg
+ ] if
+ ] if ;
+
+: (clear-col) ( col# pivot-row i -- )
+ [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
+
+: rows-from ( row# -- slice )
+ rows dup <slice> ;
+
+: clear-col ( col# row# rows -- )
+ [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
+
+: do-row ( exchange-with row# -- )
+ [ exchange-rows ] keep
+ [ first-col ] keep
+ dup 1+ rows-from clear-col ;
+
+: find-row ( row# quot -- i elt )
+ [ rows-from ] dip find ; inline
+
+: pivot-row ( col# row# -- n )
+ [ dupd nth-row nth zero? not ] find-row 2nip ;
+
+: (echelon) ( col# row# -- )
+ over cols < over rows < and [
+ 2dup pivot-row [ over do-row 1+ ] when*
+ [ 1+ ] dip (echelon)
+ ] [
+ 2drop
+ ] if ;
+
+: echelon ( matrix -- matrix' )
+ [ 0 0 (echelon) ] with-matrix ;
+
+: nonzero-rows ( matrix -- matrix' )
+ [ [ zero? ] all? not ] filter ;
+
+: null/rank ( matrix -- null rank )
+ echelon dup length swap nonzero-rows length [ - ] keep ;
+
+: leading ( seq -- n elt ) [ zero? not ] find ;
+
+: reduced ( matrix' -- matrix'' )
+ [
+ rows <reversed> [
+ dup nth-row leading drop
+ dup [ swap dup clear-col ] [ 2drop ] if
+ ] each
+ ] with-matrix ;
+
+: basis-vector ( row col# -- )
+ [ clone ] dip
+ [ swap nth neg recip ] 2keep
+ [ 0 spin set-nth ] 2keep
+ [ n*v ] dip
+ matrix get set-nth ;
+
+: nullspace ( matrix -- seq )
+ echelon reduced dup empty? [
+ dup first length identity-matrix [
+ [
+ dup leading drop
+ dup [ basis-vector ] [ 2drop ] if
+ ] each
+ ] with-matrix flip nonzero-rows
+ ] unless ;
+
+: 1-pivots ( matrix -- matrix )
+ [ dup leading nip [ recip v*n ] when* ] map ;
+
+: solution ( matrix -- matrix )
+ echelon nonzero-rows reduced 1-pivots ;
+
+: inverse ( matrix -- matrix ) ! Assumes an invertible matrix
+ dup length
+ [ identity-matrix [ append ] 2map solution ] keep
+ [ tail ] curry map ;
--- /dev/null
+Solving systems of linear equations
--- /dev/null
+IN: math.matrices.tests
+USING: math.matrices math.vectors tools.test math ;
+
+[
+ { { 0 } { 0 } { 0 } }
+] [
+ 3 1 zero-matrix
+] unit-test
+
+[
+ { { 1 0 0 }
+ { 0 1 0 }
+ { 0 0 1 } }
+] [
+ 3 identity-matrix
+] unit-test
+
+[
+ { { 1 0 4 }
+ { 0 7 0 }
+ { 6 0 3 } }
+] [
+ { { 1 0 0 }
+ { 0 2 0 }
+ { 0 0 3 } }
+
+ { { 0 0 4 }
+ { 0 5 0 }
+ { 6 0 0 } }
+
+ m+
+] unit-test
+
+[
+ { { 1 0 4 }
+ { 0 7 0 }
+ { 6 0 3 } }
+] [
+ { { 1 0 0 }
+ { 0 2 0 }
+ { 0 0 3 } }
+
+ { { 0 0 -4 }
+ { 0 -5 0 }
+ { -6 0 0 } }
+
+ m-
+] unit-test
+
+[
+ { 10 20 30 }
+] [
+ 10 { 1 2 3 } n*v
+] unit-test
+
+[
+ { 3 4 }
+] [
+ { { 1 0 }
+ { 0 1 } }
+
+ { 3 4 }
+
+ m.v
+] unit-test
+
+[
+ { 4 3 }
+] [
+ { { 0 1 }
+ { 1 0 } }
+
+ { 3 4 }
+
+ m.v
+] unit-test
+
+[
+ { { 6 } }
+] [
+ { { 3 } } { { 2 } } m.
+] unit-test
+
+[
+ { { 11 } }
+] [
+ { { 1 3 } } { { 5 } { 2 } } m.
+] unit-test
+
+[
+ { { 28 } }
+] [
+ { { 2 4 6 } }
+
+ { { 1 }
+ { 2 }
+ { 3 } }
+
+ m.
+] unit-test
+
+[ { 0 0 -1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test
+[ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test
+[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
+
+[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
+
+[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
+[ { 1 2 } { "a" "b" } cross-zip ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2005, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.order math.vectors
+sequences sequences.private accessors columns ;
+IN: math.matrices
+
+! Matrices
+: zero-matrix ( m n -- matrix )
+ [ nip 0 <array> ] curry map ;
+
+: identity-matrix ( n -- matrix )
+ #! Make a nxn identity matrix.
+ dup [ [ = 1 0 ? ] with map ] curry map ;
+
+! Matrix operations
+: mneg ( m -- m ) [ vneg ] map ;
+
+: n*m ( n m -- m ) [ n*v ] with map ;
+: m*n ( m n -- m ) [ v*n ] curry map ;
+: n/m ( n m -- m ) [ n/v ] with map ;
+: m/n ( m n -- m ) [ v/n ] curry map ;
+
+: m+ ( m m -- m ) [ v+ ] 2map ;
+: m- ( m m -- m ) [ v- ] 2map ;
+: m* ( m m -- m ) [ v* ] 2map ;
+: m/ ( m m -- m ) [ v/ ] 2map ;
+
+: v.m ( v m -- v ) flip [ v. ] with map ;
+: m.v ( m v -- v ) [ v. ] curry map ;
+: m. ( m m -- m ) flip [ swap m.v ] curry map ;
+
+: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
+: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
+: mnorm ( m -- n ) dup mmax abs m/n ;
+
+<PRIVATE
+
+: x ( seq -- elt ) first ; inline
+: y ( seq -- elt ) second ; inline
+: z ( seq -- elt ) third ; inline
+
+: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
+: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
+: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
+
+PRIVATE>
+
+: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
+
+: proj ( v u -- w )
+ [ [ v. ] [ norm-sq ] bi / ] keep n*v ;
+
+: (gram-schmidt) ( v seq -- newseq )
+ [ dupd proj v- ] each ;
+
+: gram-schmidt ( seq -- orthogonal )
+ V{ } clone [ over (gram-schmidt) over push ] reduce ;
+
+: norm-gram-schmidt ( seq -- orthonormal )
+ gram-schmidt [ normalize ] map ;
+
+: cross-zip ( seq1 seq2 -- seq1xseq2 )
+ [ [ 2array ] with map ] curry map ;
\ No newline at end of file
--- /dev/null
+Matrix arithmetic
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." }
[ 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
PRIVATE>
+: q+ ( u v -- u+v )
+ v+ ;
+
+: q- ( u v -- u-v )
+ v- ;
+
: q* ( u v -- u*v )
[ q*a ] [ q*b ] 2bi 2array ;
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
{ $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
{ $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." } ;
<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
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
! 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
: set-rect-bounds ( rect1 rect -- )
[ [ loc>> ] dip (>>loc) ]
[ [ dim>> ] dip (>>dim) ]
- 2bi ; inline
\ No newline at end of file
+ 2bi ; inline
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" }
[ 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 ;
[ [ \ 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
: 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
[ no-content-disposition ]
} case ;
-: assert-sequence= ( a b -- )
- 2dup sequence= [ 2drop ] [ assert ] if ;
-
: read-assert-sequence= ( sequence -- )
[ length read ] keep assert-sequence= ;
! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+! 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
+++ /dev/null
-USING: help.syntax help.markup kernel math classes classes.tuple\r
-calendar models ;\r
-IN: models.history\r
-\r
-HELP: history\r
-{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;\r
-\r
-HELP: <history>\r
-{ $values { "value" object } { "history" "a new " { $link history } } }\r
-{ $description "Creates a new history model with an initial value." } ;\r
-\r
-{ <history> add-history go-back go-forward } related-words\r
-\r
-HELP: go-back\r
-{ $values { "history" history } }\r
-{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
-\r
-HELP: go-forward\r
-{ $values { "history" history } }\r
-{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
-\r
-HELP: add-history\r
-{ $values { "history" history } }\r
-{ $description "Adds the current value to the history." } ;\r
-\r
-ARTICLE: "models-history" "History models"\r
-"History models record previous values."\r
-{ $subsection history }\r
-{ $subsection <history> }\r
-"Recording history:"\r
-{ $subsection add-history }\r
-"Navigating the history:"\r
-{ $subsection go-back }\r
-{ $subsection go-forward } ;\r
-\r
-ABOUT: "models-history"\r
+++ /dev/null
-USING: arrays generic kernel math models namespaces sequences assocs\r
-tools.test models.history accessors ;\r
-IN: models.history.tests\r
-\r
-f <history> "history" set\r
-\r
-"history" get add-history\r
-\r
-[ t ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get add-history\r
-3 "history" get set-model\r
-\r
-[ t ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get add-history\r
-4 "history" get set-model\r
-\r
-[ f ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get go-back\r
-\r
-[ 3 ] [ "history" get value>> ] unit-test\r
-\r
-[ t ] [ "history" get back>> empty? ] unit-test\r
-[ f ] [ "history" get forward>> empty? ] unit-test\r
-\r
-"history" get go-forward\r
-\r
-[ 4 ] [ "history" get value>> ] unit-test\r
-\r
-[ f ] [ "history" get back>> empty? ] unit-test\r
-[ t ] [ "history" get forward>> empty? ] unit-test\r
-\r
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors kernel models sequences ;\r
-IN: models.history\r
-\r
-TUPLE: history < model back forward ;\r
-\r
-: reset-history ( history -- history )\r
- V{ } clone >>back\r
- V{ } clone >>forward ; inline\r
-\r
-: <history> ( value -- history )\r
- history new-model\r
- reset-history ;\r
-\r
-: (add-history) ( history to -- )\r
- swap value>> dup [ swap push ] [ 2drop ] if ;\r
-\r
-: go-back/forward ( history to from -- )\r
- [ 2drop ]\r
- [ [ dupd (add-history) ] dip pop swap set-model ] if-empty ;\r
-\r
-: go-back ( history -- )\r
- dup [ forward>> ] [ back>> ] bi go-back/forward ;\r
-\r
-: go-forward ( history -- )\r
- dup [ back>> ] [ forward>> ] bi go-back/forward ;\r
-\r
-: add-history ( history -- )\r
- dup forward>> delete-all\r
- dup back>> (add-history) ;\r
+++ /dev/null
-History models remember prior values
{ $subsection "models-impl" }
{ $subsection "models.arrow" }
{ $subsection "models.product" }
-{ $subsection "models-history" }
{ $subsection "models-range" }
{ $subsection "models-delay" } ;
"tester" get
"model-c" get value>>
] unit-test
-
-\ model-changed must-infer
-\ set-model must-infer
! 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
-! 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
Slava Pestov
Eduardo Cavazos
Joe Groff
+Alex Chapman
(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 -- )
-Slava Pestov
+Alex Chapman
-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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2005 Alex Chapman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel sequences words ;
-IN: opengl.glu
-
-! These are defined as structs in glu.h, but we only ever use pointers to them
-TYPEDEF: void* GLUnurbs*
-TYPEDEF: void* GLUquadric*
-TYPEDEF: void* GLUtesselator*
-TYPEDEF: void* GLubyte*
-TYPEDEF: void* GLUfuncptr
-
-! StringName
-CONSTANT: GLU_VERSION 100800
-CONSTANT: GLU_EXTENSIONS 100801
-
-! ErrorCode
-CONSTANT: GLU_INVALID_ENUM 100900
-CONSTANT: GLU_INVALID_VALUE 100901
-CONSTANT: GLU_OUT_OF_MEMORY 100902
-CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903
-CONSTANT: GLU_INVALID_OPERATION 100904
-
-! NurbsDisplay
-CONSTANT: GLU_OUTLINE_POLYGON 100240
-CONSTANT: GLU_OUTLINE_PATCH 100241
-
-! NurbsCallback
-CONSTANT: GLU_NURBS_ERROR 100103
-CONSTANT: GLU_ERROR 100103
-CONSTANT: GLU_NURBS_BEGIN 100164
-CONSTANT: GLU_NURBS_BEGIN_EXT 100164
-CONSTANT: GLU_NURBS_VERTEX 100165
-CONSTANT: GLU_NURBS_VERTEX_EXT 100165
-CONSTANT: GLU_NURBS_NORMAL 100166
-CONSTANT: GLU_NURBS_NORMAL_EXT 100166
-CONSTANT: GLU_NURBS_COLOR 100167
-CONSTANT: GLU_NURBS_COLOR_EXT 100167
-CONSTANT: GLU_NURBS_TEXTURE_COORD 100168
-CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168
-CONSTANT: GLU_NURBS_END 100169
-CONSTANT: GLU_NURBS_END_EXT 100169
-CONSTANT: GLU_NURBS_BEGIN_DATA 100170
-CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170
-CONSTANT: GLU_NURBS_VERTEX_DATA 100171
-CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171
-CONSTANT: GLU_NURBS_NORMAL_DATA 100172
-CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172
-CONSTANT: GLU_NURBS_COLOR_DATA 100173
-CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173
-CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174
-CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174
-CONSTANT: GLU_NURBS_END_DATA 100175
-CONSTANT: GLU_NURBS_END_DATA_EXT 100175
-
-! NurbsError
-CONSTANT: GLU_NURBS_ERROR1 100251
-CONSTANT: GLU_NURBS_ERROR2 100252
-CONSTANT: GLU_NURBS_ERROR3 100253
-CONSTANT: GLU_NURBS_ERROR4 100254
-CONSTANT: GLU_NURBS_ERROR5 100255
-CONSTANT: GLU_NURBS_ERROR6 100256
-CONSTANT: GLU_NURBS_ERROR7 100257
-CONSTANT: GLU_NURBS_ERROR8 100258
-CONSTANT: GLU_NURBS_ERROR9 100259
-CONSTANT: GLU_NURBS_ERROR10 100260
-CONSTANT: GLU_NURBS_ERROR11 100261
-CONSTANT: GLU_NURBS_ERROR12 100262
-CONSTANT: GLU_NURBS_ERROR13 100263
-CONSTANT: GLU_NURBS_ERROR14 100264
-CONSTANT: GLU_NURBS_ERROR15 100265
-CONSTANT: GLU_NURBS_ERROR16 100266
-CONSTANT: GLU_NURBS_ERROR17 100267
-CONSTANT: GLU_NURBS_ERROR18 100268
-CONSTANT: GLU_NURBS_ERROR19 100269
-CONSTANT: GLU_NURBS_ERROR20 100270
-CONSTANT: GLU_NURBS_ERROR21 100271
-CONSTANT: GLU_NURBS_ERROR22 100272
-CONSTANT: GLU_NURBS_ERROR23 100273
-CONSTANT: GLU_NURBS_ERROR24 100274
-CONSTANT: GLU_NURBS_ERROR25 100275
-CONSTANT: GLU_NURBS_ERROR26 100276
-CONSTANT: GLU_NURBS_ERROR27 100277
-CONSTANT: GLU_NURBS_ERROR28 100278
-CONSTANT: GLU_NURBS_ERROR29 100279
-CONSTANT: GLU_NURBS_ERROR30 100280
-CONSTANT: GLU_NURBS_ERROR31 100281
-CONSTANT: GLU_NURBS_ERROR32 100282
-CONSTANT: GLU_NURBS_ERROR33 100283
-CONSTANT: GLU_NURBS_ERROR34 100284
-CONSTANT: GLU_NURBS_ERROR35 100285
-CONSTANT: GLU_NURBS_ERROR36 100286
-CONSTANT: GLU_NURBS_ERROR37 100287
-
-! NurbsProperty
-CONSTANT: GLU_AUTO_LOAD_MATRIX 100200
-CONSTANT: GLU_CULLING 100201
-CONSTANT: GLU_SAMPLING_TOLERANCE 100203
-CONSTANT: GLU_DISPLAY_MODE 100204
-CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202
-CONSTANT: GLU_SAMPLING_METHOD 100205
-CONSTANT: GLU_U_STEP 100206
-CONSTANT: GLU_V_STEP 100207
-CONSTANT: GLU_NURBS_MODE 100160
-CONSTANT: GLU_NURBS_MODE_EXT 100160
-CONSTANT: GLU_NURBS_TESSELLATOR 100161
-CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161
-CONSTANT: GLU_NURBS_RENDERER 100162
-CONSTANT: GLU_NURBS_RENDERER_EXT 100162
-
-! NurbsSampling
-CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208
-CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208
-CONSTANT: GLU_OBJECT_PATH_LENGTH 100209
-CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209
-CONSTANT: GLU_PATH_LENGTH 100215
-CONSTANT: GLU_PARAMETRIC_ERROR 100216
-CONSTANT: GLU_DOMAIN_DISTANCE 100217
-
-! NurbsTrim
-CONSTANT: GLU_MAP1_TRIM_2 100210
-CONSTANT: GLU_MAP1_TRIM_3 100211
-
-! QuadricDrawStyle
-CONSTANT: GLU_POINT 100010
-CONSTANT: GLU_LINE 100011
-CONSTANT: GLU_FILL 100012
-CONSTANT: GLU_SILHOUETTE 100013
-
-! QuadricNormal
-CONSTANT: GLU_SMOOTH 100000
-CONSTANT: GLU_FLAT 100001
-CONSTANT: GLU_NONE 100002
-
-! QuadricOrientation
-CONSTANT: GLU_OUTSIDE 100020
-CONSTANT: GLU_INSIDE 100021
-
-! TessCallback
-CONSTANT: GLU_TESS_BEGIN 100100
-CONSTANT: GLU_BEGIN 100100
-CONSTANT: GLU_TESS_VERTEX 100101
-CONSTANT: GLU_VERTEX 100101
-CONSTANT: GLU_TESS_END 100102
-CONSTANT: GLU_END 100102
-CONSTANT: GLU_TESS_ERROR 100103
-CONSTANT: GLU_TESS_EDGE_FLAG 100104
-CONSTANT: GLU_EDGE_FLAG 100104
-CONSTANT: GLU_TESS_COMBINE 100105
-CONSTANT: GLU_TESS_BEGIN_DATA 100106
-CONSTANT: GLU_TESS_VERTEX_DATA 100107
-CONSTANT: GLU_TESS_END_DATA 100108
-CONSTANT: GLU_TESS_ERROR_DATA 100109
-CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110
-CONSTANT: GLU_TESS_COMBINE_DATA 100111
-
-! TessContour
-CONSTANT: GLU_CW 100120
-CONSTANT: GLU_CCW 100121
-CONSTANT: GLU_INTERIOR 100122
-CONSTANT: GLU_EXTERIOR 100123
-CONSTANT: GLU_UNKNOWN 100124
-
-! TessProperty
-CONSTANT: GLU_TESS_WINDING_RULE 100140
-CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141
-CONSTANT: GLU_TESS_TOLERANCE 100142
-
-! TessError
-CONSTANT: GLU_TESS_ERROR1 100151
-CONSTANT: GLU_TESS_ERROR2 100152
-CONSTANT: GLU_TESS_ERROR3 100153
-CONSTANT: GLU_TESS_ERROR4 100154
-CONSTANT: GLU_TESS_ERROR5 100155
-CONSTANT: GLU_TESS_ERROR6 100156
-CONSTANT: GLU_TESS_ERROR7 100157
-CONSTANT: GLU_TESS_ERROR8 100158
-CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151
-CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152
-CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153
-CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154
-CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155
-CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156
-
-! TessWinding
-CONSTANT: GLU_TESS_WINDING_ODD 100130
-CONSTANT: GLU_TESS_WINDING_NONZERO 100131
-CONSTANT: GLU_TESS_WINDING_POSITIVE 100132
-CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133
-CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134
-
-LIBRARY: glu
-
-FUNCTION: void gluBeginCurve ( GLUnurbs* nurb ) ;
-FUNCTION: void gluBeginPolygon ( GLUtesselator* tess ) ;
-FUNCTION: void gluBeginSurface ( GLUnurbs* nurb ) ;
-FUNCTION: void gluBeginTrim ( GLUnurbs* nurb ) ;
-
-FUNCTION: void gluCylinder ( GLUquadric* quad, GLdouble base, GLdouble top, GLdouble height, GLint slices, GLint stacks ) ;
-FUNCTION: void gluDeleteNurbsRenderer ( GLUnurbs* nurb ) ;
-FUNCTION: void gluDeleteQuadric ( GLUquadric* quad ) ;
-FUNCTION: void gluDeleteTess ( GLUtesselator* tess ) ;
-FUNCTION: void gluDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops ) ;
-FUNCTION: void gluEndCurve ( GLUnurbs* nurb ) ;
-FUNCTION: void gluEndPolygon ( GLUtesselator* tess ) ;
-FUNCTION: void gluEndSurface ( GLUnurbs* nurb ) ;
-FUNCTION: void gluEndTrim ( GLUnurbs* nurb ) ;
-FUNCTION: char* gluErrorString ( GLenum error ) ;
-FUNCTION: void gluGetNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat* data ) ;
-FUNCTION: char* gluGetString ( GLenum name ) ;
-FUNCTION: void gluGetTessProperty ( GLUtesselator* tess, GLenum which, GLdouble* data ) ;
-FUNCTION: void gluLoadSamplingMatrices ( GLUnurbs* nurb, GLfloat* model, GLfloat* perspective, GLint* view ) ;
-FUNCTION: void gluLookAt ( GLdouble eyeX, GLdouble eyeY, GLdouble eyeZ, GLdouble centerX, GLdouble centerY, GLdouble centerZ, GLdouble upX, GLdouble upY, GLdouble upZ ) ;
-FUNCTION: GLUnurbs* gluNewNurbsRenderer ( ) ;
-FUNCTION: GLUquadric* gluNewQuadric ( ) ;
-FUNCTION: GLUtesselator* gluNewTess ( ) ;
-FUNCTION: void gluNextContour ( GLUtesselator* tess, GLenum type ) ;
-FUNCTION: void gluNurbsCallback ( GLUnurbs* nurb, GLenum which, GLUfuncptr CallBackFunc ) ;
-! FUNCTION: void gluNurbsCallbackData ( GLUnurbs* nurb, GLvoid* userData ) ;
-! FUNCTION: void gluNurbsCallbackDataEXT ( GLUnurbs* nurb, GLvoid* userData ) ;
-FUNCTION: void gluNurbsCurve ( GLUnurbs* nurb, GLint knotCount, GLfloat *knots, GLint stride, GLfloat *control, GLint order, GLenum type ) ;
-FUNCTION: void gluNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat value ) ;
-FUNCTION: void gluNurbsSurface ( GLUnurbs* nurb, GLint sKnotCount, GLfloat* sKnots, GLint tKnotCount, GLfloat* tKnots, GLint sStride, GLint tStride, GLfloat* control, GLint sOrder, GLint tOrder, GLenum type ) ;
-FUNCTION: void gluOrtho2D ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top ) ;
-FUNCTION: void gluPartialDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops, GLdouble start, GLdouble sweep ) ;
-FUNCTION: void gluPerspective ( GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar ) ;
-FUNCTION: void gluPickMatrix ( GLdouble x, GLdouble y, GLdouble delX, GLdouble delY, GLint* viewport ) ;
-FUNCTION: GLint gluProject ( GLdouble objX, GLdouble objY, GLdouble objZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* winX, GLdouble* winY, GLdouble* winZ ) ;
-FUNCTION: void gluPwlCurve ( GLUnurbs* nurb, GLint count, GLfloat* data, GLint stride, GLenum type ) ;
-FUNCTION: void gluQuadricCallback ( GLUquadric* quad, GLenum which, GLUfuncptr CallBackFunc ) ;
-FUNCTION: void gluQuadricDrawStyle ( GLUquadric* quad, GLenum draw ) ;
-FUNCTION: void gluQuadricNormals ( GLUquadric* quad, GLenum normal ) ;
-FUNCTION: void gluQuadricOrientation ( GLUquadric* quad, GLenum orientation ) ;
-FUNCTION: void gluQuadricTexture ( GLUquadric* quad, GLboolean texture ) ;
-FUNCTION: GLint gluScaleImage ( GLenum format, GLsizei wIn, GLsizei hIn, GLenum typeIn, void* dataIn, GLsizei wOut, GLsizei hOut, GLenum typeOut, GLvoid* dataOut ) ;
-FUNCTION: void gluSphere ( GLUquadric* quad, GLdouble radius, GLint slices, GLint stacks ) ;
-FUNCTION: void gluTessBeginContour ( GLUtesselator* tess ) ;
-FUNCTION: void gluTessBeginPolygon ( GLUtesselator* tess, GLvoid* data ) ;
-FUNCTION: void gluTessCallback ( GLUtesselator* tess, GLenum which, GLUfuncptr CallBackFunc ) ;
-FUNCTION: void gluTessEndContour ( GLUtesselator* tess ) ;
-FUNCTION: void gluTessEndPolygon ( GLUtesselator* tess ) ;
-FUNCTION: void gluTessNormal ( GLUtesselator* tess, GLdouble valueX, GLdouble valueY, GLdouble valueZ ) ;
-FUNCTION: void gluTessProperty ( GLUtesselator* tess, GLenum which, GLdouble data ) ;
-FUNCTION: void gluTessVertex ( GLUtesselator* tess, GLdouble* location, GLvoid* data ) ;
-FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* objX, GLdouble* objY, GLdouble* objZ ) ;
-
-! Not present on Windows
-! FUNCTION: GLint gluBuild1DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
-! FUNCTION: GLint gluBuild1DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, void* data ) ;
-! FUNCTION: GLint gluBuild2DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
-! FUNCTION: GLint gluBuild2DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, void* data ) ;
-! FUNCTION: GLint gluBuild3DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
-! 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 ) ;
+++ /dev/null
-OpenGL binding - libGLU
{ $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" } }
! 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 ;
: 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
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 ;
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 )
: 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@ ;
fix-coordinates glViewport ;
: init-matrices ( -- )
+ #! Leaves with matrix mode GL_MODELVIEW
GL_PROJECTION glMatrixMode
glLoadIdentity
GL_MODELVIEW glMatrixMode
: gl-program-shaders-length ( program -- shaders-length )
GL_ATTACHED_SHADERS gl-program-get-int ; inline
+! On some macosx-x86-64 graphics drivers, glGetAttachedShaders tries to treat the
+! shaders parameter as a ulonglong array rather than a GLuint array as documented.
+! We hack around this by allocating a buffer twice the size and sifting out the zero
+! values
+
: gl-program-shaders ( program -- shaders )
- dup gl-program-shaders-length
+ dup gl-program-shaders-length 2 *
0 <int>
over <uint-array>
- [ glGetAttachedShaders ] keep ;
+ [ glGetAttachedShaders ] keep [ zero? not ] filter ;
: delete-gl-program-only ( program -- )
glDeleteProgram ; inline
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 } }
! 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) ;
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 ;
+
+SLOT: display-list
-GENERIC: draw-texture ( texture -- )
+: 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 ;
] 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
[ 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 ;
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 ;
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 ;
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 ) ;
: 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 )
: 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
"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
"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 } [
"\\" [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
peg peg.private peg.parsers accessors words math accessors ;
IN: peg.tests
-\ parse must-infer
-
[ ] [ reset-pegs ] unit-test
[
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
"abc 123 def 456" 'integer' [ 2 * number>string ] action replace
] unit-test
-\ search must-infer
-\ replace must-infer
[ back>> ] [ front>> ] bi deque boa ;
: flipped ( deque quot -- newdeque )
- [ flip ] dip call flip ;
+ [ flip ] dip call flip ; inline
PRIVATE>
: deque-empty? ( deque -- ? )
: 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 ]
: 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
[ 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
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
IN: present.tests
-USING: tools.test present math vocabs tools.vocabs sequences kernel ;
+USING: tools.test vocabs.hierarchy present math vocabs sequences kernel ;
[ "3" ] [ 3 present ] unit-test
[ "Hi" ] [ "Hi" present ] unit-test
-! 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 ;
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 ;
[ 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
] check-recursion
] if ;
+M: tuple pprint*
+ pprint-tuple ;
+
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]
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{ \ } ;
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 ;
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 ;
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
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
GENERIC: method-layout ( a -- b )
M: complex method-layout
+ drop
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
;
[
{
- "USING: math prettyprint.tests ;"
+ "USING: kernel math prettyprint.tests ;"
"M: complex method-layout"
+ " drop"
" \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\""
" ;"
""
"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 ;"
} ;
"narrow-layout" narrow-test check-see
] unit-test
-: another-narrow-test ( -- str )
+: another-narrow-test ( -- array )
{
"IN: prettyprint.tests"
": another-narrow-layout ( -- obj )"
! 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
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? ;
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
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
: 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 )
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 ;
Slava Pestov
+Alex Chapman
-! 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:"
+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 values:"
+"References to assoc values:"
{ $subsection value-ref }
{ $subsection <value-ref> }
-"References are used by the UI inspector." ;
+"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" } ;
-ABOUT: "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
+
+HELP: set-ref*
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ;
-{ <key-ref> <value-ref> } related-words
+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
-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
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
-! 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 -- )
+
+! 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 < ref ;
+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
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
[ 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
{ 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 ;
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
! 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
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* ;
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* ;
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 } } }
--- /dev/null
+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
! 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 -- )
: 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
[ stack-effect. ]
} cleave ;
-M: method-spec synopsis*
- first2 method synopsis* ;
-
M: method-body synopsis*
[ definer. ]
[ "method-class" word-prop pprint-word ]
block>
] with-use ;
-M: method-spec see*
- first2 method see* ;
-
GENERIC: see-class* ( word -- )
M: union-class see-class*
Elie Chaftari
Dirk Vleugels
Slava Pestov
+Doug Coleman
+Daniel Ehrenberg
: process ( -- )
read-crlf {
+ { [ dup not ] [ f ] }
{
[ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
[ "220 and..?\r\n" write flush t ]
! 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
{ { $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."
concurrency.promises system ;
IN: smtp.tests
-\ send-email must-infer
-
{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as
[ "hello\nworld" validate-address ] must-fail
[ { "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 ]
[
{
{ "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" }
-! 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
{ cc array }
{ bcc array }
{ subject string }
+ { content-type string initial: "text/plain" }
+ { encoding word initial: utf8 }
{ body string } ;
: <email> ( -- email ) email new ; inline
"." 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 ( -- )
: 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 ;
! 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 -- )
[
data get-ok
swap write-headers
crlf
- body>> send-body get-ok
+ send-body get-ok
quit get-ok
] with-smtp-connection ;
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"
" 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"
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
[
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-slots ] unit-test
+[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test
[ { } ]
-[ { } { } sort-by-slots ] unit-test
+[ { } { } sort-by ] unit-test
[
{
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
{ { 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
! 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 ] ;
-
-MACRO: sort-by-slots ( sort-specs -- quot )
- '[ [ _ compare-slots ] sort ] ;
-
-MACRO: compare-seq ( seq -- quot )
- [ '[ _ short-circuit-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 ( sort-seq -- quot )
- '[ [ _ compare-seq ] sort ] ;
+: sort-by-with ( seq sort-specs quot -- seq' )
+ swap '[ _ bi@ _ compare-slots ] sort ; inline
-MACRO: sort-keys-by ( sort-seq -- quot )
- '[ [ first ] bi@ _ compare-seq ] sort ;
+: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ;
-MACRO: sort-values-by ( sort-seq -- quot )
- '[ [ second ] bi@ _ compare-seq ] sort ;
+: sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ;
-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 ;
-! 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
: 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, ;
: 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
-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
! 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.
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>>
[ ] [
\ 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 ]
]
] 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?
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
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"
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 -- )"
}
} ;
-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"
! 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
-! 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" ;
-
-M: missing-effect error.
- "The word " write
- word>> pprint
- " must declare a stack effect" print ;
-
-M: effect-error error.
- "Stack effects of the word " write
- [ word>> pprint " do not match." print ]
- [ "Inferred: " write inferred>> . ]
- [ "Declared: " write declared>> . ] tri ;
-
-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: undeclared-recursion-error error.
- "The inline recursive word " write
- word>> pprint
- " must be declared recursive" print ;
-
-M: diverging-recursion-error error.
- "The recursive word " write
- word>> pprint
- " digs arbitrarily deep into the stack" print ;
-
-M: unbalanced-recursion-error error.
- "The recursive word " write
- word>> pprint
- " leaves with the stack having the wrong height" print ;
-
-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: unknown-primitive-error error.
- drop
- "Cannot determine stack effect statically" print ;
+ drop "Quotation pops retain stack elements which it did not push" ;
+
+M: missing-effect summary
+ drop "Missing stack effect declaration" ;
+
+M: effect-error summary
+ drop "Stack effect declaration is wrong" ;
+
+M: recursive-quotation-error summary
+ drop "Recursive quotation" ;
+
+M: undeclared-recursion-error summary
+ word>> name>>
+ "The inline recursive word " " must be declared recursive" surround ;
+
+M: diverging-recursion-error summary
+ word>> name>>
+ "The recursive word " " digs arbitrarily deep into the stack" surround ;
+
+M: unbalanced-recursion-error summary
+ word>> name>>
+ "The recursive word " " leaves with the stack having the wrong height" surround ;
+
+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 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
! 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
: 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, ;
apply-word/effect ;
: infer-execute-effect-unsafe ( -- )
- \ execute infer-effect-unsafe ;
+ \ (execute) infer-effect-unsafe ;
: infer-call-effect-unsafe ( -- )
\ call infer-effect-unsafe ;
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
{ [ 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 -- )
\ bignum>float { bignum } { float } define-primitive
\ bignum>float make-foldable
-\ <ratio> { integer integer } { ratio } define-primitive
-\ <ratio> make-foldable
-
-\ string>float { string } { float } define-primitive
-\ string>float make-foldable
+\ (string>float) { byte-array } { float } define-primitive
+\ (string>float) make-foldable
-\ float>string { float } { string } define-primitive
-\ float>string make-foldable
+\ (float>string) { float } { byte-array } define-primitive
+\ (float>string) make-foldable
\ float>bits { real } { integer } define-primitive
\ float>bits make-foldable
\ 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
\ 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
\ 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
\ die { } { } define-primitive
-\ fopen { string string } { alien } define-primitive
+\ (fopen) { byte-array byte-array } { alien } define-primitive
\ fgetc { alien } { object } define-primitive
\ 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
-! 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 ;
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."
-$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 } "."
+"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
-"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."
} ;
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:"
"[ [ 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
+"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
-"The following articles describe the implementation of the stack effect inference algorithm:"
+"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"
"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." }
{ $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." } ;
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
{ 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 ;
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
[ [ [ [ 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
[ [ 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
{ 1 1 } [ [ deferred-word ] [ 3 ] if ] must-infer-as
-
DEFER: an-inline-word
: normal-word-3 ( -- )
] 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
[ [ [ 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
[ [ 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
[ 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
#! 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
: 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
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
: 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
! 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? ;
[ 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
! Combinators
\ cond [ cond>quot ] 1 define-transform
+\ cond t "no-compile" set-word-prop
+
\ case [
[
[ no-case ]
] 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 ]
] bi
] 1 define-transform
+\ (call-next-method) t "no-compile" set-word-prop
+
! Constructors
\ boa [
dup tuple-class? [
] [ 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 > ]
+ [ assoc-size 4 > ]
+ [ values [ ] all? ]
+ [ keys [ integer? ] all? ]
+ [ keys [ 0 lookup-table-at-max between? ] all? ]
+ } 1&& ;
+
+: lookup-table-seq ( assoc -- table )
+ [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
+
+: lookup-table-quot ( seq -- newquot )
+ lookup-table-seq
+ '[
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup >boolean
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
+ ] ;
+
+: fast-lookup-table-at? ( assoc -- ? )
+ values {
[ [ integer? ] all? ]
- [ [ 0 bit-member-max between? ] any? ]
+ [ [ 0 254 between? ] all? ]
} 1&& ;
-: bit-member-seq ( seq -- flags )
- [ supremum 1+ ] keep '[ _ member? 1 0 ? ] B{ } map-as ;
+: fast-lookup-table-seq ( assoc -- table )
+ lookup-table-seq [ 255 or ] B{ } map-as ;
-: bit-member-quot ( seq -- newquot )
- bit-member-seq
+: fast-lookup-table-quot ( seq -- newquot )
+ fast-lookup-table-seq
'[
- _ {
- { [ over fixnum? ] [ ?nth 1 eq? ] }
- { [ over bignum? ] [ ?nth 1 eq? ] }
- [ 2drop f ]
- } cond
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
+ ] [ 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
+: 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? [
\ shuffle [
shuffle-mapping nths-quot
-] 1 define-transform
\ No newline at end of file
+] 1 define-transform
! 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
! 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
+: 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 [ length ] [ max ] map-reduce
+ dup max-length
'[ _ CHAR: \s pad-tail ] map
] unless ;
-: map-last ( seq quot -- seq )
- [ dup length <reversed> ] dip '[ 0 = @ ] 2map ; inline
-
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
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.
{ $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
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
-:: spawn-namespace-test ( -- )
+:: spawn-namespace-test ( -- ? )
[let | p [ <promise> ] g [ gensym ] |
[
g "x" set
[ 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
\ 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
M: string blah-generic ;
-{ string blah-generic } watch
+[ ] [ M\ string blah-generic watch ] unit-test
[ "hi" ] [ "hi" blah-generic ] unit-test
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 -- )
f "unannotated-def" set-word-prop
] [ drop ] if ;
-M: method-spec reset
- first2 method reset ;
-
ERROR: cannot-annotate-twice word ;
<PRIVATE
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 ;
PRIVATE>
: annotate ( word quot -- )
- [ method-spec>word check-annotate-twice ] dip
+ [ check-annotate-twice ] dip
[ over save-unannotated-def (annotate) ] with-compilation-unit ;
<PRIVATE
M: word annotate-methods
annotate ;
-M: method-spec annotate-methods
- annotate ;
-
: breakpoint ( word -- )
[ add-breakpoint ] annotate-methods ;
! 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 )
[
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
-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
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 )
[ 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
! 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 ;
: 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
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 )
[ 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 ;
! 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 )
! 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 ;
QUALIFIED: init
QUALIFIED: layouts
QUALIFIED: source-files
+QUALIFIED: source-files.errors
QUALIFIED: vocabs
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 ( -- )
{
"alias"
"boa-check"
- "cannot-infer"
"coercer"
"combination"
- "compiled-status"
"compiled-generic-uses"
"compiled-uses"
"constraints"
"custom-inlining"
+ "decision-tree"
"declared-effect"
"default"
"default-method"
"engines"
"forgotten"
"identities"
- "if-intrinsics"
- "infer"
- "inferred-effect"
"inline"
"inlined-block"
"input-classes"
"instances"
"interval"
- "intrinsics"
+ "intrinsic"
"lambda"
"loc"
"local-reader"
"method-generic"
"modular-arithmetic"
"no-compile"
- "optimizer-hooks"
+ "owner-generic"
"outputs"
"participants"
"predicate"
"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"
strip-prettyprint? [
{
- "break-before"
- "break-after"
"delimiter"
"flushable"
"foldable"
compiled-crossref
compiled-generic-crossref
compiler-impl
+ compiler.errors:compiler-errors
definition-observers
- definitions:crossref
interactive-vocabs
layouts:num-tags
layouts:num-types
lexer-factory
print-use-hook
root-cache
+ source-files.errors:error-types
vocabs:dictionary
vocabs:load-vocab-hook
word
: 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
[:c]
[print-error]
'[
- [ _ execute ] [
- _ execute nl
- _ execute
+ [ _ execute( obj -- ) ] [
+ _ execute( obj -- ) nl
+ _ execute( obj -- )
] recover
] %
] if
: 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
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
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
: 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
IN: tools.disassembler.tests\r
-USING: math classes.tuple prettyprint.custom \r
-tools.disassembler tools.test strings ;\r
+USING: kernel fry vocabs tools.disassembler tools.test sequences ;\r
\r
-[ ] [ \ + disassemble ] unit-test\r
-[ ] [ { string pprint* } disassemble ] unit-test\r
+"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each
\ No newline at end of file
M: word disassemble word-xt 2array disassemble ;
-M: method-spec disassemble first2 method disassemble ;
-
cpu x86?
"tools.disassembler.udis"
"tools.disassembler.gdb" ?
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
<<
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 ;
] { } 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
+
: 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
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 ;
USING: tools.test tools.memory ;
IN: tools.memory.tests
-\ room. must-infer
[ ] [ room. ] unit-test
-
-\ heap-stats. must-infer
[ ] [ heap-stats. ] unit-test
-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"
{ $subsection vocabs-profile. }
{ $subsection method-profile. }
{ $subsection "profiler-limitations" }
-{ $see-also "ui-profiler" } ;
+{ $see-also "ui.tools.profiler" } ;
ABOUT: "profiling"
[ 1 ] [ \ foobar counter>> ] unit-test
-: fooblah ( -- ) { } [ ] like call ;
+: fooblah ( -- ) { } [ ] like call( -- ) ;
: foobaz ( -- ) fooblah fooblah ;
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 ;
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
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
: 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 ]
] 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 ? )
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
: scaffold-help ( vocab -- )
+ ensure-vocab-exists
[
dup "-docs.factor" vocab/suffix>path scaffolding? [
set-scaffold-docs-file
PRIVATE>
: scaffold-tests ( vocab -- )
+ ensure-vocab-exists
dup "-tests.factor" vocab/suffix>path
scaffolding? [
set-scaffold-tests-file
"}" 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 ( -- )
+ os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ;
+
+: scaffold-factor-rc ( -- )
+ os windows? "factor-rc" ".factor-rc" ? scaffold-rc ;
-: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ;
-: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ;
+HOOK: scaffold-emacs os ( -- )
-: scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
+M: unix scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
--- /dev/null
+Doug Coleman
--- /dev/null
+unportable
--- /dev/null
+! 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. ;
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."
$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." } ;
{ $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
{ $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." } ;
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
-! 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) ( quot -- error ? )
+ [ quot infer drop f f ] [ t ] recover ;
+
+TUPLE: did-not-fail ;
+CONSTANT: did-not-fail T{ did-not-fail }
+
+M: did-not-fail summary drop "Did not fail" ;
+
+:: (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 ;
-: must-infer ( word/quot -- )
- dup word? [ 1quotation ] when
- '[ _ infer drop ] [ ] swap unit-test ;
+: experiment-title ( word -- string )
+ "(" ?head drop ")" ?tail drop { { CHAR: - CHAR: \s } } substitute >title ;
-: must-fail-with ( quot pred -- )
- [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ;
+MACRO: <experiment> ( word -- )
+ [ stack-effect in>> length dup ]
+ [ name>> experiment-title ] bi
+ '[ _ ndup _ narray _ prefix ] ;
-: must-fail ( quot -- )
- [ drop t ] must-fail-with ;
+: experiment. ( seq -- )
+ [ first write ": " write ] [ rest . ] bi ;
-: (run-test) ( vocab -- )
+:: 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 ;
-
-: failure. ( triple -- )
- dup second .
- dup first print-error
- "Traceback" swap third write-object ;
-
-: 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* ;
-
-: run-tests ( prefix -- failures )
- child-vocabs [ f ] [
- [ dup run-test ] { } map>assoc
- [ second empty? not ] filter
- ] if-empty ;
+: traceback-button. ( failure -- )
+ "[" write [ "Traceback" ] dip continuation>> write-object "]" print ;
-: test ( prefix -- )
- run-tests test-failures. ;
+PRIVATE>
+
+TEST: unit-test
+TEST: must-infer-as
+TEST: must-infer
+TEST: must-fail-with
+TEST: must-fail
+
+M: test-failure error. ( error -- )
+ {
+ [ summary print nl ]
+ [ asset>> [ experiment. nl ] when* ]
+ [ error>> error. ]
+ [ traceback-button. ]
+ } cleave ;
-: run-all-tests ( -- failures )
- "" run-tests ;
+: :test-failures ( -- ) test-failures get errors. ;
+
+: test ( prefix -- )
+ child-vocabs [ run-vocab-tests ] each ;
-: test-all ( -- )
- run-all-tests test-failures. ;
+: test-all ( -- ) "" test ;
! 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
[
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: tools.test tools.vocabs.monitor io.pathnames ;
-IN: tools.vocabs.monitor.tests
-
-[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test
-[ "kernel" ] [ "core/kernel/" path>vocab ] unit-test
-[ "kernel" ] [ "core/kernel/" resource-path path>vocab ] unit-test
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: threads io.files io.pathnames io.monitors init kernel\r
-vocabs vocabs.loader tools.vocabs namespaces continuations\r
-sequences splitting assocs command-line concurrency.messaging\r
-io.backend sets tr accessors ;\r
-IN: tools.vocabs.monitor\r
-\r
-TR: convert-separators "/\\" ".." ;\r
-\r
-: vocab-dir>vocab-name ( path -- vocab )\r
- trim-head-separators\r
- trim-tail-separators\r
- convert-separators ;\r
-\r
-: path>vocab-name ( path -- vocab )\r
- dup ".factor" tail? [ parent-directory ] when ;\r
-\r
-: chop-vocab-root ( path -- path' )\r
- "resource:" prepend-path normalize-path\r
- dup vocab-roots get\r
- [ normalize-path ] map\r
- [ head? ] with find nip\r
- ?head drop ;\r
-\r
-: path>vocab ( path -- vocab )\r
- chop-vocab-root path>vocab-name vocab-dir>vocab-name ;\r
-\r
-: monitor-loop ( -- )\r
- #! On OS X, monitors give us the full path, so we chop it\r
- #! off if its there.\r
- receive path>> path>vocab changed-vocab\r
- reset-cache\r
- monitor-loop ;\r
-\r
-: add-monitor-for-path ( path -- )\r
- dup exists? [ t my-mailbox (monitor) ] when drop ;\r
-\r
-: monitor-thread ( -- )\r
- [\r
- [\r
- vocab-roots get prune [ add-monitor-for-path ] each\r
-\r
- H{ } clone changed-vocabs set-global\r
- vocabs [ changed-vocab ] each\r
-\r
- monitor-loop\r
- ] with-monitors\r
- ] ignore-errors ;\r
-\r
-: start-monitor-thread ( -- )\r
- #! Silently ignore errors during monitor creation since\r
- #! monitors are not supported on all platforms.\r
- [ monitor-thread ] "Vocabulary monitor" spawn drop ;\r
-\r
-[\r
- "-no-monitors" (command-line) member?\r
- [ start-monitor-thread ] unless\r
-] "tools.vocabs.monitor" add-init-hook\r
+++ /dev/null
-Use io.monitors to clear tools.browser authors/tags/summary cache
+++ /dev/null
-Reloading vocabularies and cross-referencing vocabularies
+++ /dev/null
-USING: help.markup help.syntax strings ;\r
-IN: tools.vocabs\r
-\r
-ARTICLE: "tools.vocabs" "Vocabulary tools"\r
-"Reloading source files changed on disk:"\r
-{ $subsection refresh }\r
-{ $subsection refresh-all }\r
-"Vocabulary summaries:"\r
-{ $subsection vocab-summary }\r
-{ $subsection set-vocab-summary }\r
-"Vocabulary tags:"\r
-{ $subsection vocab-tags }\r
-{ $subsection set-vocab-tags }\r
-{ $subsection add-vocab-tags }\r
-"Getting and setting vocabulary meta-data:"\r
-{ $subsection vocab-file-contents }\r
-{ $subsection set-vocab-file-contents }\r
-"Global meta-data:"\r
-{ $subsection all-vocabs }\r
-{ $subsection all-vocabs-seq }\r
-{ $subsection all-tags }\r
-{ $subsection all-authors }\r
-"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:"\r
-{ $subsection reset-cache } ;\r
-\r
-ABOUT: "tools.vocabs"\r
-\r
-HELP: vocab-files\r
-{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }\r
-{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;\r
-\r
-HELP: vocab-tests\r
-{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }\r
-{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;\r
-\r
-HELP: source-modified?\r
-{ $values { "path" "a pathname string" } { "?" "a boolean" } }\r
-{ $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." } ;\r
-\r
-HELP: refresh\r
-{ $values { "prefix" string } }\r
-{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;\r
-\r
-HELP: refresh-all\r
-{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;\r
-\r
-{ refresh refresh-all } related-words\r
-\r
-HELP: vocab-file-contents\r
-{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }\r
-{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;\r
-\r
-HELP: set-vocab-file-contents\r
-{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }\r
-{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;\r
-\r
-HELP: vocab-summary\r
-{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }\r
-{ $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." } ;\r
-\r
-HELP: set-vocab-summary\r
-{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }\r
-{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;\r
-\r
-HELP: vocab-tags\r
-{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }\r
-{ $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." } ;\r
-\r
-HELP: set-vocab-tags\r
-{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }\r
-{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;\r
-\r
-HELP: all-vocabs\r
-{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }\r
-{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;\r
+++ /dev/null
-IN: tools.vocabs.tests
-USING: tools.test tools.vocabs namespaces continuations ;
-
-[ ] [
- changed-vocabs get-global
- f changed-vocabs set-global
- [ t ] [ "kernel" changed-vocab? ] unit-test
- [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
-] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel io io.styles io.files io.files.info io.directories\r
-io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences\r
-namespaces make math.parser arrays hashtables assocs memoize\r
-summary sorting splitting combinators source-files debugger\r
-continuations compiler.errors init checksums checksums.crc32\r
-sets accessors generic definitions words ;\r
-IN: tools.vocabs\r
-\r
-: vocab-xref ( vocab quot -- vocabs )\r
- [ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map\r
- [\r
- [ [ word? ] [ generic? not ] bi and ] filter [\r
- dup method-body?\r
- [ "method-generic" word-prop ] when\r
- vocabulary>>\r
- ] map\r
- ] gather natural-sort remove sift ; inline\r
-\r
-: vocabs. ( seq -- )\r
- [ dup >vocab-link write-object nl ] each ;\r
-\r
-: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;\r
-\r
-: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;\r
-\r
-: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;\r
-\r
-: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;\r
-\r
-: vocab-tests-file ( vocab -- path )\r
- dup "-tests.factor" vocab-dir+ vocab-append-path dup\r
- [ dup exists? [ drop f ] unless ] [ drop f ] if ;\r
-\r
-: vocab-tests-dir ( vocab -- paths )\r
- dup vocab-dir "tests" append-path vocab-append-path dup [\r
- dup exists? [\r
- dup directory-files [ ".factor" tail? ] filter\r
- [ append-path ] with map\r
- ] [ drop f ] if\r
- ] [ drop f ] if ;\r
-\r
-: vocab-tests ( vocab -- tests )\r
- [\r
- [ vocab-tests-file [ , ] when* ]\r
- [ vocab-tests-dir [ % ] when* ] bi\r
- ] { } make ;\r
-\r
-: vocab-files ( vocab -- seq )\r
- [\r
- [ vocab-source-path [ , ] when* ]\r
- [ vocab-docs-path [ , ] when* ]\r
- [ vocab-tests % ] tri\r
- ] { } make ;\r
-\r
-: vocab-heading. ( vocab -- )\r
- nl\r
- "==== " write\r
- [ vocab-name ] [ vocab write-object ] bi ":" print\r
- nl ;\r
-\r
-: load-error. ( triple -- )\r
- [ first vocab-heading. ] [ second print-error ] bi ;\r
-\r
-: load-failures. ( failures -- )\r
- [ load-error. nl ] each ;\r
-\r
-SYMBOL: failures\r
-\r
-: require-all ( vocabs -- failures )\r
- [\r
- V{ } clone blacklist set\r
- V{ } clone failures set\r
- [\r
- [ require ]\r
- [ swap vocab-name failures get set-at ]\r
- recover\r
- ] each\r
- failures get\r
- ] with-compiler-errors ;\r
-\r
-: source-modified? ( path -- ? )\r
- dup source-files get at [\r
- dup path>>\r
- dup exists? [\r
- utf8 file-lines crc32 checksum-lines\r
- swap checksum>> = not\r
- ] [\r
- 2drop f\r
- ] if\r
- ] [\r
- exists?\r
- ] ?if ;\r
-\r
-SYMBOL: changed-vocabs\r
-\r
-[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook\r
-\r
-: changed-vocab ( vocab -- )\r
- dup vocab changed-vocabs get and\r
- [ dup changed-vocabs get set-at ] [ drop ] if ;\r
-\r
-: unchanged-vocab ( vocab -- )\r
- changed-vocabs get delete-at ;\r
-\r
-: unchanged-vocabs ( vocabs -- )\r
- [ unchanged-vocab ] each ;\r
-\r
-: changed-vocab? ( vocab -- ? )\r
- changed-vocabs get dup [ key? ] [ 2drop t ] if ;\r
-\r
-: filter-changed ( vocabs -- vocabs' )\r
- [ changed-vocab? ] filter ;\r
-\r
-SYMBOL: modified-sources\r
-SYMBOL: modified-docs\r
-\r
-: (to-refresh) ( vocab variable loaded? path -- )\r
- dup [\r
- swap [\r
- pick changed-vocab? [\r
- source-modified? [ get push ] [ 2drop ] if\r
- ] [ 3drop ] if\r
- ] [ drop get push ] if\r
- ] [ 2drop 2drop ] if ;\r
-\r
-: to-refresh ( prefix -- modified-sources modified-docs unchanged )\r
- [\r
- V{ } clone modified-sources set\r
- V{ } clone modified-docs set\r
-\r
- child-vocabs [\r
- [\r
- [\r
- [ modified-sources ]\r
- [ vocab source-loaded?>> ]\r
- [ vocab-source-path ]\r
- tri (to-refresh)\r
- ] [\r
- [ modified-docs ]\r
- [ vocab docs-loaded?>> ]\r
- [ vocab-docs-path ]\r
- tri (to-refresh)\r
- ] bi\r
- ] each\r
-\r
- modified-sources get\r
- modified-docs get\r
- ]\r
- [ modified-docs get modified-sources get append diff ] bi\r
- ] with-scope ;\r
-\r
-: do-refresh ( modified-sources modified-docs unchanged -- )\r
- unchanged-vocabs\r
- [\r
- [ [ vocab f >>source-loaded? drop ] each ]\r
- [ [ vocab f >>docs-loaded? drop ] each ] bi*\r
- ]\r
- [\r
- append prune\r
- [ unchanged-vocabs ]\r
- [ require-all load-failures. ] bi\r
- ] 2bi ;\r
-\r
-: refresh ( prefix -- ) to-refresh do-refresh ;\r
-\r
-: refresh-all ( -- ) "" refresh ;\r
-\r
-MEMO: vocab-file-contents ( vocab name -- seq )\r
- vocab-append-path dup\r
- [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;\r
-\r
-: set-vocab-file-contents ( seq vocab name -- )\r
- dupd vocab-append-path [\r
- utf8 set-file-lines\r
- \ vocab-file-contents reset-memoized\r
- ] [\r
- "The " swap vocab-name\r
- " vocabulary was not loaded from the file system"\r
- 3append throw\r
- ] ?if ;\r
-\r
-: vocab-summary-path ( vocab -- string )\r
- vocab-dir "summary.txt" append-path ;\r
-\r
-: vocab-summary ( vocab -- summary )\r
- dup dup vocab-summary-path vocab-file-contents\r
- [\r
- vocab-name " vocabulary" append\r
- ] [\r
- nip first\r
- ] if-empty ;\r
-\r
-M: vocab summary\r
- [\r
- dup vocab-summary %\r
- " (" %\r
- words>> assoc-size #\r
- " words)" %\r
- ] "" make ;\r
-\r
-M: vocab-link summary vocab-summary ;\r
-\r
-: set-vocab-summary ( string vocab -- )\r
- [ 1array ] dip\r
- dup vocab-summary-path\r
- set-vocab-file-contents ;\r
-\r
-: vocab-tags-path ( vocab -- string )\r
- vocab-dir "tags.txt" append-path ;\r
-\r
-: vocab-tags ( vocab -- tags )\r
- dup vocab-tags-path vocab-file-contents harvest ;\r
-\r
-: set-vocab-tags ( tags vocab -- )\r
- dup vocab-tags-path set-vocab-file-contents ;\r
-\r
-: add-vocab-tags ( tags vocab -- )\r
- [ vocab-tags append prune ] keep set-vocab-tags ;\r
-\r
-: vocab-authors-path ( vocab -- string )\r
- vocab-dir "authors.txt" append-path ;\r
-\r
-: vocab-authors ( vocab -- authors )\r
- dup vocab-authors-path vocab-file-contents harvest ;\r
-\r
-: set-vocab-authors ( authors vocab -- )\r
- dup vocab-authors-path set-vocab-file-contents ;\r
-\r
-: subdirs ( dir -- dirs )\r
- [\r
- [ link-info directory? ] filter\r
- ] with-directory-files natural-sort ;\r
-\r
-: (all-child-vocabs) ( root name -- vocabs )\r
- [\r
- vocab-dir append-path dup exists?\r
- [ subdirs ] [ drop { } ] if\r
- ] keep [\r
- swap [ "." glue ] with map\r
- ] unless-empty ;\r
-\r
-: vocab-dir? ( root name -- ? )\r
- over\r
- [ ".factor" vocab-dir+ append-path exists? ]\r
- [ 2drop f ]\r
- if ;\r
-\r
-: vocabs-in-dir ( root name -- )\r
- dupd (all-child-vocabs) [\r
- 2dup vocab-dir? [ dup >vocab-link , ] when\r
- vocabs-in-dir\r
- ] with each ;\r
-\r
-: all-vocabs ( -- assoc )\r
- vocab-roots get [\r
- dup [ "" vocabs-in-dir ] { } make\r
- ] { } map>assoc ;\r
-\r
-MEMO: all-vocabs-seq ( -- seq )\r
- all-vocabs values concat ;\r
-\r
-: unportable? ( name -- ? )\r
- vocab-tags "unportable" swap member? ;\r
-\r
-: filter-unportable ( seq -- seq' )\r
- [ vocab-name unportable? not ] filter ;\r
-\r
-: try-everything ( -- failures )\r
- all-vocabs-seq\r
- filter-unportable\r
- require-all ;\r
-\r
-: load-everything ( -- )\r
- try-everything load-failures. ;\r
-\r
-: unrooted-child-vocabs ( prefix -- seq )\r
- dup empty? [ CHAR: . suffix ] unless\r
- vocabs\r
- [ find-vocab-root not ] filter\r
- [\r
- vocab-name swap ?head CHAR: . rot member? not and\r
- ] with filter\r
- [ vocab ] map ;\r
-\r
-: all-child-vocabs ( prefix -- assoc )\r
- vocab-roots get [\r
- dup pick (all-child-vocabs) [ >vocab-link ] map\r
- ] { } map>assoc\r
- swap unrooted-child-vocabs f swap 2array suffix ;\r
-\r
-: all-child-vocabs-seq ( prefix -- assoc )\r
- vocab-roots get swap [\r
- dupd (all-child-vocabs)\r
- [ vocab-dir? ] with filter\r
- ] curry map concat ;\r
-\r
-MEMO: all-tags ( -- seq )\r
- all-vocabs-seq [ vocab-tags ] gather natural-sort ;\r
-\r
-MEMO: all-authors ( -- seq )\r
- all-vocabs-seq [ vocab-authors ] gather natural-sort ;\r
-\r
-: reset-cache ( -- )\r
- root-cache get-global clear-assoc\r
- \ vocab-file-contents reset-memoized\r
- \ all-vocabs-seq reset-memoized\r
- \ all-authors reset-memoized\r
- \ all-tags reset-memoized ;\r
! 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 )
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
[ { } ] [
[ { } ] [
[ "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
-! 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 -- )
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' )
-
-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 ;
+<< \ walk t "no-compile" set-word-prop >>
-\ (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
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>> ;
{ 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 ;
{
! 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? ] [
! For convenience
IN: syntax
-: B ( -- ) break ;
+SYNTAX: B \ break parsed ;
-Daniel Ehrenberg
+Slava Pestov
\ No newline at end of file
-Packed homogeneous tuple arrays
+Efficient arrays of tuples with value semantics for elements
+++ /dev/null
-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." } ;
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
-! 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 ;
-! 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
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
! 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 ;
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
[ 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 -- )
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)
] 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 ;
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 -- )
! 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: {
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
! 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" }
-> 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 ;
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 ;
<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
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 )
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
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 ]
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
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
! 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 }
: 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 ;
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
[ 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 ;
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 -- )
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 ]
! 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
[ 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
[
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
IN: ui.event-loop.tests
USING: ui.event-loop tools.test ;
-
-\ event-loop must-infer
IN: ui.gadgets.books.tests
USING: tools.test ui.gadgets.books ;
-
-\ <book> must-infer
{ $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" }
} <radio-buttons> "religion" set
] unit-test
-\ <radio-buttons> must-infer
-
-\ <checkbox> must-infer
-
[ 0 ] [
"religion" get gadget-child value>>
] unit-test
] with-grafted-gadget
] unit-test
-\ <editor> must-infer
-
"hello" <model> <model-field> "field" set
"field" get [
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 }
{ { 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
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
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>> ;
: ((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>
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
! 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 ;
: <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
[ ] [ "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
! 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
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>
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 ;
[ 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
[ { 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
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 -- )
{ $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 } } }
{ <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." } ;
{ $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 }
[ { 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
drop
"g2" get scroll>gadget
"s" get layout
- "s" get scroller-value
+ "s" get scroll-position
] map [ { 0 0 } = ] all?
] unit-test
model>> dependencies>> [ range-max value>> ] map
{ 0 0 } =
] unit-test
-
-\ <scroller> must-infer
: 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 -- )
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 )
2&& ;
: (update-scroller) ( scroller -- )
- [ scroller-value ] keep scroll ;
+ [ scroll-position ] keep set-scroll-position ;
: (scroll>gadget) ( gadget scroller -- )
2dup swap child? [
] [ 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 -- )
--- /dev/null
+IN: ui.gadgets.search-tables.tests
+USING: ui.gadgets.search-tables sequences tools.test ;
+[ [ second ] <search-table> ] must-infer
: <search-field> ( model -- gadget )
horizontal search-field new-track
+ 0 >>fill
{ 5 5 } >>gap
+baseline+ >>align
swap <model-field> 10 >>min-cols >>field
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 ;
[ 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 ;
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
} 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 ;
{ +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 ;
{ $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 } ;
{ $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"
! 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 )
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 -- )
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
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
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
{ 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 )
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 - ;
'[ [ 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 ;
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
: 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 ]
: 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 ]
: table-button-up ( table -- )
dup row-action? [ row-action ] [ update-selected-value ] if ;
+PRIVATE>
+
: select-row ( table n -- )
over validate-line
[ (select-row) ]
[ show-row-summary ]
2tri ;
+<PRIVATE
+
: prev/next-row ( table n -- )
[ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
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 }
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 ;
M: viewport focusable-child*
gadget-child ;
-: scroller-value ( scroller -- loc )
+: scroll-position ( scroller -- loc )
model>> range-value [ >integer ] map ;
M: viewport model-changed
[ relayout-1 ]
[
[ gadget-child ]
- [ scroller-value vneg ]
+ [ scroll-position vneg ]
[ constraint>> ]
tri v* >>loc drop
] bi ;
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
} ;
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 } } }
{ $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* }
$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" } ;
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
! 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 ;
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
+ { 0 0 } >>window-loc ;
+
+: 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 ;
-: <world> ( gadget title status -- world )
- world new-world ;
-
: as-big-as-possible ( world gadget -- )
dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
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.
: 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
: 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
+
IN: ui.gestures.tests
USING: tools.test ui.gestures ;
-
-\ handle-gesture must-infer
-\ send-queued-gesture must-infer
\ No newline at end of file
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
[
: 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 ;
IN: ui.operations
: $operations ( element -- )
- >quotation call
+ >quotation call( -- obj )
f operations>commands
command-map. ;
[ ] [
[ { $operations \ + } print-element ] with-string-writer drop
] unit-test
-
-\ object-operations must-infer
\ No newline at end of file
--- /dev/null
+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"
--- /dev/null
+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 -- )
+
--- /dev/null
+Cross-platform OpenGL context pixel format specifiers
IN: ui.render.tests
USING: ui.render tools.test ;
-
-\ draw-gadget must-infer
\ No newline at end of file
! 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
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 ;
: 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 -- )
: 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 -- )
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."
M: selection draw-text draw-string ;
M: array draw-text
- GL_MODELVIEW [
+ [
[
[ draw-string ]
[ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi
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
\r
: rendered-script-string ( font string -- texture )\r
world get world-text-handle\r
- [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi <texture> ]\r
+ [ cached-script-string image>> { 0 0 } <texture> ]\r
2cache ;\r
\r
M: uniscribe-renderer draw-string ( font string -- )\r
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
! 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> ;
: <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
: 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 -- )
\ 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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
+
--- /dev/null
+! 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
! 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 ;
: 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 ;
SYMBOL: tool-dims
-tool-dims global [ H{ } clone or ] change-at
+tool-dims [ H{ } clone ] initialize
TUPLE: tool < track ;
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 ;
: 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) ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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"
--- /dev/null
+! 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
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"
"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
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
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
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 )
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? ;
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 -- )
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
{ $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" } "." ;
calendar concurrency.promises io ui.tools.common ;
IN: ui.tools.listener.tests
-\ <interactor> must-infer
-
[
[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
[ ] [
[
"interactor" get register-self
- "interactor" get contents "promise" get fulfill
+ "interactor" get stream-contents "promise" get fulfill
] in-thread
] unit-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
! 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
: 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
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
: 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 ;
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* ;
! 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
{ +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 ;
"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
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" } ")." ;
--- /dev/null
+USING: ui.tools.profiler tools.test ;
+
+
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
: <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 -- <=> )
: 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
$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
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:"
{ $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:"
! 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
{ 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
IN: ui.tools.walker\r
USING: help.markup help.syntax ui.commands ui.operations\r
-ui.render tools.walker sequences ;\r
+ui.render tools.walker sequences tools.continuations ;\r
\r
ARTICLE: "ui-walker-step" "Stepping through code"\r
"If the current position points to a word, the various stepping commands behave as follows:"\r
USING: ui.tools.walker tools.test ;
IN: ui.tools.walker.tests
-\ <walker-gadget> must-infer
{ 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
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 } }
IN: ui.tests
USING: ui ui.private tools.test ;
-
-\ open-window must-infer
-\ update-ui must-infer
\ No newline at end of file
! 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
[ [ 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
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 ;
[ images>> [ dispose ] when* ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
+ [ end-world ]
} cleave ;
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
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 ;
<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 ]
: 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* ;
: 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 ( -- )
[ 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
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
: test-two ( str1 str2 -- )\r
[ +lt+ ] -rot [ string<=> ] 2curry unit-test ;\r
\r
-: test-equality ( str1 str2 -- )\r
+: test-equality ( str1 str2 -- ? ? ? ? )\r
{ primary= secondary= tertiary= quaternary= }\r
- [ execute ] with with each ;\r
+ [ execute( a b -- ? ) ] with with map\r
+ first4 ;\r
\r
[ f f f f ] [ "hello" "hi" test-equality ] unit-test\r
[ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test\r
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
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."
[ ] [ all-groups drop ] unit-test
-\ all-groups must-infer
-
[ t ] [ real-group-name string? ] unit-test
[ t ] [ effective-group-name string? ] unit-test
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 ) ;
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
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" } }
[ 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
[ "/_-.:" 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 -- )
[ 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 -- )
] when*
] 2keep set-at ;
+: assoc-strings ( assoc -- assoc' )
+ [
+ {
+ { [ dup not ] [ ] }
+ { [ dup array? ] [ [ present ] map ] }
+ [ present 1array ]
+ } cond
+ ] assoc-map ;
+
PRIVATE>
: query>assoc ( query -- assoc )
: 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 ;
! 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 ;
IN: urls.tests
-USING: urls urls.private tools.test
+USING: urls urls.private tools.test prettyprint
arrays kernel assocs present accessors ;
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 [
[ "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
IN: values\r
\r
ARTICLE: "values" "Global values"\r
-"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:"\r
+"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:"\r
{ $subsection POSTPONE: VALUE: }\r
"To get the value, just call the word. The following words manipulate values:"\r
{ $subsection get-value }\r
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+Caching vocabulary data from disk
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+Loading vocabularies and batching errors
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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." } ;
+
--- /dev/null
+IN: vocabs.files.tests
+USING: tools.test vocabs.files vocabs arrays grouping ;
+
+[ t ] [
+ "kernel" vocab-files
+ "kernel" vocab vocab-files
+ "kernel" <vocab-link> vocab-files
+ 3array all-equal?
+] unit-test
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+Getting a list of files in a vocabulary
--- /dev/null
+USING: help.markup help.syntax strings vocabs.loader ;\r
+IN: vocabs.hierarchy\r
+\r
+ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools"\r
+"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not."\r
+$nl\r
+"Loading vocabulary hierarchies:"\r
+{ $subsection load }\r
+{ $subsection load-all }\r
+"Getting all vocabularies on disk:"\r
+{ $subsection all-vocabs }\r
+{ $subsection all-vocabs-seq }\r
+"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"\r
+{ $subsection all-tags }\r
+{ $subsection all-authors } ;\r
+\r
+ABOUT: "vocabs.hierarchy"\r
+\r
+HELP: all-vocabs\r
+{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }\r
+{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;\r
+\r
+HELP: load\r
+{ $values { "prefix" string } }\r
+{ $description "Load all vocabularies that match the provided prefix." }\r
+{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ;\r
+\r
+HELP: load-all\r
+{ $description "Load all vocabularies in the source tree." } ;\r
+\r
+HELP: all-vocabs-under\r
+{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } }\r
+{ $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." } ;\r
--- /dev/null
+IN: vocabs.hierarchy.tests
+USING: continuations namespaces tools.test vocabs.hierarchy vocabs.hierarchy.private ;
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays assocs combinators.short-circuit fry\r
+io.directories io.files io.files.info io.pathnames kernel make\r
+memoize namespaces sequences sorting splitting vocabs sets\r
+vocabs.loader vocabs.metadata vocabs.errors ;\r
+IN: vocabs.hierarchy\r
+\r
+<PRIVATE\r
+\r
+: vocab-subdirs ( dir -- dirs )\r
+ [\r
+ [\r
+ { [ link-info directory? ] [ "." head? not ] } 1&&\r
+ ] filter\r
+ ] with-directory-files natural-sort ;\r
+\r
+: (all-child-vocabs) ( root name -- vocabs )\r
+ [\r
+ vocab-dir append-path dup exists?\r
+ [ vocab-subdirs ] [ drop { } ] if\r
+ ] keep\r
+ [ '[ [ _ "." ] dip 3append ] map ] unless-empty ;\r
+\r
+: vocab-dir? ( root name -- ? )\r
+ over\r
+ [ ".factor" vocab-dir+ append-path exists? ]\r
+ [ 2drop f ]\r
+ if ;\r
+\r
+: vocabs-in-dir ( root name -- )\r
+ dupd (all-child-vocabs) [\r
+ 2dup vocab-dir? [ dup >vocab-link , ] when\r
+ vocabs-in-dir\r
+ ] with each ;\r
+\r
+PRIVATE>\r
+\r
+: all-vocabs ( -- assoc )\r
+ vocab-roots get [\r
+ dup [ "" vocabs-in-dir ] { } make\r
+ ] { } map>assoc ;\r
+\r
+: all-vocabs-under ( prefix -- vocabs )\r
+ [\r
+ [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each\r
+ ] { } make ;\r
+\r
+MEMO: all-vocabs-seq ( -- seq )\r
+ "" all-vocabs-under ;\r
+\r
+<PRIVATE\r
+\r
+: unrooted-child-vocabs ( prefix -- seq )\r
+ dup empty? [ CHAR: . suffix ] unless\r
+ vocabs\r
+ [ find-vocab-root not ] filter\r
+ [\r
+ vocab-name swap ?head CHAR: . rot member? not and\r
+ ] with filter\r
+ [ vocab ] map ;\r
+\r
+PRIVATE>\r
+\r
+: all-child-vocabs ( prefix -- assoc )\r
+ vocab-roots get [\r
+ dup pick (all-child-vocabs) [ >vocab-link ] map\r
+ ] { } map>assoc\r
+ swap unrooted-child-vocabs f swap 2array suffix ;\r
+\r
+: all-child-vocabs-seq ( prefix -- assoc )\r
+ vocab-roots get swap '[\r
+ dup _ (all-child-vocabs)\r
+ [ vocab-dir? ] with filter\r
+ ] map concat ;\r
+\r
+<PRIVATE\r
+\r
+: filter-unportable ( seq -- seq' )\r
+ [ vocab-name unportable? not ] filter ;\r
+\r
+PRIVATE>\r
+\r
+: (load) ( prefix -- failures )\r
+ all-vocabs-under\r
+ filter-unportable\r
+ require-all ;\r
+\r
+: load ( prefix -- )\r
+ (load) load-failures. ;\r
+\r
+: load-all ( -- )\r
+ "" load ;\r
+\r
+MEMO: all-tags ( -- seq )\r
+ all-vocabs-seq [ vocab-tags ] gather natural-sort ;\r
+\r
+MEMO: all-authors ( -- seq )\r
+ all-vocabs-seq [ vocab-authors ] gather natural-sort ;
\ No newline at end of file
--- /dev/null
+Searching for vocabularies on disk
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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." } ;
+
--- /dev/null
+! 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
--- /dev/null
+Managing vocabulary author, tag and summary information
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
--- /dev/null
+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
+[ "kernel" ] [ "core/kernel/" resource-path path>vocab ] unit-test
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors assocs command-line concurrency.messaging\r
+continuations init io.backend io.files io.monitors io.pathnames\r
+kernel namespaces sequences sets splitting threads\r
+tr vocabs vocabs.loader vocabs.refresh vocabs.cache ;\r
+IN: vocabs.refresh.monitor\r
+\r
+TR: convert-separators "/\\" ".." ;\r
+\r
+: vocab-dir>vocab-name ( path -- vocab )\r
+ trim-head-separators\r
+ trim-tail-separators\r
+ convert-separators ;\r
+\r
+: path>vocab-name ( path -- vocab )\r
+ dup ".factor" tail? [ parent-directory ] when ;\r
+\r
+: chop-vocab-root ( path -- path' )\r
+ "resource:" prepend-path normalize-path\r
+ dup vocab-roots get\r
+ [ normalize-path ] map\r
+ [ head? ] with find nip\r
+ ?head drop ;\r
+\r
+: path>vocab ( path -- vocab )\r
+ chop-vocab-root path>vocab-name vocab-dir>vocab-name ;\r
+\r
+: monitor-loop ( -- )\r
+ #! On OS X, monitors give us the full path, so we chop it\r
+ #! off if its there.\r
+ receive path>> path>vocab changed-vocab\r
+ reset-cache\r
+ monitor-loop ;\r
+\r
+: add-monitor-for-path ( path -- )\r
+ dup exists? [ t my-mailbox (monitor) ] when drop ;\r
+\r
+: monitor-thread ( -- )\r
+ [\r
+ [\r
+ vocab-roots get prune [ add-monitor-for-path ] each\r
+\r
+ H{ } clone changed-vocabs set-global\r
+ vocabs [ changed-vocab ] each\r
+\r
+ monitor-loop\r
+ ] with-monitors\r
+ ] ignore-errors ;\r
+\r
+: start-monitor-thread ( -- )\r
+ #! Silently ignore errors during monitor creation since\r
+ #! monitors are not supported on all platforms.\r
+ [ monitor-thread ] "Vocabulary monitor" spawn drop ;\r
+\r
+[\r
+ "-no-monitors" (command-line) member?\r
+ [ start-monitor-thread ] unless\r
+] "vocabs.refresh.monitor" add-init-hook\r
--- /dev/null
+Use io.monitors to clear tools.browser authors/tags/summary cache
--- /dev/null
+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"
--- /dev/null
+IN: vocabs.refresh.tests
+USING: vocabs.refresh tools.test continuations namespaces ;
+
+[ ] [
+ changed-vocabs get-global
+ f changed-vocabs set-global
+ [ t ] [ "kernel" changed-vocab? ] unit-test
+ [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
+] unit-test
--- /dev/null
+! 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
--- /dev/null
+Reloading changed vocabularies from disk
USING: alien.syntax kernel math windows.types math.bitwise ;
IN: windows.advapi32
+
LIBRARY: advapi32
CONSTANT: PROV_RSA_FULL 1
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
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
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 ;
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 ;
! : 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 ;
! : 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 ;
! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ;
FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
-! : InitializeSecurityDescriptor ;
+FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ;
! : InitializeSid ;
! : InitiateSystemShutdownA ;
! : InitiateSystemShutdownExA ;
! : 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 ;
! : SetEntriesInAccessListA ;
! : SetEntriesInAccessListW ;
! : SetEntriesInAclA ;
-! : SetEntriesInAclW ;
+FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ;
+ALIAS: SetEntriesInAcl SetEntriesInAclW
! : SetEntriesInAuditListA ;
! : SetEntriesInAuditListW ;
! : SetFileSecurityA ;
! : 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 ;
[ [ 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 ;
--- /dev/null
+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
: (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 )
] ;
: (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
"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 ( -- )
{
} [ first2 (malloc-guid-symbol) ] each ;
: define-joystick-format-constant ( -- )
- c_dfDIJoystick2 global [ [
+ c_dfDIJoystick2 [
DIDF_ABSAXIS
"DIJOYSTATE2" heap-size
"DIJOYSTATE2" {
{ 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" {
{ 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 {
{ 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 {
{ 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
define-format-constants ;
[ define-constants ] "windows.dinput.constants" add-init-hook
-define-constants
+
+: uninitialize ( variable quot -- )
+ '[ _ when* f ] change-global ; inline
: free-dinput-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>
--- /dev/null
+! 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
-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
+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_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 ;
USING: assocs memoize locals kernel accessors init fonts math\r
-combinators windows windows.types windows.gdi32 ;\r
+combinators windows.errors windows.types windows.gdi32 ;\r
IN: windows.fonts\r
\r
: windows-font-name ( string -- string' )\r
--- /dev/null
+unportable
! 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
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
! 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 ) ;
! 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 ) ;
! FUNCTION: LoadLibraryW
! FUNCTION: LoadModule
! FUNCTION: LoadResource
-! FUNCTION: LocalAlloc
+FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ;
! FUNCTION: LocalCompact
! FUNCTION: LocalFileTimeToFileTime
! FUNCTION: LocalFlags
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
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 ;
! 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
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
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? ;
! 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
! 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> ;
TYPEDEF: HANDLE HGLOBAL
TYPEDEF: HANDLE HHOOK
TYPEDEF: HANDLE HINSTANCE
-TYPEDEF: HANDLE HKEY
+TYPEDEF: DWORD HKEY
TYPEDEF: HANDLE HKL
TYPEDEF: HANDLE HLOCAL
TYPEDEF: HANDLE HMENU
! 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 ;
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
: 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 -- )
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
{ "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
! 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
! FUNCTION: GetMessagePos
! FUNCTION: GetMessageTime
! FUNCTION: GetMonitorInfoA
-! FUNCTION: GetMonitorInfoW
+
+FUNCTION: BOOL GetMonitorInfoW ( HMONITOR hMonitor, LPMONITORINFO lpmi ) ;
+ALIAS: GetMonitorInfo GetMonitorInfoW
+
! FUNCTION: GetMouseMovePointsEx
! FUNCTION: GetNextDlgGroupItem
! FUNCTION: GetNextDlgTabItem
! FUNCTION: GetWindowInfo
! FUNCTION: GetWindowLongA
! FUNCTION: GetWindowLongW
+FUNCTION: LONG_PTR GetWindowLongW ( HANDLE hWnd, int index ) ;
+ALIAS: GetWindowLong GetWindowLongW
! FUNCTION: GetWindowModuleFileName
! FUNCTION: GetWindowModuleFileNameA
! FUNCTION: GetWindowModuleFileNameW
! FUNCTION: ModifyMenuW
! FUNCTION: MonitorFromPoint
! FUNCTION: MonitorFromRect
-! FUNCTION: MonitorFromWindow
+FUNCTION: HMONITOR MonitorFromWindow ( HWND hWnd, DWORD dwFlags ) ;
! FUNCTION: mouse_event
! 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
--- /dev/null
+unportable
+bindings
! 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 ;
! 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
: (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) ;
[ "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
} 35 35 wrap-words [ { } like ] map
] unit-test
-\ wrap-words must-infer
{ [ 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
--- /dev/null
+Eduardo Cavazos
+Slava Pestov
! 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
! 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 -- )
! 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
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* ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
! 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
{ 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 )
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 ] [
: 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 ;
--- /dev/null
+! 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
! 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
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 )
[
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
{ "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
! 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
{ "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
! 4.1 - Obtaining Window Information
-FUNCTION: Status XQueryTree (
+X-FUNCTION: Status XQueryTree (
Display* display,
Window w,
Window* root_return,
{ "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,
! 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 ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 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 ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
{ "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
{ "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
{ "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" }
{ "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,
{ "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 * ;
! 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
! 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
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
CONSTANT: None 0
-FUNCTION: int XGrabPointer (
+X-FUNCTION: int XGrabPointer (
Display* display,
Window grab_window,
Bool owner_events,
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
! 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
! 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,
! 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,
! Appendix D - Compatibility Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-FUNCTION: Status XSetStandardProperties (
+X-FUNCTION: Status XSetStandardProperties (
Display* display,
Window w,
char* window_name,
! 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
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
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 ) ;
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
[ "<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
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 ;
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
[ ] [
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 ;
! 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
[ ] [ "<?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
\r
: indent-string ( -- string )\r
xml-pprint? get\r
- [ indentation get indenter get <repetition> concat ]\r
+ [ indentation get indenter get <repetition> "" join ]\r
[ "" ] if ;\r
\r
: ?indent ( -- )\r
tools.test multiline splitting memoize
kernel io.streams.string xml.writer ;
-\ htmlize-file must-infer
-
[ ] [ \ (load-mode) reset-memoized ] unit-test
[ ] [
[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
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 $* ;
$ECHO -n "any of [ $* ]"
fi
$ECHO " and try again."
- exit 1
+ exit_script 1;
fi
}
RET=$?
if [[ $RET -ne 0 ]] ; then
$ECHO $1 failed
- exit 2
+ exit_script 2
fi
}
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
}
check_X11_libraries() {
- check_library_exists GLU
check_library_exists GL
check_library_exists X11
check_library_exists pango-1.0
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
}
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() {
$ECHO "OS, ARCH, or WORD is empty. Please report this."
echo $MAKE_TARGET
- exit 5
+ exit_script 5
fi
}
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
}
}
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
}
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
{ $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: }
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
[ ] [ 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
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 )
--- /dev/null
+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"
--- /dev/null
+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
+
+[ "\u0000ff" ]
+[ "\u0000ff" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello world" ]
+[ "hello world" latin1 string>alien latin1 alien>string ]
+unit-test
+
+[ "hello\u00abcdworld" ]
+[ "hello\u00abcdworld" utf16le string>alien utf16le alien>string ]
+unit-test
+
+[ t ] [ f expired? ] unit-test
+
+[ "hello world" ] [
+ "hello world" ascii malloc-string
+ dup ascii alien>string swap free
+] unit-test
+
+[ "hello world" ] [
+ "hello world" utf16n malloc-string
+ dup utf16n alien>string swap free
+] unit-test
+
+[ f ] [ f utf8 alien>string ] unit-test
+
+[ "hello" ] [ "hello" utf16 encode utf16 decode ] unit-test
+
+[ "hello" ] [ "hello" utf16 string>alien utf16 alien>string ] unit-test
--- /dev/null
+! 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
+
--- /dev/null
+Passing Factor strings as C strings and vice versa
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
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 )
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? ;
-! 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
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
-! 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
"Creating primitives and basic runtime structures..." print flush
-crossref off
-
H{ } clone sub-primitives set
"vocab:bootstrap/syntax.factor" parse-file
"classes.predicate"
"compiler.units"
"continuations.private"
+ "generic.single"
+ "generic.single.private"
"growable"
"hashtables"
"hashtables.private"
"kernel"
"kernel.private"
"math"
+ "math.parser.private"
"math.private"
"memory"
+ "memory.private"
"quotations"
"quotations.private"
"sbufs"
"threads.private"
"tools.profiler.private"
"words"
- "words.private"
"vectors"
"vectors.private"
} [ create-vocab drop ] each
"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
"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 ,
"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
"vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] }
"props"
- { "optimized" read-only }
+ { "direct-entry-def" }
{ "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only }
} define-builtin
[ 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 )) }
{ "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
{ "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 )) }
{ "(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 )) }
{ "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 )) }
{ "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 -- )) }
{ "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
"<PRIVATE"
"BIN:"
"B{"
+ "BV{"
"C:"
"CHAR:"
"DEFER:"
"W{"
"["
"\\"
+ "M\\"
"]"
"delimiter"
"f"
--- /dev/null
+USING: arrays byte-arrays help.markup help.syntax kernel combinators ;\r
+IN: byte-vectors\r
+\r
+ARTICLE: "byte-vectors" "Byte vectors"\r
+"The " { $vocab-link "byte-vectors" } " vocabulary implements resizable mutable sequence of unsigned bytes. Byte vectors implement the " { $link "sequence-protocol" } " and thus all " { $link "sequences" } " can be used with them."\r
+$nl\r
+"Byte vectors form a class:"\r
+{ $subsection byte-vector }\r
+{ $subsection byte-vector? }\r
+"Creating byte vectors:"\r
+{ $subsection >byte-vector }\r
+{ $subsection <byte-vector> }\r
+"Literal syntax:"\r
+{ $subsection POSTPONE: BV{ }\r
+"If you don't care about initial capacity, a more elegant way to create a new byte vector is to write:"\r
+{ $code "BV{ } clone" } ;\r
+\r
+ABOUT: "byte-vectors"\r
+\r
+HELP: byte-vector\r
+{ $description "The class of resizable byte vectors. See " { $link "byte-vectors" } " for information." } ;\r
+\r
+HELP: <byte-vector>\r
+{ $values { "n" "a positive integer specifying initial capacity" } { "byte-vector" byte-vector } }\r
+{ $description "Creates a new byte vector that can hold " { $snippet "n" } " bytes before resizing." } ;\r
+\r
+HELP: >byte-vector\r
+{ $values { "seq" "a sequence" } { "byte-vector" byte-vector } }\r
+{ $description "Outputs a freshly-allocated byte vector with the same elements as a given sequence." }\r
+{ $errors "Throws an error if the sequence contains elements other than integers." } ;\r
+\r
+HELP: BV{\r
+{ $syntax "BV{ elements... }" }\r
+{ $values { "elements" "a list of bytes" } }\r
+{ $description "Marks the beginning of a literal byte vector. Literal byte vectors are terminated by " { $link POSTPONE: } } "." } \r
+{ $examples { $code "BV{ 1 2 3 12 }" } } ;\r
--- /dev/null
+IN: byte-vectors.tests\r
+USING: tools.test byte-vectors vectors sequences kernel\r
+prettyprint ;\r
+\r
+[ 0 ] [ 123 <byte-vector> length ] unit-test\r
+\r
+: do-it ( seq -- seq )\r
+ 123 [ over push ] each ;\r
+\r
+[ t ] [\r
+ 3 <byte-vector> do-it\r
+ 3 <vector> do-it sequence=\r
+] unit-test\r
+\r
+[ t ] [ BV{ } byte-vector? ] unit-test\r
+\r
+[ "BV{ }" ] [ BV{ } unparse ] unit-test\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: arrays kernel kernel.private math sequences\r
+sequences.private growable byte-arrays accessors ;\r
+IN: byte-vectors\r
+\r
+TUPLE: byte-vector\r
+{ underlying byte-array }\r
+{ length array-capacity } ;\r
+\r
+: <byte-vector> ( n -- byte-vector )\r
+ (byte-array) 0 byte-vector boa ; inline\r
+\r
+: >byte-vector ( seq -- byte-vector )\r
+ T{ byte-vector f B{ } 0 } clone-like ;\r
+\r
+M: byte-vector like\r
+ drop dup byte-vector? [\r
+ dup byte-array?\r
+ [ dup length byte-vector boa ] [ >byte-vector ] if\r
+ ] unless ;\r
+\r
+M: byte-vector new-sequence\r
+ drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ;\r
+\r
+M: byte-vector equal?\r
+ over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
+\r
+M: byte-array like\r
+ #! If we have an byte-array, we're done.\r
+ #! If we have a byte-vector, and it's at full capacity,\r
+ #! we're done. Otherwise, call resize-byte-array, which is a\r
+ #! relatively fast primitive.\r
+ drop dup byte-array? [\r
+ dup byte-vector? [\r
+ [ length ] [ underlying>> ] bi\r
+ 2dup length eq?\r
+ [ nip ] [ resize-byte-array ] if\r
+ ] [ >byte-array ] if\r
+ ] unless ;\r
+\r
+M: byte-array new-resizable drop <byte-vector> ;\r
+\r
+INSTANCE: byte-vector growable\r
--- /dev/null
+Growable byte arrays
--- /dev/null
+collections
IN: checksums.tests
USING: checksums tools.test ;
-\ checksum-bytes must-infer
-\ checksum-stream must-infer
-\ checksum-lines must-infer
-\ checksum-file must-infer
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 ;
CONSTANT: crc32-table V{ }
-256 [
+256 iota [
8 [
[ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
] times >bignum
classes.tuple accessors ;\r
IN: classes.algebra.tests\r
\r
-\ class< must-infer\r
-\ class-and must-infer\r
-\ class-or must-infer\r
-\ flatten-class must-infer\r
-\ flatten-builtin-class must-infer\r
-\r
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
\r
: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
\r
[ sa ] [ sa { sa sb sc } min-class ] unit-test\r
\r
+[ f ] [ sa sb classes-intersect? ] unit-test\r
+\r
[ +lt+ ] [ integer sequence class<=> ] unit-test\r
[ +lt+ ] [ sequence object class<=> ] unit-test\r
[ +gt+ ] [ object sequence class<=> ] unit-test\r
[ +eq+ ] [ integer integer class<=> ] unit-test\r
+\r
+! Limitations:\r
+\r
+! UNION: u1 sa sb ;\r
+! UNION: u2 sc ;\r
+\r
+! [ f ] [ u1 u2 classes-intersect? ] unit-test
\ No newline at end of file
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 ;
[
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)
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
[ ] [ [ \ 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
[ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
[ reset-class ]
[ ?define-symbol ]
- [ redefined ]
+ [ changed-definition ]
[ ]
} cleave
] dip [ assoc-union ] curry change-props
[ 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 -- )
[ 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
[ ] [ "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
[ [ 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
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
] 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
" f"
" 3"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
"T{ parsing-corner-case"
" { x 3 }"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
[ T{ parsing-corner-case f 3 } ] [
"T{ parsing-corner-case {"
" x 3 }"
"}"
- } "\n" join eval
+ } "\n" join eval( -- tuple )
] unit-test
{
"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
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 ;
$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
" <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 ;"
" } ;"
""
": 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 ;"
}
-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 ;
[ 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
[ 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
[ 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 ;
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
[ ] [ \ 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 ;
[
[ ] [ \ 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
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
] 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
[ 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
[ ] [ "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
[ 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
[ 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
! 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
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
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 ;
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
] 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
[ 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 ;
[ 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 ;
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 ]
[ 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
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
[ 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
: 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
: blah ( -- vec ) vector new ;
-\ blah must-infer
+[ vector new ] must-infer
[ V{ } ] [ blah ] unit-test
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
[ "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
[ "( 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
] 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 ;
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
{
[ , ]
[ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
- [ superclasses length 1- , ]
+ [ superclasses length 1 - , ]
[ superclasses [ [ , ] [ hashcode , ] bi ] each ]
} cleave
] { } make ;
2drop
[
[ update-tuples-after ]
- [ redefined ]
+ [ changed-definition ]
bi
] each-subclass
]
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
[ 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
[ 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
effects words ;
IN: combinators
-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."
+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
-"Quotations:"
-{ $subsection POSTPONE: call( }
-{ $subsection call-effect }
-"Words:"
-{ $subsection POSTPONE: execute( }
-{ $subsection execute-effect }
-"Unsafe calls:"
-{ $subsection call-effect-unsafe }
-{ $subsection execute-effect-unsafe } ;
+"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: "combinators" "Additional combinators"
-"The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators."
+ARTICLE: "cleave-combinators" "Cleave combinators"
+"The cleave combinators apply multiple quotations to a single value."
$nl
-"Generalization of " { $link bi } " and " { $link tri } ":"
+"Two quotations:"
+{ $subsection bi }
+{ $subsection 2bi }
+{ $subsection 3bi }
+"Three quotations:"
+{ $subsection tri }
+{ $subsection 2tri }
+{ $subsection 3tri }
+"An array of quotations:"
{ $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* } ":"
+"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 }
-"The " { $vocab-link "combinators" } " also provides some less frequently-used features."
+{ $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-unsafe" "Unsafe combinators"
+"Unsafe calls declare an effect statically without any runtime checking:"
+{ $subsection call-effect-unsafe }
+{ $subsection execute-effect-unsafe } ;
+
+ARTICLE: "call" "Fundamental combinators"
+"The most basic combinators are those that take either a quotation or word, and invoke it immediately."
$nl
-"A combinator which can help with implementing methods on " { $link hashcode* } ":"
-{ $subsection recursive-hashcode }
+"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared."
+$nl
+"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"
: 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
: 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
{ [ 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
[ 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
{ [ 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
{
} cond ;
-\ cond-test-4 must-infer
+\ cond-test-4 def>> must-infer
[ cond-test-4 ] [ class \ no-cond = ] must-fail-with
{ 4 [ "four" ] }
} case ;
-\ case-test-1 must-infer
+\ case-test-1 def>> must-infer
[ "two" ] [ 2 case-test-1 ] unit-test
[ sq ]
} case ;
-\ case-test-2 must-infer
+\ case-test-2 def>> must-infer
[ 25 ] [ 5 case-test-2 ] unit-test
[ sq ]
} case ;
-\ case-test-3 must-infer
+\ case-test-3 def>> must-infer
[ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test
[ 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
[ drop "demasiado" print ]
} case ;
-\ case-test-5 must-infer
+\ case-test-5 def>> must-infer
[ ] [ 1 case-test-5 ] unit-test
{ 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
{ \ ] [ "KFC" ] }
} case ;
-\ test-case-7 must-infer
+\ test-case-7 def>> must-infer
[ "plus" ] [ \ + test-case-7 ] unit-test
<< \ 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 ;
] [ callable? ] if
] find nip ;
+\ case-find t "no-compile" set-word-prop
+
: case ( obj assoc -- )
case-find {
{ [ dup array? ] [ nip second call ] }
[ [ [ 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 )
! 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-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." } ;
+++ /dev/null
-! 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
+++ /dev/null
-Compiler warning and error reporting
{ $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 } "." } ;
+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
! 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
[
"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
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
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.
[ 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
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 -- )
[
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
{ $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:"
{ $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" } ;
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 }" }
} ;
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) ;
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
[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
-\ with-datastack must-infer
+[ with-datastack ] must-infer
! 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
<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>
{ $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
{ $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"
{ $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 } ;
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
! 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
SYMBOL: changed-effects
-: changed-effect ( word -- )
- dup changed-effects get set-in-unit ;
-
SYMBOL: changed-generics
SYMBOL: outdated-generics
GENERIC: forget* ( defspec -- )
-M: object forget* drop ;
+M: f forget* drop ;
+
+M: wrapper forget* wrapped>> forget* ;
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 ;
-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" } } }
{ { $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"
{ $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 } }
[ { "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
! 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
: effect-height ( effect -- n )
[ out>> length ] [ in>> length ] bi - ; inline
-: effect<= ( eff1 eff2 -- ? )
+: effect<= ( effect1 effect2 -- ? )
{
{ [ over terminated?>> ] [ t ] }
{ [ dup terminated?>> ] [ f ] }
[ 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" ;
: 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
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"
{ $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"
{ $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"
{ $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." } ;
[ 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 ;
[ 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 ;
[ 3.4 3 ] [ 3.4 tag-and-f ] 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 ( a -- b )
-GENERIC: generic-forget-test-2 ( a b -- c )
+M: f generic-forget-test ;
-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
[ ] [
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
[ ] [ "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
: 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 ;
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 ;
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 ;
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 ;
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: \ ; ;
[ 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
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 ]
}
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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! 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
USING: kernel generic help.markup help.syntax math classes
-sequences quotations ;
+sequences quotations generic.math.private ;
IN: generic.math
HELP: math-upgrade
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 } "." } ;
--- /dev/null
+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
+
+
-! 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
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
[
: 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
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? ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+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' )
+
+M: integer lo-tag-test 3 + ;
+
+M: float lo-tag-test 4 - ;
+
+M: rational lo-tag-test 2 - ;
+
+M: complex lo-tag-test sq ;
+
+[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
+[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
+[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
+[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
+
+GENERIC: hi-tag-test ( obj -- obj' )
+
+M: string hi-tag-test ", in bed" append ;
+
+M: integer hi-tag-test 3 + ;
+
+M: array hi-tag-test [ hi-tag-test ] map ;
+
+M: sequence hi-tag-test reverse ;
+
+[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
+
+[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
+
+[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
+
+TUPLE: shape ;
+
+TUPLE: abstract-rectangle < shape width height ;
+
+TUPLE: rectangle < abstract-rectangle ;
+
+C: <rectangle> rectangle
+
+TUPLE: parallelogram < abstract-rectangle skew ;
+
+C: <parallelogram> parallelogram
+
+TUPLE: circle < shape radius ;
+
+C: <circle> circle
+
+GENERIC: area ( shape -- n )
+
+M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
+
+M: circle area radius>> sq pi * ;
+
+[ 12 ] [ 4 3 <rectangle> area ] unit-test
+[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
+[ t ] [ 2 <circle> area 4 pi * = ] unit-test
+
+GENERIC: perimiter ( shape -- n )
+
+: rectangle-perimiter ( l w -- n ) + 2 * ;
+
+M: rectangle perimiter
+ [ width>> ] [ height>> ] bi
+ rectangle-perimiter ;
+
+: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
+
+M: parallelogram perimiter
+ [ width>> ]
+ [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
+ rectangle-perimiter ;
+
+M: circle perimiter 2 * pi * ;
+
+[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
+[ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+
+GENERIC: big-mix-test ( obj -- obj' )
+
+M: object big-mix-test drop "object" ;
+
+M: tuple big-mix-test drop "tuple" ;
+
+M: integer big-mix-test drop "integer" ;
+
+M: float big-mix-test drop "float" ;
+
+M: complex big-mix-test drop "complex" ;
+
+M: string big-mix-test drop "string" ;
+
+M: array big-mix-test drop "array" ;
+
+M: sequence big-mix-test drop "sequence" ;
+
+M: rectangle big-mix-test drop "rectangle" ;
+
+M: parallelogram big-mix-test drop "parallelogram" ;
+
+M: circle big-mix-test drop "circle" ;
+
+[ "integer" ] [ 3 big-mix-test ] unit-test
+[ "float" ] [ 5.0 big-mix-test ] unit-test
+[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
+[ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test
+[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
+[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
+[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
+[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
+[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
+[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
+[ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test
+[ "string" ] [ "hello" big-mix-test ] unit-test
+[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
+[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
+[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
+[ "tuple" ] [ H{ } big-mix-test ] unit-test
+[ "object" ] [ \ + big-mix-test ] unit-test
+
+GENERIC: small-lo-tag ( obj -- obj )
+
+M: fixnum small-lo-tag drop "fixnum" ;
+
+M: string small-lo-tag drop "string" ;
+
+M: array small-lo-tag drop "array" ;
+
+M: double-array small-lo-tag drop "double-array" ;
+
+M: byte-array small-lo-tag drop "byte-array" ;
+
+[ "fixnum" ] [ 3 small-lo-tag ] unit-test
+
+[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test
+
+! Testing next-method
+TUPLE: person ;
+
+TUPLE: intern < person ;
+
+TUPLE: employee < person ;
+
+TUPLE: tape-monkey < employee ;
+
+TUPLE: manager < employee ;
+
+TUPLE: junior-manager < manager ;
+
+TUPLE: middle-manager < manager ;
+
+TUPLE: senior-manager < manager ;
+
+TUPLE: executive < senior-manager ;
+
+TUPLE: ceo < executive ;
+
+GENERIC: salary ( person -- n )
+
+M: intern salary
+ #! Intentional mistake.
+ call-next-method ;
+
+M: employee salary drop 24000 ;
+
+M: manager salary call-next-method 12000 + ;
+
+M: middle-manager salary call-next-method 5000 + ;
+
+M: senior-manager salary call-next-method 15000 + ;
+
+M: executive salary call-next-method 2 * ;
+
+M: ceo salary
+ #! Intentional error.
+ drop 5 call-next-method 3 * ;
+
+[ salary ] must-infer
+
+[ 24000 ] [ employee boa salary ] unit-test
+
+[ 24000 ] [ tape-monkey boa salary ] unit-test
+
+[ 36000 ] [ junior-manager boa salary ] unit-test
+
+[ 41000 ] [ middle-manager boa salary ] unit-test
+
+[ 51000 ] [ senior-manager boa salary ] unit-test
+
+[ 102000 ] [ executive boa salary ] unit-test
+
+[ ceo boa salary ]
+[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
+
+[ intern boa salary ]
+[ no-next-method? ] must-fail-with
+
+! Weird shit
+TUPLE: a ;
+TUPLE: b ;
+TUPLE: c ;
+
+UNION: x a b ;
+UNION: y a c ;
+
+UNION: z x y ;
+
+GENERIC: funky* ( obj -- )
+
+M: z funky* "z" , drop ;
+
+M: x funky* "x" , call-next-method ;
+
+M: y funky* "y" , call-next-method ;
+
+M: a funky* "a" , call-next-method ;
+
+M: b funky* "b" , call-next-method ;
+
+M: c funky* "c" , call-next-method ;
+
+: funky ( obj -- seq ) [ funky* ] { } make ;
+
+[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
+
+[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
+
+[ t ] [
+ T{ a } funky
+ { { "a" "x" "z" } { "a" "y" "z" } } member?
+] unit-test
+
+! Hooks
+SYMBOL: my-var
+HOOK: my-hook my-var ( -- x )
+
+M: integer my-hook "an integer" ;
+M: string my-hook "a string" ;
+
+[ "an integer" ] [ 3 my-var set my-hook ] unit-test
+[ "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: call-next-hooker my-var ( -- x )
+
+M: sequence call-next-hooker "sequence" ;
+
+M: array call-next-hooker call-next-method "array " prepend ;
+
+M: vector call-next-hooker call-next-method "vector " prepend ;
+
+M: growable call-next-hooker call-next-method "growable " prepend ;
+
+[ "vector growable sequence" ] [
+ V{ } my-var [ call-next-hooker ] with-variable
+] unit-test
+
+[ t ] [
+ { } \ 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
--- /dev/null
+! 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 ;
-Slava Pestov
+Slava Pestov
\ No newline at end of file
+++ /dev/null
-! 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 )
+++ /dev/null
-! 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 ;
+++ /dev/null
-Chained-conditional dispatch strategy
+++ /dev/null
-Generic word dispatch strategy implementation
+++ /dev/null
-Jump table keyed by pointer tag dispatch strategy
+++ /dev/null
-! 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 ;
+++ /dev/null
-Tuple class dispatch strategy
+++ /dev/null
-! 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 ;
-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."
}
} ;
-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
+++ /dev/null
-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 ;
-
-GENERIC: lo-tag-test ( obj -- obj' )
-
-M: integer lo-tag-test 3 + ;
-
-M: float lo-tag-test 4 - ;
-
-M: rational lo-tag-test 2 - ;
-
-M: complex lo-tag-test sq ;
-
-[ 8 ] [ 5 >bignum lo-tag-test ] unit-test
-[ 0.0 ] [ 4.0 lo-tag-test ] unit-test
-[ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
-[ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
-
-GENERIC: hi-tag-test ( obj -- obj' )
-
-M: string hi-tag-test ", in bed" append ;
-
-M: integer hi-tag-test 3 + ;
-
-M: array hi-tag-test [ hi-tag-test ] map ;
-
-M: sequence hi-tag-test reverse ;
-
-[ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
-
-[ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
-
-[ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
-
-TUPLE: shape ;
-
-TUPLE: abstract-rectangle < shape width height ;
-
-TUPLE: rectangle < abstract-rectangle ;
-
-C: <rectangle> rectangle
-
-TUPLE: parallelogram < abstract-rectangle skew ;
-
-C: <parallelogram> parallelogram
-
-TUPLE: circle < shape radius ;
-
-C: <circle> circle
-
-GENERIC: area ( shape -- n )
-
-M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
-
-M: circle area radius>> sq pi * ;
-
-[ 12 ] [ 4 3 <rectangle> area ] unit-test
-[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
-[ t ] [ 2 <circle> area 4 pi * = ] unit-test
-
-GENERIC: perimiter ( shape -- n )
-
-: rectangle-perimiter ( n -- n ) + 2 * ;
-
-M: rectangle perimiter
- [ width>> ] [ height>> ] bi
- rectangle-perimiter ;
-
-: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
-
-M: parallelogram perimiter
- [ width>> ]
- [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
- rectangle-perimiter ;
-
-M: circle perimiter 2 * pi * ;
-
-[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
-[ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
-
-GENERIC: big-mix-test ( obj -- obj' )
-
-M: object big-mix-test drop "object" ;
-
-M: tuple big-mix-test drop "tuple" ;
-
-M: integer big-mix-test drop "integer" ;
-
-M: float big-mix-test drop "float" ;
-
-M: complex big-mix-test drop "complex" ;
-
-M: string big-mix-test drop "string" ;
-
-M: array big-mix-test drop "array" ;
-
-M: sequence big-mix-test drop "sequence" ;
-
-M: rectangle big-mix-test drop "rectangle" ;
-
-M: parallelogram big-mix-test drop "parallelogram" ;
-
-M: circle big-mix-test drop "circle" ;
-
-[ "integer" ] [ 3 big-mix-test ] unit-test
-[ "float" ] [ 5.0 big-mix-test ] unit-test
-[ "complex" ] [ -1 sqrt big-mix-test ] unit-test
-[ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test
-[ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
-[ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
-[ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
-[ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
-[ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
-[ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
-[ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test
-[ "string" ] [ "hello" big-mix-test ] unit-test
-[ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
-[ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
-[ "circle" ] [ 100 <circle> big-mix-test ] unit-test
-[ "tuple" ] [ H{ } big-mix-test ] unit-test
-[ "object" ] [ \ + big-mix-test ] unit-test
-
-GENERIC: small-lo-tag ( obj -- obj )
-
-M: fixnum small-lo-tag drop "fixnum" ;
-
-M: string small-lo-tag drop "string" ;
-
-M: array small-lo-tag drop "array" ;
-
-M: double-array small-lo-tag drop "double-array" ;
-
-M: byte-array small-lo-tag drop "byte-array" ;
-
-[ "fixnum" ] [ 3 small-lo-tag ] unit-test
-
-[ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test
-
-! Testing next-method
-TUPLE: person ;
-
-TUPLE: intern < person ;
-
-TUPLE: employee < person ;
-
-TUPLE: tape-monkey < employee ;
-
-TUPLE: manager < employee ;
-
-TUPLE: junior-manager < manager ;
-
-TUPLE: middle-manager < manager ;
-
-TUPLE: senior-manager < manager ;
-
-TUPLE: executive < senior-manager ;
-
-TUPLE: ceo < executive ;
-
-GENERIC: salary ( person -- n )
-
-M: intern salary
- #! Intentional mistake.
- call-next-method ;
-
-M: employee salary drop 24000 ;
-
-M: manager salary call-next-method 12000 + ;
-
-M: middle-manager salary call-next-method 5000 + ;
-
-M: senior-manager salary call-next-method 15000 + ;
-
-M: executive salary call-next-method 2 * ;
-
-M: ceo salary
- #! Intentional error.
- drop 5 call-next-method 3 * ;
-
-[ salary ] must-infer
-
-[ 24000 ] [ employee boa salary ] unit-test
-
-[ 24000 ] [ tape-monkey boa salary ] unit-test
-
-[ 36000 ] [ junior-manager boa salary ] unit-test
-
-[ 41000 ] [ middle-manager boa salary ] unit-test
-
-[ 51000 ] [ senior-manager boa salary ] unit-test
-
-[ 102000 ] [ executive boa salary ] unit-test
-
-[ ceo boa salary ]
-[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
-
-[ intern boa salary ]
-[ no-next-method? ] must-fail-with
-
-! Weird shit
-TUPLE: a ;
-TUPLE: b ;
-TUPLE: c ;
-
-UNION: x a b ;
-UNION: y a c ;
-
-UNION: z x y ;
-
-GENERIC: funky* ( obj -- )
-
-M: z funky* "z" , drop ;
-
-M: x funky* "x" , call-next-method ;
-
-M: y funky* "y" , call-next-method ;
-
-M: a funky* "a" , call-next-method ;
-
-M: b funky* "b" , call-next-method ;
-
-M: c funky* "c" , call-next-method ;
-
-: funky ( obj -- seq ) [ funky* ] { } make ;
-
-[ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
-
-[ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
-
-[ t ] [
- T{ a } funky
- { { "a" "x" "z" } { "a" "y" "z" } } member?
-] unit-test
-
-! Hooks
-SYMBOL: my-var
-HOOK: my-hook my-var ( -- x )
-
-M: integer my-hook "an integer" ;
-M: string my-hook "a string" ;
-
-[ "an integer" ] [ 3 my-var set my-hook ] unit-test
-[ "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" ;
-
-M: array call-next-hooker call-next-method "array " prepend ;
-
-M: vector call-next-hooker call-next-method "vector " prepend ;
-
-M: growable call-next-hooker call-next-method "growable " prepend ;
-
-[ "vector growable sequence" ] [
- 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?
-] unit-test
-
-[ t ] [
- \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
-] unit-test
-! 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
-
-M: standard-generic extra-values drop 0 ;
-
-M: standard-combination make-default-method
- [ error-method ] with-standard ;
+: (picker) ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1 - (picker) [ dip swap ] curry ]
+ } case ;
-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 ;
-
-TUPLE: hook-combination var ;
-
-C: <hook-combination> hook-combination
-
-PREDICATE: hook-generic < generic
- "combination" word-prop hook-combination? ;
-
-: with-hook ( combination quot -- quot' )
- 0 (dispatch#) [
- [ hook-combination ] dip with-variable
- ] with-variable ; inline
+ [ datastack ] dip [ "combination" word-prop #>> swap <reversed> nth ] keep
+ (effective-method) ;
-: prepend-hook-var ( quot -- quot' )
- hook-combination get var>> [ get ] curry prepend ;
+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 ;
-M: hook-combination dispatch# drop 0 ;
+: make-empty-cache ( -- array )
+ mega-cache-size get f <array> ;
-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 ;
+++ /dev/null
-Standard method combination used for most generic words
] if
(>>length) ;
-: new-size ( old -- new ) 1+ 3 * ; inline
+: new-size ( old -- new ) 1 + 3 * ; inline
: ensure ( n seq -- n seq )
growable-check
{ $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
[ 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
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
[ 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) ;
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
! 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
"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"
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
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+UTF16 encoding/decoding
--- /dev/null
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.encodings strings ;
+IN: io.encodings.utf16
+
+ARTICLE: "io.encodings.utf16" "UTF-16 encoding"
+"The UTF-16 encoding is a variable-width encoding. Unicode code points are encoded as 2 or 4 byte sequences. There are three encoding descriptor classes for working with UTF-16, depending on endianness or the presence of a BOM:"
+{ $subsection utf16 }
+{ $subsection utf16le }
+{ $subsection utf16be } ;
+
+ABOUT: "io.encodings.utf16"
+
+HELP: utf16le
+{ $class-description "The encoding descriptor for UTF-16LE, that is, UTF-16 in little endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf16be
+{ $class-description "The encoding descriptor for UTF-16BE, that is, UTF-16 in big endian, without a byte order mark. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+HELP: utf16
+{ $class-description "The encoding descriptor for UTF-16, that is, UTF-16 with a byte order mark. This is the most useful for general input and output in UTF-16. Streams can be made which read or write wth this encoding." }
+{ $see-also "encodings-introduction" } ;
+
+{ utf16 utf16le utf16be } related-words
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
+IN: io.encodings.utf16
+
+SINGLETON: utf16be
+
+SINGLETON: utf16le
+
+SINGLETON: utf16
+
+ERROR: missing-bom ;
+
+<PRIVATE
+
+! UTF-16BE decoding
+
+: append-nums ( byte ch -- ch )
+ over [ 8 shift bitor ] [ 2drop replacement-char ] if ;
+
+: double-be ( stream byte -- stream char )
+ over stream-read1 swap append-nums ;
+
+: quad-be ( stream byte -- stream char )
+ double-be over stream-read1 [
+ dup -2 shift BIN: 110111 number= [
+ [ 2 shift ] dip BIN: 11 bitand bitor
+ over stream-read1 swap append-nums HEX: 10000 +
+ ] [ 2drop dup stream-read1 drop replacement-char ] if
+ ] when* ;
+
+: ignore ( stream -- stream char )
+ dup stream-read1 drop replacement-char ;
+
+: begin-utf16be ( stream byte -- stream char )
+ dup -3 shift BIN: 11011 number= [
+ dup BIN: 00000100 bitand zero?
+ [ BIN: 11 bitand quad-be ]
+ [ drop ignore ] if
+ ] [ double-be ] if ;
+
+M: utf16be decode-char
+ drop dup stream-read1 dup [ begin-utf16be ] when nip ;
+
+! UTF-16LE decoding
+
+: quad-le ( stream ch -- stream char )
+ over stream-read1 swap 10 shift bitor
+ over stream-read1 dup -2 shift BIN: 110111 = [
+ BIN: 11 bitand append-nums HEX: 10000 +
+ ] [ 2drop replacement-char ] if ;
+
+: double-le ( stream byte1 byte2 -- stream char )
+ dup -3 shift BIN: 11011 = [
+ dup BIN: 100 bitand 0 number=
+ [ BIN: 11 bitand 8 shift bitor quad-le ]
+ [ 2drop replacement-char ] if
+ ] [ append-nums ] if ;
+
+: begin-utf16le ( stream byte -- stream char )
+ over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
+
+M: utf16le decode-char
+ drop dup stream-read1 dup [ begin-utf16le ] when nip ;
+
+! UTF-16LE/BE encoding
+
+: encode-first ( char -- byte1 byte2 )
+ -10 shift
+ dup -8 shift BIN: 11011000 bitor
+ swap HEX: FF bitand ;
+
+: encode-second ( char -- byte3 byte4 )
+ BIN: 1111111111 bitand
+ dup -8 shift BIN: 11011100 bitor
+ swap BIN: 11111111 bitand ;
+
+: stream-write2 ( stream char1 char2 -- )
+ rot [ stream-write1 ] curry bi@ ;
+
+: char>utf16be ( stream char -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ 2dup encode-first stream-write2
+ encode-second stream-write2
+ ] [ h>b/b swap stream-write2 ] if ;
+
+M: utf16be encode-char ( char stream encoding -- )
+ drop swap char>utf16be ;
+
+: char>utf16le ( char stream -- )
+ dup HEX: FFFF > [
+ HEX: 10000 -
+ 2dup encode-first swap stream-write2
+ encode-second swap stream-write2
+ ] [ h>b/b stream-write2 ] if ;
+
+M: utf16le encode-char ( char stream encoding -- )
+ drop swap char>utf16le ;
+
+! UTF-16
+
+CONSTANT: bom-le B{ HEX: ff HEX: fe }
+
+CONSTANT: bom-be B{ HEX: fe HEX: ff }
+
+: bom>le/be ( bom -- le/be )
+ dup bom-le sequence= [ drop utf16le ] [
+ bom-be sequence= [ utf16be ] [ missing-bom ] if
+ ] if ;
+
+M: utf16 <decoder> ( stream utf16 -- decoder )
+ drop 2 over stream-read bom>le/be <decoder> ;
+
+M: utf16 <encoder> ( stream utf16 -- encoder )
+ drop bom-le over stream-write utf16le <encoder> ;
+
+PRIVATE>
--- /dev/null
+Daniel Ehrenberg
--- /dev/null
+UTF16 encoding with native byte order
--- /dev/null
+USING: help.markup help.syntax ;
+IN: io.encodings.utf16n
+
+HELP: utf16n
+{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" }
+{ $see-also "encodings-introduction" } ;
--- /dev/null
+USING: accessors alien.c-types kernel
+io.encodings.utf16 io.streams.byte-array tools.test ;
+IN: io.encodings.utf16n
+
+: correct-endian ( obj -- ? )
+ code>> little-endian? [ utf16le = ] [ utf16be = ] if ;
+
+[ t ] [ B{ } utf16n <byte-reader> correct-endian ] unit-test
+[ t ] [ utf16n <byte-writer> correct-endian ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.encodings io.encodings.utf16 kernel alien.accessors ;
+IN: io.encodings.utf16n
+
+! Native-order UTF-16
+
+SINGLETON: utf16n
+
+: utf16n ( -- descriptor )
+ B{ 1 0 0 0 } 0 alien-unsigned-4 1 = utf16le utf16be ? ; foldable
+
+M: utf16n <decoder> drop utf16n <decoder> ;
+
+M: utf16n <encoder> drop utf16n <encoder> ;
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
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> }
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
-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
-! 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 )
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
: 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
[
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
{ $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." } ;
{ $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"
"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" }
: 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 ) -- )
: 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
[ 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 -- ? )
dup root-directory? [
trim-tail-separators
dup last-path-separator [
- 1+ cut
+ 1 + cut
] [
drop "." swap
] if
: 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 ;
--- /dev/null
+USING: help.syntax help.markup io byte-arrays quotations ;
+IN: io.streams.byte-array
+
+ABOUT: "io.streams.byte-array"
+
+ARTICLE: "io.streams.byte-array" "Byte-array streams"
+"Byte array streams:"
+{ $subsection <byte-reader> }
+{ $subsection <byte-writer> }
+"Utility combinators:"
+{ $subsection with-byte-reader }
+{ $subsection with-byte-writer } ;
+
+HELP: <byte-reader>
+{ $values { "byte-array" byte-array }
+ { "encoding" "an encoding descriptor" }
+ { "stream" "a new byte reader" } }
+{ $description "Creates an input stream reading from a byte array using an encoding." } ;
+
+HELP: <byte-writer>
+{ $values { "encoding" "an encoding descriptor" }
+ { "stream" "a new byte writer" } }
+{ $description "Creates an output stream writing data to a byte array using an encoding." } ;
+
+HELP: with-byte-reader
+{ $values { "encoding" "an encoding descriptor" }
+ { "quot" quotation } { "byte-array" byte-array } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link input-stream } " rebound to an input stream for reading from a byte array using an encoding." } ;
+
+HELP: with-byte-writer
+{ $values { "encoding" "an encoding descriptor" }
+ { "quot" quotation }
+ { "byte-array" byte-array } }
+{ $description "Calls the quotation in a new dynamic scope with " { $link output-stream } " rebound to an output stream writing data to a byte array using an encoding." } ;
--- /dev/null
+USING: tools.test io.streams.byte-array io.encodings.binary
+io.encodings.utf8 io kernel arrays strings namespaces ;
+
+[ 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 } >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
+ [ 1 read drop "\0" read-until ] with-byte-reader
+] unit-test
+
+[ 1 1 4 11 f ] [
+ B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
+ [
+ read1
+ 0 seek-absolute input-stream get stream-seek
+ read1
+ 2 seek-relative input-stream get stream-seek
+ read1
+ -2 seek-end input-stream get stream-seek
+ read1
+ 0 seek-end input-stream get stream-seek
+ read1
+ ] with-byte-reader
+] unit-test
--- /dev/null
+! Copyright (C) 2008, 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+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
+
+M: byte-vector stream-element-type drop +byte+ ;
+
+: <byte-writer> ( encoding -- stream )
+ 512 <byte-vector> swap <encoder> ;
+
+: with-byte-writer ( encoding quot -- byte-array )
+ [ <byte-writer> ] dip [ output-stream get ] compose with-output-stream*
+ dup encoder? [ stream>> ] when >byte-array ; inline
+
+TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ;
+
+M: byte-reader stream-element-type drop +byte+ ;
+
+M: byte-reader stream-read-partial stream-read ;
+M: byte-reader stream-read sequence-read ;
+M: byte-reader stream-read1 sequence-read1 ;
+M: byte-reader stream-read-until sequence-read-until ;
+M: byte-reader dispose drop ;
+
+M: byte-reader stream-seek ( n seek-type stream -- )
+ swap {
+ { seek-absolute [ (>>i) ] }
+ { seek-relative [ [ + ] change-i drop ] }
+ { seek-end [ [ underlying>> length + ] keep (>>i) ] }
+ [ bad-seek-type ]
+ } case ;
+
+: <byte-reader> ( byte-array encoding -- stream )
+ [ B{ } like 0 byte-reader boa ] dip <decoder> ;
+
+: with-byte-reader ( byte-array encoding quot -- )
+ [ <byte-reader> ] dip with-input-stream* ; inline
--- /dev/null
+Streams for reading and writing bytes in a byte array
{ $description "Creates a stream which writes data by calling C standard library functions." }
{ $notes "Usually C streams are only used during bootstrap, and non-blocking OS-specific I/O routines are used during normal operation." } ;
-HELP: fopen ( path mode -- alien )
+HELP: fopen
{ $values { "path" "a pathname string" } { "mode" "an access mode specifier" } { "alien" "a C FILE* handle" } }
{ $description "Opens a file named by " { $snippet "path" } ". The " { $snippet "mode" } " parameter should be something like " { $snippet "\"r\"" } " or " { $snippet "\"rw\"" } "; consult the " { $snippet "fopen(3)" } " manual page for details." }
{ $errors "Throws an error if the file could not be opened." }
[ "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
! 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 ;
M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ;
+: fopen ( path mode -- alien )
+ [ utf8 string>alien ] bi@ (fopen) ;
+
M: c-io-backend (file-reader)
"rb" fopen <c-reader> ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors alien alien.accessors math io ;
+IN: io.streams.memory
+
+TUPLE: memory-stream alien index ;
+
+: <memory-stream> ( alien -- stream )
+ 0 memory-stream boa ;
+
+M: memory-stream stream-element-type drop +byte+ ;
+
+M: memory-stream stream-read1
+ [ [ alien>> ] [ index>> ] bi alien-unsigned-1 ]
+ [ [ 1+ ] change-index drop ] bi ;
--- /dev/null
+Streams for reading data directly from memory
[ 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
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
{ $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 } "." } ;
{ $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.." }
{ $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
{ $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"
-
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
: overflow-d ( -- ) 3 overflow-d ;
-[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with
+: (overflow-d-alt) ( -- n ) 3 ;
-[ ] [ :c ] unit-test
+: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
-: (overflow-d-alt) ( -- ) 3 ;
+: overflow-r ( -- ) 3 load-local overflow-r ;
-: overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ;
+<<
+{ 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 ] [ { "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
[ ] [ :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
! 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
[ 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
: 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
-! 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 ;
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 ;
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
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 ;
: 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 ;
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 -- ? )
[ 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
[ 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 ]
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 ;
! 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
! 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 > ]
! 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
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
{ $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."
-! 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
: 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 -- ? )
] 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
#! 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>
[ call ] 2keep rot [
drop
] [
- [ 1- ] dip find-last-integer
+ [ 1 - ] dip find-last-integer
] if
] if ; inline recursive
{ $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 <=> }
{ $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"
-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
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 } "." } ;
$nl
"Outputs " { $link f } " if the string does not represent a float." } ;
-HELP: float>string ( n -- str )
+HELP: float>string
{ $values { "n" real } { "str" string } }
{ $description "Primitive for getting a string representation of a float." }
{ $notes "The " { $link number>string } " word is more general." } ;
[ 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
-! 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 )
{ 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>
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 -- )
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> ;
[ ".0" append ]
} cond ;
+: float>string ( n -- 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 ;
classes.builtin arrays quotations io.launcher system ;
IN: memory.tests
+[ ] [ { } { } become ] unit-test
+
! LOL
[ ] [
vm
[ [ ] 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 ;
-! 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 -- ) -- )
[ 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 ;
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"
{ $subsection off }
{ $subsection inc }
{ $subsection dec }
-{ $subsection change } ;
+{ $subsection change }
+{ $subsection change-global } ;
ARTICLE: "namespaces-global" "Global variables"
{ $subsection namespace }
{ $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" } ")."
"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." ;
{ $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." }
} ;
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
{ $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
: 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
"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"
{ $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" } }
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
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
[ \ 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
[ \ 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 ] [
] 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
] 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
] [ 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 ] [
] 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
] 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
[ 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
[ 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
! 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 ;
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
[ 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
! 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 )
"math.order"
"memory"
"namespaces"
+ "parser"
"prettyprint"
"see"
"sequences"
"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
: finish-parsing ( lines quot -- )
file get
- [ record-form ]
+ [ record-top-level-form ]
[ record-definitions ]
[ record-checksum ]
tri ;
: parse-stream ( stream name -- quot )
[
[
- lines dup parse-fresh
+ stream-lines dup parse-fresh
[ nip ] [ finish-parsing ] 2bi
forget-smudged
] with-source-file
: 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
"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"
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
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
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 ."
"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 }
{ $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? }
"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" }
{ $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" } ;
[ -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
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 ;
] 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 )
[ 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
[ [ 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 -- )
[ empty? not ] filter ;
: mismatch ( seq1 seq2 -- i )
- [ min-length ] 2keep
+ [ min-length iota ] 2keep
[ 2nth-unsafe = not ] 2curry
find drop ; inline
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
: (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
[ 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
2over = [
2drop 2drop
] [
- [ [ 2over + pick ] dip move [ 1+ ] dip ] keep
+ [ [ 2over + pick ] dip move [ 1 + ] dip ] keep
move-backward
] if ;
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 ;
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
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 ]
: reverse-here ( seq -- )
[ length 2/ ] [ length ] [ ] tri
- [ [ over - 1- ] dip exchange-unsafe ] 2curry each ;
+ [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
: reverse ( seq -- newseq )
[
PRIVATE>
: start* ( subseq seq n -- i )
- pick length pick length swap - 1+
+ pick length pick length swap - 1 +
[ (start) ] find-from
swap [ 3drop ] dip ;
-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"
{ $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
{ $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 } }" }
"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."
{ $subsection define-changer }
{ $subsection define-slot-methods }
{ $subsection define-accessors }
+"Unsafe slot access:"
+{ $subsection slot }
+{ $subsection set-slot }
{ $see-also "accessors" "mirrors" } ;
ABOUT: "slots"
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 ;
[ 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
[
\ 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 ;
[ 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 ;
[ [ [ 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
[ [ 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
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 [
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! 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
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 }
{ $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:"
{ $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" } }
-! 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 ;
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 ;
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
: (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) ;
[ "\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
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"
"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"
{ $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
{ $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" } ;
{ $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 ))" }
{ $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"
}
} ;
"<PRIVATE"
""
": (fac) ( accum n -- n! )"
- " dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
+ " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
""
"PRIVATE>"
""
"IN: factorial.private"
""
": (fac) ( accum n -- n! )"
- " dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
+ " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
""
"IN: factorial"
""
{ $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."
} ;
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
! 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
"{" [ \ } [ >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
-! 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
: 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 ;
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" } }
-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...
[ ] [
[ 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 ( -- ) ;
forget-junk
[ { } ] [
- "IN: xabbabbja" eval "xabbabbja" vocab-files
+ "IN: xabbabbja" eval( -- ) "xabbabbja" vocab-files
] unit-test
[ "xabbabbja" forget-vocab ] with-compilation-unit
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
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 ;
[
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
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 ;
: 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 ;
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
! 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 ;
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
--- /dev/null
+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"
--- /dev/null
+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
-! 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
! 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 ;
M: symbol definition drop f ;
: define-symbol ( word -- )
- dup define-constant ;
+ dup [ ] curry (( -- value )) define-inline ;
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
{ $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: : }
{ $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." ;
": 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."
{ { { $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" }
"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:"
"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: } "." } ;
"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 } "." }
[ 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
! 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
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
[ ] [ "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
[ 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
[ { } ]
keys [ "forgotten" word-prop ] any?
] filter
] unit-test
-
-[ { } ] [
- crossref get keys
- [ word? ] filter [ "forgotten" word-prop ] filter
-] unit-test
! 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 ;
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
: inline? ( word -- ? ) "inline" word-prop ; inline
-SYMBOL: visited
-
-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 ;
+GENERIC: subwords ( word -- seq )
-: 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 ;
[ 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 ;
"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> ;
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*
M: word literalize <wrapper> ;
-: xref-words ( -- ) all-words [ xref ] each ;
-
INSTANCE: word definition
\ No newline at end of file
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!\r
\r
! namespace utilities\r
- \r
-: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;\r
\r
: closed-quot ( quot -- quot )\r
namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;\r
3 model-projection <model> view4> (>>model) ;\r
\r
: camera-action ( quot -- quot ) \r
- [ drop [ ] observer3d> \r
+ '[ drop _ observer3d> \r
with-self update-observer-projections ] \r
- make* closed-quot ;\r
+ closed-quot ;\r
\r
: win3D ( text gadget -- ) \r
"navigateur 4D : " rot append open-window ;\r
\r
: add-keyboard-delegate ( obj -- obj )\r
<handler>\r
-{\r
+H{\r
{ T{ key-down f f "LEFT" } \r
[ [ rotation-step turn-left ] camera-action ] }\r
{ T{ key-down f f "RIGHT" } \r
{ T{ key-down f f "3" } [ mvt-3D-3 camera-action ] }\r
{ T{ key-down f f "4" } [ mvt-3D-4 camera-action ] }\r
\r
- } [ make* ] map >hashtable >>table\r
+ } >>table\r
; \r
\r
! --------------------------------------------\r
-USING: kernel namespaces math.vectors opengl 4DNav.turtle ;
+USING: kernel namespaces math.vectors opengl opengl.glu 4DNav.turtle ;
IN: 4DNav.camera
: init-filelist-model ( file-chooser -- file-chooser )\r
dup list-of-files <model> >>model ; \r
\r
-: (fc-go) ( file-chooser quot -- )\r
+: (fc-go) ( file-chooser button quot -- )\r
[ [ file-chooser? ] find-parent dup path>> ] dip\r
call\r
normalize-path swap set-model\r
update-filelist-model\r
- drop ;\r
+ drop ; inline\r
\r
-: fc-go-parent ( file-chooser -- )\r
+: fc-go-parent ( file-chooser button -- )\r
[ dup value>> parent-directory ] (fc-go) ;\r
\r
-: fc-go-home ( file-chooser -- )\r
+: fc-go-home ( file-chooser button -- )\r
[ home ] (fc-go) ;\r
\r
: fc-change-directory ( file-chooser file -- )\r
;\r
\r
: fc-load-file ( file-chooser file -- )\r
- dupd [ selected-file>> ] [ name>> ] bi* swap set-model \r
- [ path>> value>> ] \r
- [ selected-file>> value>> append ] \r
- [ hook>> ] tri\r
- call\r
+ over [ name>> ] [ selected-file>> ] bi* set-model \r
+ [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi\r
+ call( path -- )\r
; inline\r
\r
! : fc-ok-action ( file-chooser -- quot )\r
+++ /dev/null
-IN: advice
-USING: help.markup help.syntax tools.annotations words coroutines ;
-
-HELP: make-advised
-{ $values { "word" "a word to annotate in preparation of advising" } }
-{ $description "Prepares a word for being advised. This is done by: "
- { $list
- { "Annotating it to call the appropriate words before, around, and after the original body " }
- { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
- { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
- }
-}
-{ $see-also advised? annotate } ;
-
-HELP: advised?
-{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
-{ $description "Determines whether or not the given word has any advice on it." } ;
-
-HELP: ad-do-it
-{ $values { "input" "an object" } { "result" "an object" } }
-{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
-{ $see-also coyield } ;
-
-ARTICLE: "advice" "Advice"
-"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
-
-ABOUT: "advice"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences io io.streams.string math tools.test advice math.parser
-parser namespaces multiline eval words assocs ;
-IN: advice.tests
-
-[
- [ ad-do-it ] must-fail
-
- : foo ( -- str ) "foo" ;
- \ foo make-advised
-
- { "bar" "foo" } [
- [ "bar" ] "barify" \ foo advise-before
- foo
- ] unit-test
-
- { "bar" "foo" "baz" } [
- [ "baz" ] "bazify" \ foo advise-after
- foo
- ] unit-test
-
- { "foo" "baz" } [
- "barify" \ foo before remove-advice
- foo
- ] unit-test
-
- : bar ( a -- b ) 1+ ;
- \ bar make-advised
-
- { 11 } [
- [ 2 * ] "double" \ bar advise-before
- 5 bar
- ] unit-test
-
- { 11/3 } [
- [ 3 / ] "third" \ bar advise-after
- 5 bar
- ] unit-test
-
- { -2 } [
- [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
- 5 bar
- ] unit-test
-
- : add ( a b -- c ) + ;
- \ add make-advised
-
- { 10 } [
- [ [ 2 * ] bi@ ] "double-args" \ add advise-before
- 2 3 add
- ] unit-test
-
- { 21 } [
- [ 3 * ad-do-it 1- ] "around1" \ add advise-around
- 2 3 add
- ] unit-test
-
-! { 9 } [
-! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
-! 2 3 add
-! ] unit-test
-
-! { { "around1" "around2" } } [
-! \ add around word-prop keys
-! ] unit-test
-
- { 5 f } [
- \ add unadvise
- 2 3 add \ add advised?
- ] unit-test
-
-! : quux ( a b -- c ) * ;
-
-! { f t 3+3/4 } [
-! <" USING: advice kernel math ;
-! IN: advice.tests
-! \ quux advised?
-! ADVISE: quux halve before [ 2 / ] bi@ ;
-! \ quux advised?
-! 3 5 quux"> eval
-! ] unit-test
-
-! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
-! <" USING: advice kernel math math.parser io io.streams.string ;
-! IN: advice.tests
-! ADVISE: quux log around
-! 2dup [ number>string write " " write ] bi@
-! ad-do-it
-! dup number>string write ;
-! [ 3 5 quux ] with-string-writer"> eval
-! ] unit-test
-
-] with-scope
\ No newline at end of file
+++ /dev/null
-! 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 ;
-IN: advice
-
-SYMBOLS: before after around advised in-advice? ;
-
-: advised? ( word -- ? )
- advised word-prop ;
-
-DEFER: make-advised
-
-<PRIVATE
-: init-around-co ( quot -- coroutine )
- \ coreset suffix cocreate ;
-PRIVATE>
-
-: advise ( quot name word loc -- )
- dup around eq? [ [ init-around-co ] 3dip ] when
- over advised? [ over make-advised ] unless
- word-prop set-at ;
-
-: advise-before ( quot name word -- ) before advise ;
-
-: advise-after ( quot name word -- ) after advise ;
-
-: advise-around ( quot name word -- ) around advise ;
-
-: get-advice ( word type -- seq )
- word-prop values ;
-
-: call-before ( word -- )
- before get-advice [ call ] each ;
-
-: call-after ( word -- )
- after get-advice [ call ] each ;
-
-: call-around ( main word -- )
- t in-advice? [
- around get-advice tuck
- [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
- ] with-variable ;
-
-: remove-advice ( name word loc -- )
- word-prop delete-at ;
-
-: ad-do-it ( input -- result )
- in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ;
-
-: make-advised ( word -- )
- [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
- [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
- [ t advised set-word-prop ] tri ;
-
-: unadvise ( word -- )
- [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
-
-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
+++ /dev/null
-James Cash
+++ /dev/null
-Implmentation of advice/aspects
+++ /dev/null
-extensions
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
--- /dev/null
+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 ;
+
--- /dev/null
+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 ;
: 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
] [
: 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 ;
: base64-benchmark ( -- )
65535 [ 255 bitand ] "" map-as
- 100 [ >base64 base64> ] times
+ 20 [ >base64 base64> ] times
drop ;
MAIN: base64-benchmark
-! 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
[
[
[ [ 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
1 [a,b] [ number>string all-unique? ] count ; inline
: beust ( -- )
- 10000000 count-numbers
+ 2000000 count-numbers
number>string " unique numbers." append print ;
MAIN: beust
:: beust ( -- )
[let | i! [ 0 ] |
- 10000000000 [ i 1+ i! ] count-numbers
+ 5000000000 [ i 1+ i! ] count-numbers
i number>string " unique numbers." append print
] ;
}
: 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
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
:: 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
--- /dev/null
+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 }
+}
] alien-callback\r
"int" { "int" } "cdecl" alien-indirect ;\r
\r
-: fib-main ( -- ) 34 fib drop ;\r
+: fib-main ( -- ) 32 fib drop ;\r
\r
MAIN: fib-main\r
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+/*
+ * 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
-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
--- /dev/null
+Aaron Schaefer
--- /dev/null
+! 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
] with-file-writer ;
: random-main ( -- )
- 1000000 write-random-numbers ;
+ 300000 write-random-numbers ;
MAIN: random-main
: 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
-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
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
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 ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes kernel sequences sets
-io prettyprint multi-methods ;
-IN: boolean-expr
-
-! Demonstrates the use of Unicode symbols in source files, and
-! multi-method dispatch.
-
-TUPLE: ⋀ x y ;
-TUPLE: ⋁ x y ;
-TUPLE: ¬ x ;
-
-SINGLETONS: ⊤ ⊥ ;
-
-SINGLETONS: P Q R S T U V W X Y Z ;
-
-UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ;
-
-GENERIC: ⋀ ( x y -- expr )
-
-METHOD: ⋀ { ⊤ □ } nip ;
-METHOD: ⋀ { □ ⊤ } drop ;
-METHOD: ⋀ { ⊥ □ } drop ;
-METHOD: ⋀ { □ ⊥ } nip ;
-
-METHOD: ⋀ { ⋁ □ } [ [ x>> ] dip ⋀ ] [ [ y>> ] dip ⋀ ] 2bi ⋁ ;
-METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
-
-METHOD: ⋀ { □ □ } \ ⋀ boa ;
-
-GENERIC: ⋁ ( x y -- expr )
-
-METHOD: ⋁ { ⊤ □ } drop ;
-METHOD: ⋁ { □ ⊤ } nip ;
-METHOD: ⋁ { ⊥ □ } nip ;
-METHOD: ⋁ { □ ⊥ } drop ;
-
-METHOD: ⋁ { □ □ } \ ⋁ boa ;
-
-GENERIC: ¬ ( x -- expr )
-
-METHOD: ¬ { ⊤ } drop ⊥ ;
-METHOD: ¬ { ⊥ } drop ⊤ ;
-
-METHOD: ¬ { ⋀ } [ x>> ¬ ] [ y>> ¬ ] bi ⋁ ;
-METHOD: ¬ { ⋁ } [ x>> ¬ ] [ y>> ¬ ] bi ⋀ ;
-
-METHOD: ¬ { □ } \ ¬ boa ;
-
-: → ( x y -- expr ) ¬ ⋀ ;
-: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ;
-: ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ;
-
-GENERIC: (cnf) ( expr -- cnf )
-
-METHOD: (cnf) { ⋀ } [ x>> (cnf) ] [ y>> (cnf) ] bi append ;
-METHOD: (cnf) { □ } 1array ;
-
-GENERIC: cnf ( expr -- cnf )
-
-METHOD: cnf { ⋁ } [ x>> cnf ] [ y>> cnf ] bi append ;
-METHOD: cnf { □ } (cnf) 1array ;
-
-GENERIC: satisfiable? ( expr -- ? )
-
-METHOD: satisfiable? { ⊤ } drop t ;
-METHOD: satisfiable? { ⊥ } drop f ;
-
-: partition ( seq quot -- left right )
- [ [ not ] compose filter ] [ filter ] 2bi ; inline
-
-: (satisfiable?) ( seq -- ? )
- [ \ ¬ instance? ] partition [ x>> ] map intersect empty? ;
-
-METHOD: satisfiable? { □ }
- cnf [ (satisfiable?) ] any? ;
-
-GENERIC: (expr.) ( expr -- )
-
-METHOD: (expr.) { □ } pprint ;
-
-: op. ( expr -- )
- "(" write
- [ x>> (expr.) ]
- [ bl class pprint bl ]
- [ y>> (expr.) ]
- tri
- ")" write ;
-
-METHOD: (expr.) { ⋀ } op. ;
-METHOD: (expr.) { ⋁ } op. ;
-METHOD: (expr.) { ¬ } [ class pprint ] [ x>> (expr.) ] bi ;
-
-: expr. ( expr -- ) (expr.) nl ;
+++ /dev/null
-Simple boolean expression evaluator and simplifier
--- /dev/null
+Sascha Matzke
--- /dev/null
+USING: vocabs.loader ;
+
+IN: bson
+
+"bson.reader" require
+"bson.writer" require
--- /dev/null
+Sascha Matzke
--- /dev/null
+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
+
+
--- /dev/null
+Shared constants and classes
--- /dev/null
+Sascha Matzke
--- /dev/null
+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 ;
--- /dev/null
+BSON to Factor deserializer
--- /dev/null
+BSON reader and writer
--- /dev/null
+Sascha Matzke
--- /dev/null
+Factor to BSON serializer
--- /dev/null
+! 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
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
] 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 ]
} 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 ]
! 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
DEFER: preprocess-file
-ERROR: unknown-c-preprocessor state-parser name ;
+ERROR: unknown-c-preprocessor sequence-parser name ;
ERROR: bad-include-line line ;
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 ]
: 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 ] }
[ 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" = [
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 ;
IN: contributors.tests
USING: contributors tools.test ;
-\ contributors must-infer
[ ] [ contributors ] unit-test
: 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 )
: 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 ;
: coreset ( v -- )
current-coro get dup
originalcc>> >>resumecc
- exitcc>> continue-with ;
\ No newline at end of file
+ exitcc>> continue-with ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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
--- /dev/null
+! 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
+! - ...?
--- /dev/null
+unportable
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
io.encodings.binary ;
IN: crypto.hmac
+<PRIVATE
+
: sha1-hmac ( Ko Ki -- hmac )
initialize-sha1 process-sha1-block
stream>sha1 get-sha1
[ bitxor ] 2map ;
MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
+
MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
: init-hmac ( K -- o i )
[ 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 )
: 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 ;
-USING: help.syntax help.markup ;\r
+USING: help.syntax help.markup words ;\r
IN: descriptive\r
\r
HELP: DESCRIPTIVE:\r
{ $syntax "DESCRIPTIVE: word ( inputs -- outputs ) definition ;" }\r
-{ $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." } ;\r
+{ $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." } ;\r
\r
HELP: DESCRIPTIVE::\r
{ $syntax "DESCRIPTIVE:: word ( inputs -- outputs ) definition ;" }\r
-{ $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." } ;\r
+{ $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." } ;\r
\r
-HELP: descriptive\r
-{ $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)." } ;\r
+HELP: descriptive-error\r
+{ $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)." } ;\r
+\r
+HELP: make-descriptive\r
+{ $values { "word" word } }\r
+{ $description "Makes the word wrap errors in " { $link descriptive-error } " instances." } ;\r
\r
ARTICLE: "descriptive" "Descriptive errors"\r
-"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:"\r
-{ $subsection descriptive }\r
+"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:"\r
+{ $subsection descriptive-error }\r
+"The wrapper contains the word itself, the input parameters, as well as the original error."\r
+$nl\r
+"To annotate an existing word with descriptive error checking:"\r
+{ $subsection make-descriptive }\r
"To define words which throw descriptive errors, use the following words:"\r
{ $subsection POSTPONE: DESCRIPTIVE: }\r
{ $subsection POSTPONE: DESCRIPTIVE:: } ;\r
-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 ;
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 ]
--- /dev/null
+extensions
io io.binary io.sockets io.encodings.binary
accessors
combinators.smart
- newfx
+ assocs
;
IN: dns
[
{
[ 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 ;
[
{
[ 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
[
{
[ 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 ;
[ 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 ;
[
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
]
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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: message-query ( message -- query ) question-section>> 1st ;
+: message-query ( message -- query ) question-section>> first ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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
: 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 ;
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
[ 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
: 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-: 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
--- /dev/null
+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 }
+}
--- /dev/null
+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
--- /dev/null
+unportable
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
--- /dev/null
+! (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"
--- /dev/null
+! (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 ;
+
--- /dev/null
+Access environment variables via the assoc protocol
--- /dev/null
+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
--- /dev/null
+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
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
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? [
[ 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)
--- /dev/null
+! 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
! 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
<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 ]
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
: 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 ;
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
[ 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
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
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
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
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
+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*>
[ +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 ]
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)
M: iokit-game-input-backend (close-game-input)
+hid-manager+ get-global [
- +hid-manager+ global [
+ +hid-manager+ [
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerUnscheduleFromRunLoop
[ 0 IOHIDManagerClose drop ]
[ CFRelease ] tri
f
- ] change-at
+ ] change-global
f +keyboard-state+ set-global
f +controller-states+ set-global
] when ;
--- /dev/null
+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 ;
+
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
+++ /dev/null
-William Schlieper
+++ /dev/null
-! See http://factorcode.org/license.txt for BSD licence.
-USING: help.markup help.syntax ;
-
-IN: graph-theory
-
-ARTICLE: "graph-protocol" "Graph protocol"
-"All graphs must be instances of the graph mixin:"
-{ $subsection graph }
-"All graphs must implement a method on the following generic word:"
-{ $subsection vertices }
-"At least one of the following two generic words must have a method; the " { $link graph } " mixin has default definitions which are mutually recursive:"
-{ $subsection adjlist }
-{ $subsection adj? }
-"All mutable graphs must implement a method on the following generic word:"
-{ $subsection add-blank-vertex }
-"All mutable undirected graphs must implement a method on the following generic word:"
-{ $subsection add-edge }
-"Mutable directed graphs should not implement the above word, as it has a default definition defined in terms of the following generic word:"
-{ $subsection add-edge* }
-"The following two words have default definitions, but are available as generics to allow implementations to optimize them:"
-{ $subsection num-vertices }
-{ $subsection num-edges } ;
-
-HELP: graph
-{ $class-description "A mixin class whose instances are graphs. Custom implementations of the graph protocol should be declared as instances of this mixin for all graph functionality to work correctly:"
- { $code "INSTANCE: hex-board graph" }
-} ;
-
-{ vertices num-vertices num-edges } related-words
-
-HELP: vertices
-{ $values { "graph" graph } { "seq" "The vertices" } }
-{ $description "Returns the vertices of the graph." } ;
-
-HELP: num-vertices
-{ $values { "graph" graph } { "n" "The number of vertices" } }
-{ $description "Returns the number of vertices in the graph." } ;
-
-HELP: num-edges
-{ $values { "graph" "A graph" } { "n" "The number of edges" } }
-{ $description "Returns the number of edges in the graph." } ;
-
-{ adjlist adj? } related-words
-
-HELP: adjlist
-{ $values
- { "from" "The index of a vertex" }
- { "graph" "The graph to be examined" }
- { "seq" "The adjacency list" } }
-{ $description "Returns a sequence of vertices that this vertex links to" } ;
-
-HELP: adj?
-{ $values
- { "from" "The index of a vertex" }
- { "to" "The index of a vertex" }
- { "graph" "A graph" }
- { "?" "A boolean" } }
-{ $description "Returns a boolean describing whether there is an edge in the graph between from and to." } ;
-
-{ add-blank-vertex add-blank-vertices add-edge add-edge* } related-words
-
-HELP: add-blank-vertex
-{ $values
- { "index" "A vertex index" }
- { "graph" "A graph" } }
-{ $description "Adds a vertex to the graph." } ;
-
-HELP: add-blank-vertices
-{ $values
- { "seq" "A sequence of vertex indices" }
- { "graph" "A graph" } }
-{ $description "Adds vertices with indices in seq to the graph." } ;
-
-HELP: add-edge*
-{ $values
- { "from" "The index of a vertex" }
- { "to" "The index of another vertex" }
- { "graph" "A graph" } }
-{ $description "Adds a one-way edge to the graph, between " { $snippet "from" } " and " { $snippet "to" } "."
- $nl
- "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
-
-HELP: add-edge
-{ $values
- { "u" "The index of a vertex" }
- { "v" "The index of another vertex" }
- { "graph" "A graph" } }
-{ $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
- $nl
- "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;
-
-{ depth-first full-depth-first dag? topological-sort } related-words
-
-HELP: depth-first
-{ $values
- { "v" "The vertex to start the search at" }
- { "graph" "The graph to search" }
- { "pre" "A quotation of the form ( n -- )" }
- { "post" "A quotation of the form ( n -- )" }
- { "?list" "A list of booleans describing the vertices visited in the search" }
- { "?" "A boolean describing whether or not the end-search error was thrown" } }
-{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } " can be accessed in both quotations."
- $nl
- "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
- $nl
- "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
- $nl
- { $emphasis "?list" } " is a list of booleans, " { $link t } " for every vertex visted during the search, and " { $link f } " for every vertex not visited." } ;
-
-HELP: full-depth-first
-{ $values
- { "graph" "The graph to search" }
- { "pre" "A quotation of the form ( n -- )" }
- { "post" "A quotation of the form ( n -- )" }
- { "tail" "A quotation of the form ( -- )" }
- { "?" "A boolean describing whether or not the end-search error was thrown" } }
-{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } "can be accessed in both quotations."
- $nl
- "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
- $nl
- "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
- $nl
- "The " { $emphasis "tail" } " quotation is run after each time the depth-first search runs out of nodes. On an undirected graph this will be each connected subgroup but on a directed graph it can be more complex." } ;
-
-HELP: dag?
-{ $values
- { "graph" graph }
- { "?" "A boolean indicating if the graph is acyclic" } }
-{ $description "Using a depth-first search, determines if the specified directed graph is a directed acyclic graph. An undirected graph will produce a false result, as the algorithm does not eliminate cycles of length 2, which will include any edge that goes both ways." } ;
-
-HELP: topological-sort
-{ $values
- { "graph" graph }
- { "seq/f" "Either a sequence of values or f" } }
-{ $description "Using a depth-first search, topologically sorts the specified directed graph. Returns f if the graph contains any cycles, and a topologically sorted sequence otherwise." } ;
+++ /dev/null
-! 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 ;
-
-IN: graph-theory
-
-MIXIN: graph
-SYMBOL: visited?
-ERROR: end-search ;
-
-GENERIC: vertices ( graph -- seq ) flushable
-
-GENERIC: num-vertices ( graph -- n ) flushable
-
-GENERIC: num-edges ( graph -- n ) flushable
-
-GENERIC: adjlist ( from graph -- seq ) flushable
-
-GENERIC: adj? ( from to graph -- ? ) flushable
-
-GENERIC: add-blank-vertex ( index graph -- )
-
-GENERIC: delete-blank-vertex ( index graph -- )
-
-GENERIC: add-edge* ( from to graph -- )
-
-GENERIC: add-edge ( u v graph -- )
-
-GENERIC: delete-edge* ( from to graph -- )
-
-GENERIC: delete-edge ( u v graph -- )
-
-M: graph num-vertices
- vertices length ;
-
-M: graph num-edges
- [ vertices ] [ '[ _ adjlist length ] map sum ] bi ;
-
-M: graph adjlist
- [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
-
-M: graph adj?
- swapd adjlist index >boolean ;
-
-M: graph add-edge
- [ add-edge* ] [ swapd add-edge* ] 3bi ;
-
-M: graph delete-edge
- [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
-
-: add-blank-vertices ( seq graph -- )
- '[ _ add-blank-vertex ] each ;
-
-: delete-vertex ( index graph -- )
- [ adjlist ]
- [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
- [ delete-blank-vertex ] 2tri ;
-
-<PRIVATE
-
-: search-wrap ( quot graph -- ? )
- [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
- [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
-
-: (depth-first) ( v pre post -- )
- { [ 2drop visited? get t -rot set-at ]
- [ drop call ]
- [ [ graph get adjlist ] 2dip
- '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
- [ nip call ] } 3cleave ; inline
-
-PRIVATE>
-
-: depth-first ( v graph pre post -- ?list ? )
- '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
-
-: full-depth-first ( graph pre post tail -- ? )
- '[ [ visited? get [ nip not ] assoc-find ]
- [ drop _ _ (depth-first) @ ]
- while 2drop ] swap search-wrap ; inline
-
-: dag? ( graph -- ? )
- V{ } clone swap [ 2dup swap push dupd
- '[ _ swap graph get adj? not ] all?
- [ end-search ] unless ]
- [ drop dup pop* ] [ ] full-depth-first nip ;
-
-: topological-sort ( graph -- seq/f )
- dup dag?
- [ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
- [ drop f ] if ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: accessors kernel graph-theory ;
-
-IN: graph-theory.reversals
-
-TUPLE: reversal graph ;
-
-GENERIC: reverse-graph ( graph -- reversal )
-
-M: graph reverse-graph reversal boa ;
-
-M: reversal reverse-graph graph>> ;
-
-INSTANCE: reversal graph
-
-M: reversal vertices
- graph>> vertices ;
-
-M: reversal adj?
- swapd graph>> adj? ;
+++ /dev/null
-! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: accessors kernel sequences arrays vectors sets assocs hashtables graph-theory namespaces fry ;
-
-IN: graph-theory.sparse
-
-TUPLE: sparse-graph alist ;
-
-: <sparse-graph> ( -- sparse-graph )
- H{ } clone sparse-graph boa ;
-
-: >sparse-graph ( graph -- sparse-graph )
- [ vertices ] keep
- '[ dup _ adjlist 2array ] map >hashtable sparse-graph boa ;
-
-INSTANCE: sparse-graph graph
-
-M: sparse-graph vertices
- alist>> keys ;
-
-M: sparse-graph adjlist
- alist>> at ;
-
-M: sparse-graph add-blank-vertex
- alist>> V{ } clone -rot set-at ;
-
-M: sparse-graph delete-blank-vertex
- alist>> delete-at ;
-
-M: sparse-graph add-edge*
- alist>> swapd at adjoin ;
-
-M: sparse-graph delete-edge*
- alist>> swapd at delete ;
+++ /dev/null
-Graph-theoretic algorithms
+++ /dev/null
-collections
! 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 ;
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>
+++ /dev/null
-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
+++ /dev/null
-! 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 ;
! 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 )
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 }
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 } "." } ;
! 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 )
"Big Band"
] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
+
+[ t ]
+[ 10000 [ synchsafe>seq seq>synchsafe ] map [ < ] monotonic? ] unit-test
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
"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
+
+CONSTANT: id3v1-length 128
+CONSTANT: id3v1-offset 128
+CONSTANT: id3v1+-length 227
+CONSTANT: id3v1+-offset $[ 128 227 + ]
-: id3v1? ( mmap -- ? )
- { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline
+: id3v1? ( seq -- ? )
+ {
+ [ length id3v1-offset >= ]
+ [ id3v1-length tail-slice* "TAG" head? ]
+ } 1&& ;
-: id3v1-frame ( string key -- frame )
- <frame>
- swap >>frame-id
- swap >>data ; inline
+: 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>id3v2 ( id3v1 -- id3v2 )
+: 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 ( seq -- frame/f )
+ dup 4 head-slice valid-tag?
+ [ (read-frame) ] [ drop f ] if ;
-: read-frame ( mmap -- frame/f )
- dup 4 head-slice valid-frame-id?
- [ (read-frame) ] [ drop f ] if ; inline
+: remove-frame ( seq frame -- seq )
+ size>> 10 + tail-slice ;
-: remove-frame ( mmap frame -- mmap )
- size>> 10 + tail-slice ; inline
+: frames>assoc ( seq -- assoc )
+ [ [ tag>> ] keep ] H{ } map>assoc ;
-: read-frames ( mmap -- frames )
- [ dup read-frame dup ]
- [ [ remove-frame ] keep ]
- produce 2nip ; inline
+: 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 ;
+
+: merge-frames ( id3 assoc -- id3 )
+ [ dup frames>> ] dip update ;
-: read-v2-tag-data ( seq -- id3v2-info )
+: 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 ]
[ [ 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
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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors grouping sequences combinators
+math specialized-arrays.direct.uint byte-arrays fry
+specialized-arrays.direct.ushort specialized-arrays.uint
+specialized-arrays.ushort specialized-arrays.float images ;
+IN: images.normalization
+
+<PRIVATE
+
+: add-dummy-alpha ( seq -- seq' )
+ 3 <groups> [ 255 suffix ] map concat ;
+
+: normalize-floats ( byte-array -- byte-array )
+ byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
+
+GENERIC: normalize-component-order* ( image component-order -- image )
+
+: normalize-component-order ( image -- image )
+ dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
+
+M: RGBA normalize-component-order* drop ;
+
+M: R32G32B32A32 normalize-component-order*
+ drop normalize-floats ;
+
+M: R32G32B32 normalize-component-order*
+ drop normalize-floats add-dummy-alpha ;
+
+: RGB16>8 ( bitmap -- bitmap' )
+ byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
+
+M: R16G16B16A16 normalize-component-order*
+ drop RGB16>8 ;
+
+M: R16G16B16 normalize-component-order*
+ drop RGB16>8 add-dummy-alpha ;
+
+: BGR>RGB ( bitmap -- pixels )
+ 3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
+
+: BGRA>RGBA ( bitmap -- pixels )
+ 4 <sliced-groups>
+ [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
+
+M: BGRA normalize-component-order*
+ drop BGRA>RGBA ;
+
+M: RGB normalize-component-order*
+ drop add-dummy-alpha ;
+
+M: BGR normalize-component-order*
+ drop BGR>RGB add-dummy-alpha ;
+
+: ARGB>RGBA ( bitmap -- bitmap' )
+ 4 <groups> [ unclip suffix ] map B{ } join ; inline
+
+M: ARGB normalize-component-order*
+ drop ARGB>RGBA ;
+
+M: ABGR normalize-component-order*
+ drop ARGB>RGBA BGRA>RGBA ;
+
+: fix-XBGR ( bitmap -- bitmap' )
+ dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
+
+M: XBGR normalize-component-order*
+ drop fix-XBGR ABGR normalize-component-order* ;
+
+: fix-BGRX ( bitmap -- bitmap' )
+ dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
+
+M: BGRX normalize-component-order*
+ drop fix-BGRX BGRA normalize-component-order* ;
+
+: normalize-scan-line-order ( image -- image )
+ dup upside-down?>> [
+ dup dim>> first 4 * '[
+ _ <groups> reverse concat
+ ] change-bitmap
+ f >>upside-down?
+ ] when ;
+
+PRIVATE>
+
+: normalize-image ( image -- image )
+ [ >byte-array ] change-bitmap
+ normalize-component-order
+ normalize-scan-line-order
+ RGBA >>component-order ;
-! 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 -- ) load-image default-image. ;
-
-M: pathname image. ( image -- ) load-image default-image. ;
+M: string image. ( image -- ) <image-name> <image-gadget> gadget. ;
-M: image image. ( image -- ) default-image. ;
+M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;
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 ;
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
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: ) } ]
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! 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> ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! 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." ;
--- /dev/null
+! 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 ;
--- /dev/null
+IRC Client and Chat object definitions
-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 } "." } ;
"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"
"! 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"
}
+++ /dev/null
-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 ;
-EXCLUDE: irc.messages => join ;
-RENAME: join irc.messages => join_
-IN: irc.client.tests
-
-! Streams for testing
-TUPLE: mb-writer lines last-line disposed ;
-TUPLE: mb-reader lines disposed ;
-: <mb-writer> ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ;
-: <mb-reader> ( -- mb-reader ) <mailbox> f mb-reader boa ;
-: push-line ( line test-reader-stream -- ) lines>> mailbox-put ;
-: <test-stream> ( -- stream ) <mb-reader> <mb-writer> <duplex-stream> ;
-M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ;
-M: mb-writer stream-flush ( mb-writer -- ) drop ;
-M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
-M: mb-writer stream-nl ( mb-writer -- )
- [ [ last-line>> concat ] [ lines>> ] bi push ] keep
- V{ } clone >>last-line drop ;
-M: mb-reader dispose f swap push-line ;
-M: mb-writer dispose drop ;
-
-: spawn-client ( -- irc-client )
- "someserver" irc-port "factorbot" f <irc-profile>
- <irc-client>
- t >>is-ready
- t >>is-running
- <test-stream> >>stream
- dup [ spawn-irc yield ] with-irc-client ;
-
-! to be used inside with-irc-client quotations
-: %add-named-chat ( chat -- ) irc> attach-chat ;
-: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
-: %join ( channel -- ) <irc-channel-chat> irc> attach-chat ;
-
-: read-matching-message ( chat quot: ( msg -- ? ) -- irc-message )
- [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ;
-
-: with-irc ( quot: ( -- ) -- )
- [ spawn-client ] dip [ irc> terminate-irc ] compose with-irc-client ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! TESTS
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { t } [ irc> nick>> me? ] unit-test
-
- { "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
-
- { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
- parse-irc-line forward-name ] unit-test
-] with-irc
-
-! Test login and nickname set
-[ { "factorbot2" } [
- ":some.where 001 factorbot2 :Welcome factorbot2" %push-line
- irc> nick>>
- ] unit-test
-] with-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
-] unit-test
-
-! Test join
-[ { "JOIN #factortest" } [
- "#factortest" %join
- irc> stream>> out>> lines>> pop
- ] unit-test
-] with-irc
-
-[ { 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
- ] 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
-
-[ { 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
- ] unit-test
-] with-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
- ] unit-test
-] with-irc
-
-[ { mode } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":ircserver.net MODE #factortest +ns" %push-line
- [ mode? ] read-matching-message class
- ] unit-test
-] with-irc
-
-! Participant lists tests
-[ { H{ { "ircuser" +normal+ } } } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":ircuser!n=user@isp.net JOIN :#factortest" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "ircuser2" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser2" +normal+ }
- { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user@isp.net PART #factortest" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "ircuser2" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser2" +normal+ }
- { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user@isp.net QUIT" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "ircuser2" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser2" +normal+ }
- { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "ircuser2" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
- [ %add-named-chat ] keep
- ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
- participants>>
- ] unit-test
-] with-irc
-
-[ { H{ { "factorbot" +operator+ } { "ircuser" +normal+ } } } [
- "#factortest" <irc-channel-chat>
- H{ { "ircuser" +normal+ } } clone >>participants
- [ %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
- participants>>
- ] unit-test
-] with-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" } } [
- "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
- ":ircserver.net MODE #factortest +o ircuser" %push-line
- [ participant-changed? ] read-matching-message
- ] unit-test
-] with-irc
! 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 ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! 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 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.internals.tests
+
+! Streams for testing
+TUPLE: mb-writer lines last-line disposed ;
+TUPLE: mb-reader lines disposed ;
+: <mb-writer> ( -- mb-writer ) V{ } clone V{ } clone f mb-writer boa ;
+: <mb-reader> ( -- mb-reader ) <mailbox> f mb-reader boa ;
+: push-line ( line test-reader-stream -- ) lines>> mailbox-put ;
+: <test-stream> ( -- stream ) <mb-reader> <mb-writer> <duplex-stream> ;
+M: mb-writer stream-write ( line mb-writer -- ) last-line>> push ;
+M: mb-writer stream-flush ( mb-writer -- ) drop ;
+M: mb-reader stream-readln ( mb-reader -- str/f ) lines>> mailbox-get ;
+M: mb-writer stream-nl ( mb-writer -- )
+ [ [ last-line>> concat ] [ lines>> ] bi push ] keep
+ V{ } clone >>last-line drop ;
+M: mb-reader dispose f swap push-line ;
+M: mb-writer dispose drop ;
+
+: spawn-client ( -- irc-client )
+ "someserver" irc-port "factorbot" f <irc-profile>
+ <irc-client>
+ t >>is-ready
+ t >>is-running
+ <test-stream> >>stream
+ dup [ spawn-irc yield ] with-irc ;
+
+! to be used inside with-irc quotations
+: %add-named-chat ( chat -- ) (attach-chat) ;
+: %push-line ( line -- ) irc> stream>> in>> push-line yield ;
+: %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? ; inline
+
+: spawning-irc ( quot: ( -- ) -- )
+ [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TESTS
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { t } [ irc> nick>> me? ] unit-test
+
+ { "factorbot" } [ irc> nick>> ] unit-test
+
+ { "#factortest" } [ ":someuser!n=user@some.where PRIVMSG #factortest :hi"
+ string>irc-message chat-name ] unit-test
+
+ { "someuser" } [ ":someuser!n=user@some.where PRIVMSG factorbot :hi"
+ 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
+] 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)
+ (do-login)
+ irc> stream>> out>> lines>>
+ (terminate-irc)
+ ] with-irc
+] unit-test
+
+! Test join
+[ { "JOIN #factortest" } [
+ "#factortest" %join %pop-output-line
+ ] unit-test
+] spawning-irc
+
+[ { 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-lines
+ [ join? ] read-matching-message
+ [ class ] [ channel>> ] bi
+ ] unit-test
+] 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 ] [ target>> ] [ trailing>> ] tri
+ ] unit-test
+] 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 ] [ target>> ] [ trailing>> ] tri
+ ] unit-test
+] spawning-irc
+
+[ { mode "#factortest" "+ns" } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ ":ircserver.net MODE #factortest +ns" %push-line
+ [ mode? ] read-matching-message
+ [ class ] [ name>> ] [ mode>> ] tri
+ ] unit-test
+] spawning-irc
+
+! Participant lists tests
+[ { { "ircuser" } } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net JOIN :#factortest" %push-line
+ participants>> keys
+ ] unit-test
+] spawning-irc
+
+[ { { "ircuser2" } } [
+ "#factortest" <irc-channel-chat>
+ { "ircuser2" "ircuser" } [ over join-participant ] each
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net PART #factortest" %push-line
+ participants>> keys
+ ] unit-test
+] spawning-irc
+
+[ { { "ircuser2" } } [
+ "#factortest" <irc-channel-chat>
+ { "ircuser2" "ircuser" } [ over join-participant ] each
+ [ %add-named-chat ] keep
+ ":ircuser!n=user@isp.net QUIT" %push-line
+ participants>> keys
+ ] unit-test
+] spawning-irc
+
+[ { { "ircuser2" } } [
+ "#factortest" <irc-channel-chat>
+ { "ircuser2" "ircuser" } [ over join-participant ] each
+ [ %add-named-chat ] keep
+ ":ircuser2!n=user2@isp.net KICK #factortest ircuser" %push-line
+ participants>> keys
+ ] unit-test
+] spawning-irc
+
+[ { H{ { "ircuser2" T{ participant { nick "ircuser2" } } } } } [
+ "#factortest" <irc-channel-chat>
+ "ircuser" over join-participant
+ [ %add-named-chat ] keep
+ ":ircuser!n=user2@isp.net NICK :ircuser2" %push-line
+ participants>>
+ ] unit-test
+] spawning-irc
+
+[ { H{ { "factorbot" T{ participant { nick "factorbot" } { operator t } } }
+ { "ircuser" T{ participant { nick "ircuser" } } }
+ { "voiced" T{ participant { nick "voiced" } { voice t } } } } } [
+ "#factortest" <irc-channel-chat>
+ "ircuser" over join-participant
+ [ %add-named-chat ] keep
+ { ":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
+] spawning-irc
+
+[ { mode "#factortest" "+o" "ircuser" } [
+ "#factortest" <irc-channel-chat> [ %add-named-chat ] keep
+ "ircuser" over join-participant
+ ":ircserver.net MODE #factortest +o ircuser" %push-line
+ [ mode? ] read-matching-message
+ { [ class ] [ name>> ] [ mode>> ] [ parameter>> ] } cleave
+ ] unit-test
+] 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
--- /dev/null
+! 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
--- /dev/null
+IRC Client internals
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! 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 ;
--- /dev/null
+IRC Client chat participants handling
! 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
"--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
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! 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 ;
--- /dev/null
+IRC message formatting for logs
--- /dev/null
+! 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
--- /dev/null
+An IRC logging bot
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! 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 ;
--- /dev/null
+IRC messages base implementation
+! 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" }
{ 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" }
{ 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" }
{ 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" }
{ 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
-! 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 ;
-
-: <irc-client-message> ( command parameters trailing -- irc-message )
- irc-message new
- now >>timestamp
- swap >>trailing
- swap >>parameters
- swap >>command ;
-
-<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 ;
+! 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 ;
+
+M: rpl-names post-process-irc-message ( rpl-names -- )
+ [ [ blank? ] trim " " split ] change-nicks drop ;
+
+PREDICATE: channel-mode < mode name>> first "#&" member? ;
+PREDICATE: participant-mode < channel-mode parameter>> ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+! 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 ;
--- /dev/null
+Basic parser for irc messages
--- /dev/null
+IRC message definitions
--- /dev/null
+Alex Chapman
--- /dev/null
+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" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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 ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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 ;
--- /dev/null
+! 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
--- /dev/null
+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...
--- /dev/null
+Alex Chapman
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
--- /dev/null
+A simple 3d tunnel racing game
--- /dev/null
+applications
+games
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
+
swap [
" " [ drop ] <border-button>
swap [ first >>loc ] [ second >>dim ] bi
- ] [ execute ] bi*
+ ] [ execute( -- value ) ] bi*
] dip set-nth ;
: add-keys-gadgets ( gadget -- gadget )
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 ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: io lint kernel math tools.test ;
-IN: lint.tests
-
-! Don't write code like this
-: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when
-
-[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
-
-: lint2 ( n -- n' ) 1 + ; ! 1+
-[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
-
-: lint3 ( a b -- b a b ) dup -rot ; ! tuck
-
-[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.accessors arrays assocs
-combinators.short-circuit fry hashtables io
-kernel math namespaces prettyprint quotations sequences
-sequences.deep sets slots.private vectors vocabs words
-kernel.private ;
-IN: lint
-
-SYMBOL: def-hash
-SYMBOL: def-hash-keys
-
-: set-hash-vector ( val key hash -- )
- 2dup at -rot [ ?push ] 2dip set-at ;
-
-: more-defs ( hash -- )
- {
- { -rot [ swap [ swap ] dip ] }
- { -rot [ swap swapd ] }
- { rot [ [ swap ] dip swap ] }
- { rot [ swapd swap ] }
- { over [ dup swap ] }
- { tuck [ dup -rot ] }
- { swapd [ [ swap ] dip ] }
- { 2nip [ nip nip ] }
- { 2drop [ drop drop ] }
- { 3drop [ drop drop drop ] }
- { pop* [ pop drop ] }
- { when [ [ ] if ] }
- { >boolean [ f = not ] }
- } swap '[ first2 _ set-hash-vector ] each ;
-
-: accessor-words ( -- seq )
-{
- alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
- alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
- <displaced-alien> alien-unsigned-cell set-alien-signed-cell
- set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
- set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
- set-alien-unsigned-8 set-alien-signed-8
- alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
- set-alien-float alien-float
-} ;
-
-: trivial-defs ( -- seq )
- {
- [ drop ] [ 2array ]
- [ bitand ]
-
- [ . ]
- [ get ]
- [ t ] [ f ]
- [ { } ]
- [ drop f ]
- [ "cdecl" ]
- [ first ] [ second ] [ third ] [ fourth ]
- [ ">" write ] [ "/>" write ]
- } ;
-
-! ! Add definitions
-H{ } clone def-hash set-global
-
-all-words [
- dup def>> dup callable?
- [ def-hash get-global set-hash-vector ] [ drop ] if
-] each
-
-! ! Remove definitions
-
-! Remove empty word defs
-def-hash get-global [ drop empty? not ] assoc-filter
-
-! Remove constants [ 1 ]
-[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
-
-! Remove words that are their own definition
-[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
-
-! Remove set-alien-cell, etc.
-[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
-
-! Remove trivial defs
-[ drop trivial-defs member? not ] assoc-filter
-
-! Remove numbers only defs
-[ drop [ number? ] all? not ] assoc-filter
-
-! Remove curry only defs
-[ drop [ \ curry = ] all? not ] assoc-filter
-
-! Remove tag defs
-[
- drop {
- [ length 3 = ]
- [ first \ tag = ] [ second number? ] [ third \ eq? = ]
- } 1&& not
-] assoc-filter
-
-[
- drop {
- [ [ wrapper? ] deep-any? ]
- [ [ hashtable? ] deep-any? ]
- } 1|| not
-] assoc-filter
-
-! Remove n m shift defs
-[
- drop dup length 3 = [
- [ first2 [ number? ] both? ]
- [ third \ shift = ] bi and not
- ] [ drop t ] if
-] assoc-filter
-
-! Remove [ n slot ]
-[
- drop dup length 2 =
- [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
-] assoc-filter
-
-
-dup more-defs
-
-[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
-
-: find-duplicates ( -- seq )
- def-hash get-global [ nip length 1 > ] assoc-filter ;
-
-GENERIC: lint ( obj -- seq )
-
-M: object lint ( obj -- seq ) drop f ;
-
-: subseq/member? ( subseq/member seq -- ? )
- { [ start ] [ member? ] } 2|| ;
-
-M: callable lint ( quot -- seq )
- [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
-
-M: word lint ( word -- seq )
- def>> dup callable? [ lint ] [ drop f ] if ;
-
-: word-path. ( word -- )
- [ vocabulary>> ] [ unparse ] bi ":" glue print ;
-
-: 4bl ( -- ) bl bl bl bl ;
-
-: (lint.) ( pair -- )
- first2 [ word-path. ] dip [
- [ 4bl . "-----------------------------------" print ]
- [ def-hash get-global at [ 4bl word-path. ] each nl ] bi
- ] each nl nl ;
-
-: lint. ( alist -- ) [ (lint.) ] each ;
-
-GENERIC: run-lint ( obj -- obj )
-
-: (trim-self) ( val key -- obj ? )
- def-hash get-global at*
- [ dupd remove empty? not ] [ drop f ] if ;
-
-: trim-self ( seq -- newseq )
- [ [ (trim-self) ] filter ] assoc-map ;
-
-: filter-symbols ( alist -- alist )
- [
- nip first dup def-hash get-global at
- [ first ] bi@ literalize = not
- ] assoc-filter ;
-
-M: sequence run-lint ( seq -- seq )
- [ dup lint ] { } map>assoc trim-self
- [ second empty? not ] filter filter-symbols ;
-
-M: word run-lint ( word -- seq ) 1array run-lint ;
-
-: lint-all ( -- seq ) all-words run-lint dup lint. ;
-
-: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
-
-: lint-word ( word -- seq ) 1array run-lint dup lint. ;
+++ /dev/null
-Finds potential mistakes in code
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel multiline ;
-IN: literals
-
-HELP: $
-{ $syntax "$ word" }
-{ $description "Executes " { $snippet "word" } " at parse time and adds the result(s) to the parser accumulator." }
-{ $notes { $snippet "word" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." }
-{ $examples
-
- { $example <"
-USING: kernel literals prettyprint ;
-IN: scratchpad
-
-CONSTANT: five 5
-{ $ five } .
- "> "{ 5 }" }
-
- { $example <"
-USING: kernel literals prettyprint ;
-IN: scratchpad
-
-<< : seven-eleven ( -- a b ) 7 11 ; >>
-{ $ seven-eleven } .
- "> "{ 7 11 }" }
-
-} ;
-
-HELP: $[
-{ $syntax "$[ code ]" }
-{ $description "Calls " { $snippet "code" } " at parse time and adds the result(s) to the parser accumulator." }
-{ $notes "Since " { $snippet "code" } " is " { $link call } "ed at parse time, it cannot reference any words defined in the same compilation unit." }
-{ $examples
-
- { $example <"
-USING: kernel literals math prettyprint ;
-IN: scratchpad
-
-<< CONSTANT: five 5 >>
-{ $[ five dup 1+ dup 2 + ] } .
- "> "{ 5 6 8 }" }
-
-} ;
-
-{ POSTPONE: $ POSTPONE: $[ } related-words
-
-ARTICLE: "literals" "Interpolating code results into literal values"
-"The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
-{ $example <"
-USING: kernel literals math prettyprint ;
-IN: scratchpad
-
-<< CONSTANT: five 5 >>
-{ $ five $[ five dup 1+ dup 2 + ] } .
- "> "{ 5 5 6 8 }" }
-{ $subsection POSTPONE: $ }
-{ $subsection POSTPONE: $[ }
-;
-
-ABOUT: "literals"
+++ /dev/null
-USING: kernel literals math tools.test ;
-IN: literals.tests
-
-<<
-: six-six-six ( -- a b c ) 6 6 6 ;
->>
-
-: five ( -- a ) 5 ;
-: seven-eleven ( -- b c ) 7 11 ;
-
-[ { 5 } ] [ { $ five } ] unit-test
-[ { 7 11 } ] [ { $ seven-eleven } ] unit-test
-[ { 6 6 6 } ] [ { $ six-six-six } ] unit-test
-
-[ { 6 6 6 7 } ] [ { $ six-six-six 7 } ] unit-test
-
-[ { 8 8 8 } ] [ { $[ six-six-six [ 2 + ] tri@ ] } ] unit-test
-
-[ { 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
+++ /dev/null
-! (c) Joe Groff, see license for details
-USING: accessors continuations kernel parser words quotations vectors ;
-IN: literals
-
-SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
-SYNTAX: $[ parse-quotation with-datastack >vector ;
+++ /dev/null
-Expression interpolation into sequence literals
+++ /dev/null
-extensions
-syntax
USING: mason.build tools.test sequences ;
IN: mason.build.tests
-
-{ create-build-dir enter-build-dir clone-builds-factor record-id }
-[ must-infer ] each
-! 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
: 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
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" } ] [
[
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
! 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 )
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? ( -- ? )
- {
- [ 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
+MACRO: recover-cond ( alist -- )
+ dup { [ length 1 = ] [ first callable? ] } 1&&
+ [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ;
- [ 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
+: build-child ( -- status )
+ copy-image
+ {
+ { [ 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
USING: tools.test mason.cleanup ;
IN: mason.cleanup.tests
-
-\ cleanup must-infer
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 ;
! 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 ]
: 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 )
: ?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"
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
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
! 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.
[
"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
-! 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 ;
-! 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 ;
: 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 ( -- )
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
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
: 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 ] }
: 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
-! 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
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 ;
IN: mason.release.upload.tests
USING: mason.release.upload tools.test ;
-\ upload must-infer
: 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 ;
--- /dev/null
+Benchmarks
--- /dev/null
+{ "benchmarks" }
--- /dev/null
+H{ { "a" 1 } { "b" 2 } }
--- /dev/null
+Compile
+Log
--- /dev/null
+Compiler errors
--- /dev/null
+{ "compiler-errors" }
--- /dev/null
+"deadbeef"
--- /dev/null
+{ "help-lint" }
--- /dev/null
+Load everything
--- /dev/null
+{ "load-everything" }
--- /dev/null
+Test all errors
--- /dev/null
+{ "test-all" }
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
-! 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 ;
+
+: 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 ;
-: test-failed-report ( error -- )
+: 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.
-
- nl
-
- load-everything-vocabs-file eval-file [
- "== Did not pass load-everything:" print .
- load-everything-errors-file cat
- ] unless-empty
-
- compiler-errors-file eval-file [
- "== Vocabularies with compiler errors:" print .
- ] unless-empty
-
- test-all-vocabs-file eval-file [
- "== Did not pass test-all:" print .
- test-all-errors-file cat
- ] unless-empty
-
- help-lint-vocabs-file eval-file [
- "== Did not pass help-lint:" print .
- help-lint-errors-file cat
- ] unless-empty
-
- "== Benchmarks:" print
- benchmarks-file eval-file benchmarks.
- ] with-report ;
\ No newline at end of file
+ [
+ timings-table
+
+ "Load failures"
+ load-all-vocabs-file
+ load-all-errors-file
+ error-dump
+
+ "Compiler errors"
+ compiler-errors-file
+ compiler-error-messages-file
+ error-dump
+
+ "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
+
+ "Benchmark errors"
+ benchmark-error-vocabs-file
+ benchmark-error-messages-file
+ error-dump
+
+ "Benchmark timings"
+ benchmarks-file eval-file benchmarks-table
+ ] output>array
+ ] with-report ;
+
+: 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&& ;
+
+: success ( -- status )
+ successful-report build-clean? status-clean status-dirty ? ;
\ No newline at end of file
-! 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 )
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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
#! 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 ;
#! 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 ;
[ 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
[ 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-IN: math.matrices.elimination.tests
-USING: kernel math.matrices math.matrices.elimination
-tools.test sequences ;
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- }
-] [
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- }
-] [
- {
- { 1 0 0 0 }
- { 1 1 0 0 }
- { 1 0 1 0 }
- { 1 0 0 1 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- }
-] [
- {
- { 1 0 0 0 }
- { 1 1 0 0 }
- { 1 0 1 0 }
- { 1 1 0 1 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 1 0 }
- { 0 0 0 1 }
- }
-] [
- {
- { 1 0 0 0 }
- { 1 1 0 0 }
- { 1 1 0 1 }
- { 1 0 1 0 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 0 0 }
- { 0 0 0 0 }
- }
-] [
- {
- { 0 1 0 0 }
- { 1 0 0 0 }
- { 1 0 0 0 }
- { 1 0 0 0 }
- } [
- [ 1 ] [ 0 0 pivot-row ] unit-test
- 1 0 do-row
- ] with-matrix
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 0 0 }
- { 0 0 0 0 }
- }
-] [
- {
- { 0 1 0 0 }
- { 1 0 0 0 }
- { 1 0 0 0 }
- { 1 0 0 0 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 0 0 0 1 }
- { 0 0 0 0 }
- }
-] [
- {
- { 1 0 0 0 }
- { 0 1 0 0 }
- { 1 0 0 1 }
- { 1 0 0 1 }
- } echelon
-] unit-test
-
-[
- {
- { 1 0 0 1 }
- { 0 1 0 1 }
- { 0 0 0 -1 }
- { 0 0 0 0 }
- }
-] [
- {
- { 0 1 0 1 }
- { 1 0 0 1 }
- { 1 0 0 0 }
- { 1 1 0 1 }
- } echelon
-] unit-test
-
-[
- 2
-] [
- {
- { 0 0 }
- { 0 0 }
- } nullspace length
-] unit-test
-
-[
- 1 3
-] [
- {
- { 0 1 0 1 }
- { 1 0 0 1 }
- { 1 0 0 0 }
- { 1 1 0 1 }
- } null/rank
-] unit-test
-
-[
- 1 3
-] [
- {
- { 0 0 0 0 0 1 0 1 }
- { 0 0 0 0 1 0 0 1 }
- { 0 0 0 0 1 0 0 0 }
- { 0 0 0 0 1 1 0 1 }
- } null/rank
-] unit-test
-
-[ { { 1 0 -1 } { 0 1 2 } } ]
-[ { { 1 2 3 } { 4 5 6 } } solution ] unit-test
+++ /dev/null
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.vectors math.matrices namespaces
-sequences ;
-IN: math.matrices.elimination
-
-SYMBOL: matrix
-
-: with-matrix ( matrix quot -- )
- [ swap matrix set call matrix get ] with-scope ; inline
-
-: nth-row ( row# -- seq ) matrix get nth ;
-
-: change-row ( row# quot: ( seq -- seq ) -- )
- matrix get swap change-nth ; inline
-
-: exchange-rows ( row# row# -- ) matrix get exchange ;
-
-: rows ( -- n ) matrix get length ;
-
-: cols ( -- n ) 0 nth-row length ;
-
-: skip ( i seq quot -- n )
- over [ find-from drop ] dip length or ; inline
-
-: first-col ( row# -- n )
- #! First non-zero column
- 0 swap nth-row [ zero? not ] skip ;
-
-: clear-scale ( col# pivot-row i-row -- n )
- [ over ] dip nth dup zero? [
- 3drop 0
- ] [
- [ nth dup zero? ] dip swap [
- 2drop 0
- ] [
- swap / neg
- ] if
- ] if ;
-
-: (clear-col) ( col# pivot-row i -- )
- [ [ clear-scale ] 2keep [ n*v ] dip v+ ] change-row ;
-
-: rows-from ( row# -- slice )
- rows dup <slice> ;
-
-: clear-col ( col# row# rows -- )
- [ nth-row ] dip [ [ 2dup ] dip (clear-col) ] each 2drop ;
-
-: do-row ( exchange-with row# -- )
- [ exchange-rows ] keep
- [ first-col ] keep
- dup 1+ rows-from clear-col ;
-
-: find-row ( row# quot -- i elt )
- [ rows-from ] dip find ; inline
-
-: pivot-row ( col# row# -- n )
- [ dupd nth-row nth zero? not ] find-row 2nip ;
-
-: (echelon) ( col# row# -- )
- over cols < over rows < and [
- 2dup pivot-row [ over do-row 1+ ] when*
- [ 1+ ] dip (echelon)
- ] [
- 2drop
- ] if ;
-
-: echelon ( matrix -- matrix' )
- [ 0 0 (echelon) ] with-matrix ;
-
-: nonzero-rows ( matrix -- matrix' )
- [ [ zero? ] all? not ] filter ;
-
-: null/rank ( matrix -- null rank )
- echelon dup length swap nonzero-rows length [ - ] keep ;
-
-: leading ( seq -- n elt ) [ zero? not ] find ;
-
-: reduced ( matrix' -- matrix'' )
- [
- rows <reversed> [
- dup nth-row leading drop
- dup [ swap dup clear-col ] [ 2drop ] if
- ] each
- ] with-matrix ;
-
-: basis-vector ( row col# -- )
- [ clone ] dip
- [ swap nth neg recip ] 2keep
- [ 0 spin set-nth ] 2keep
- [ n*v ] dip
- matrix get set-nth ;
-
-: nullspace ( matrix -- seq )
- echelon reduced dup empty? [
- dup first length identity-matrix [
- [
- dup leading drop
- dup [ basis-vector ] [ 2drop ] if
- ] each
- ] with-matrix flip nonzero-rows
- ] unless ;
-
-: 1-pivots ( matrix -- matrix )
- [ dup leading nip [ recip v*n ] when* ] map ;
-
-: solution ( matrix -- matrix )
- echelon nonzero-rows reduced 1-pivots ;
-
-: inverse ( matrix -- matrix ) ! Assumes an invertible matrix
- dup length
- [ identity-matrix [ append ] 2map solution ] keep
- [ tail ] curry map ;
+++ /dev/null
-Solving systems of linear equations
+++ /dev/null
-IN: math.matrices.tests
-USING: math.matrices math.vectors tools.test math ;
-
-[
- { { 0 } { 0 } { 0 } }
-] [
- 3 1 zero-matrix
-] unit-test
-
-[
- { { 1 0 0 }
- { 0 1 0 }
- { 0 0 1 } }
-] [
- 3 identity-matrix
-] unit-test
-
-[
- { { 1 0 4 }
- { 0 7 0 }
- { 6 0 3 } }
-] [
- { { 1 0 0 }
- { 0 2 0 }
- { 0 0 3 } }
-
- { { 0 0 4 }
- { 0 5 0 }
- { 6 0 0 } }
-
- m+
-] unit-test
-
-[
- { { 1 0 4 }
- { 0 7 0 }
- { 6 0 3 } }
-] [
- { { 1 0 0 }
- { 0 2 0 }
- { 0 0 3 } }
-
- { { 0 0 -4 }
- { 0 -5 0 }
- { -6 0 0 } }
-
- m-
-] unit-test
-
-[
- { 10 20 30 }
-] [
- 10 { 1 2 3 } n*v
-] unit-test
-
-[
- { 3 4 }
-] [
- { { 1 0 }
- { 0 1 } }
-
- { 3 4 }
-
- m.v
-] unit-test
-
-[
- { 4 3 }
-] [
- { { 0 1 }
- { 1 0 } }
-
- { 3 4 }
-
- m.v
-] unit-test
-
-[
- { { 6 } }
-] [
- { { 3 } } { { 2 } } m.
-] unit-test
-
-[
- { { 11 } }
-] [
- { { 1 3 } } { { 5 } { 2 } } m.
-] unit-test
-
-[
- { { 28 } }
-] [
- { { 2 4 6 } }
-
- { { 1 }
- { 2 }
- { 3 } }
-
- m.
-] unit-test
-
-[ { 0 0 -1 } ] [ { 1 0 0 } { 0 1 0 } cross ] unit-test
-[ { 1 0 0 } ] [ { 0 1 0 } { 0 0 1 } cross ] unit-test
-[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
-
-[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
-
-[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2005, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.vectors sequences ;
-IN: math.matrices
-
-! Matrices
-: zero-matrix ( m n -- matrix )
- [ nip 0 <array> ] curry map ;
-
-: identity-matrix ( n -- matrix )
- #! Make a nxn identity matrix.
- dup [ [ = 1 0 ? ] with map ] curry map ;
-
-! Matrix operations
-: mneg ( m -- m ) [ vneg ] map ;
-
-: n*m ( n m -- m ) [ n*v ] with map ;
-: m*n ( m n -- m ) [ v*n ] curry map ;
-: n/m ( n m -- m ) [ n/v ] with map ;
-: m/n ( m n -- m ) [ v/n ] curry map ;
-
-: m+ ( m m -- m ) [ v+ ] 2map ;
-: m- ( m m -- m ) [ v- ] 2map ;
-: m* ( m m -- m ) [ v* ] 2map ;
-: m/ ( m m -- m ) [ v/ ] 2map ;
-
-: v.m ( v m -- v ) flip [ v. ] with map ;
-: m.v ( m v -- v ) [ v. ] curry map ;
-: m. ( m m -- m ) flip [ swap m.v ] curry map ;
-
-: mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ;
-: mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ;
-: mnorm ( m -- n ) dup mmax abs m/n ;
-
-<PRIVATE
-
-: x ( seq -- elt ) first ; inline
-: y ( seq -- elt ) second ; inline
-: z ( seq -- elt ) third ; inline
-
-: i ( seq1 seq2 -- n ) [ [ y ] [ z ] bi* * ] [ [ z ] [ y ] bi* * ] 2bi - ;
-: j ( seq1 seq2 -- n ) [ [ z ] [ x ] bi* * ] [ [ x ] [ z ] bi* * ] 2bi - ;
-: k ( seq1 seq2 -- n ) [ [ y ] [ x ] bi* * ] [ [ x ] [ y ] bi* * ] 2bi - ;
-
-PRIVATE>
-
-: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
-
-: proj ( v u -- w )
- [ [ v. ] [ norm-sq ] bi / ] keep n*v ;
-
-: (gram-schmidt) ( v seq -- newseq )
- [ dupd proj v- ] each ;
-
-: gram-schmidt ( seq -- orthogonal )
- V{ } clone [ over (gram-schmidt) over push ] reduce ;
-
-: norm-gram-schmidt ( seq -- orthonormal )
- gram-schmidt [ normalize ] map ;
-
-: cross-zip ( seq1 seq2 -- seq1xseq2 )
- [ [ 2array ] with map ] curry map ;
\ No newline at end of file
+++ /dev/null
-Matrix arithmetic
! 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
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
--- /dev/null
+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 }
+}
--- /dev/null
+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
--- /dev/null
+unportable
+
--- /dev/null
+USING: help.syntax help.markup kernel math classes classes.tuple\r
+calendar models ;\r
+IN: models.history\r
+\r
+HELP: history\r
+{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;\r
+\r
+HELP: <history>\r
+{ $values { "value" object } { "history" "a new " { $link history } } }\r
+{ $description "Creates a new history model with an initial value." } ;\r
+\r
+{ <history> add-history go-back go-forward } related-words\r
+\r
+HELP: go-back\r
+{ $values { "history" history } }\r
+{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
+\r
+HELP: go-forward\r
+{ $values { "history" history } }\r
+{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;\r
+\r
+HELP: add-history\r
+{ $values { "history" history } }\r
+{ $description "Adds the current value to the history." } ;\r
+\r
+ARTICLE: "models-history" "History models"\r
+"History models record previous values."\r
+{ $subsection history }\r
+{ $subsection <history> }\r
+"Recording history:"\r
+{ $subsection add-history }\r
+"Navigating the history:"\r
+{ $subsection go-back }\r
+{ $subsection go-forward } ;\r
+\r
+ABOUT: "models-history"\r
--- /dev/null
+USING: arrays generic kernel math models namespaces sequences assocs\r
+tools.test models.history accessors ;\r
+IN: models.history.tests\r
+\r
+f <history> "history" set\r
+\r
+"history" get add-history\r
+\r
+[ t ] [ "history" get back>> empty? ] unit-test\r
+[ t ] [ "history" get forward>> empty? ] unit-test\r
+\r
+"history" get add-history\r
+3 "history" get set-model\r
+\r
+[ t ] [ "history" get back>> empty? ] unit-test\r
+[ t ] [ "history" get forward>> empty? ] unit-test\r
+\r
+"history" get add-history\r
+4 "history" get set-model\r
+\r
+[ f ] [ "history" get back>> empty? ] unit-test\r
+[ t ] [ "history" get forward>> empty? ] unit-test\r
+\r
+"history" get go-back\r
+\r
+[ 3 ] [ "history" get value>> ] unit-test\r
+\r
+[ t ] [ "history" get back>> empty? ] unit-test\r
+[ f ] [ "history" get forward>> empty? ] unit-test\r
+\r
+"history" get go-forward\r
+\r
+[ 4 ] [ "history" get value>> ] unit-test\r
+\r
+[ f ] [ "history" get back>> empty? ] unit-test\r
+[ t ] [ "history" get forward>> empty? ] unit-test\r
+\r
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors kernel models sequences ;\r
+IN: models.history\r
+\r
+TUPLE: history < model back forward ;\r
+\r
+: reset-history ( history -- history )\r
+ V{ } clone >>back\r
+ V{ } clone >>forward ; inline\r
+\r
+: <history> ( value -- history )\r
+ history new-model\r
+ reset-history ;\r
+\r
+: (add-history) ( history to -- )\r
+ swap value>> dup [ swap push ] [ 2drop ] if ;\r
+\r
+: go-back/forward ( history to from -- )\r
+ [ 2drop ]\r
+ [ [ dupd (add-history) ] dip pop swap set-model ] if-empty ;\r
+\r
+: go-back ( history -- )\r
+ dup [ forward>> ] [ back>> ] bi go-back/forward ;\r
+\r
+: go-forward ( history -- )\r
+ dup [ back>> ] [ forward>> ] bi go-back/forward ;\r
+\r
+: add-history ( history -- )\r
+ dup forward>> delete-all\r
+ dup back>> (add-history) ;\r
--- /dev/null
+History models remember prior values
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: modules.rpc-server vocabs ;
+IN: modules.remote-loading mem-service
+
+: get-vocab ( vocabstr -- vocab ) vocab ;
\ No newline at end of file
--- /dev/null
+required for listeners allowing remote loading of modules
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+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
--- /dev/null
+remote procedure call server
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+remote procedure call client
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+module pushing in remote-loading listeners
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+Sam Anklesaria
--- /dev/null
+improved module import syntax
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+Sascha Matzke
--- /dev/null
+Sascha Matzke
--- /dev/null
+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
+
--- /dev/null
+serialization/deserialization and insert/query benchmarks for mongodb.driver
--- /dev/null
+Sascha Matzke
--- /dev/null
+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
--- /dev/null
+low-level connection handling for mongodb.driver
--- /dev/null
+Sascha Matzke
--- /dev/null
+! 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" } ;
+
+
--- /dev/null
+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 ;
+
+
--- /dev/null
+A driver for the MongoDB document-oriented database (http://www.mongodb.org)
--- /dev/null
+Sascha Matzke
--- /dev/null
+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
--- /dev/null
+mongo-message-monitor - a small proxy to introspect messages send to MongoDB
--- /dev/null
+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
--- /dev/null
+USING: vocabs.loader ;
+
+IN: mongodb
+
+"mongodb.connection" require
+"mongodb.driver" require
+"mongodb.tuple" require
+
--- /dev/null
+Sascha Matzke
--- /dev/null
+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
+
--- /dev/null
+message primitives for the communication with MongoDB
--- /dev/null
+Sascha Matzke
--- /dev/null
+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) ;
+
--- /dev/null
+low-level message reading and writing
--- /dev/null
+MongoDB Factor integration
--- /dev/null
+Sascha Matzke
--- /dev/null
+Sascha Matzke
--- /dev/null
+
+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? ;
--- /dev/null
+tuple class MongoDB collection handling
--- /dev/null
+Sascha Matzke
--- /dev/null
+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
+
--- /dev/null
+tuple to MongoDB storable conversion (and back)
--- /dev/null
+Sascha Matzke
--- /dev/null
+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? ;
+
--- /dev/null
+client-side persistent tuple state handling
--- /dev/null
+persist tuple instances into MongoDB
--- /dev/null
+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 ;
--- /dev/null
+Alex Chapman
+Diego Martinelli
--- /dev/null
+! Copyright (C) 2007 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax ;
+IN: morse
+
+HELP: ch>morse
+{ $values
+ { "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 a space character." } ;
+
+HELP: >morse
+{ $values
+ { "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 { "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 } ;
+
+HELP: play-as-morse*
+{ $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } }
+{ $description "Plays a string as morse code" } ;
+
+HELP: play-as-morse
+{ $values { "str" "A string of ascii characters which can be translated into morse code" } }
+{ $description "Plays a string as morse code" } ;
--- /dev/null
+! 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
--- /dev/null
+! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
+! See http://factorcode.org/license.txt for BSD license.
+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
+
+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 "-.-." }
+ { CHAR: d "-.." }
+ { CHAR: e "." }
+ { CHAR: f "..-." }
+ { CHAR: g "--." }
+ { CHAR: h "...." }
+ { CHAR: i ".." }
+ { CHAR: j ".---" }
+ { CHAR: k "-.-" }
+ { CHAR: l ".-.." }
+ { CHAR: m "--" }
+ { CHAR: n "-." }
+ { CHAR: o "---" }
+ { CHAR: p ".--." }
+ { CHAR: q "--.-" }
+ { CHAR: r ".-." }
+ { CHAR: s "..." }
+ { CHAR: t "-" }
+ { CHAR: u "..-" }
+ { CHAR: v "...-" }
+ { CHAR: w ".--" }
+ { CHAR: x "-..-" }
+ { CHAR: y "-.--" }
+ { CHAR: z "--.." }
+ { CHAR: 1 ".----" }
+ { CHAR: 2 "..---" }
+ { CHAR: 3 "...--" }
+ { CHAR: 4 "....-" }
+ { CHAR: 5 "....." }
+ { CHAR: 6 "-...." }
+ { CHAR: 7 "--..." }
+ { CHAR: 8 "---.." }
+ { CHAR: 9 "----." }
+ { CHAR: 0 "-----" }
+ { CHAR: . ".-.-.-" }
+ { CHAR: , "--..--" }
+ { CHAR: ? "..--.." }
+ { CHAR: ' ".----." }
+ { CHAR: ! "-.-.--" }
+ { CHAR: / "-..-." }
+ { CHAR: ( "-.--." }
+ { CHAR: ) "-.--.-" }
+ { CHAR: & ".-..." }
+ { CHAR: : "---..." }
+ { CHAR: ; "-.-.-." }
+ { CHAR: = "-...- " }
+ { CHAR: + ".-.-." }
+ { CHAR: - "-....-" }
+ { CHAR: _ "..--.-" }
+ { CHAR: " ".-..-." }
+ { CHAR: $ "...-..-" }
+ { CHAR: @ ".--.-." }
+ { CHAR: \s "/" }
+ } >biassoc
+]
+
+: ch>morse ( ch -- morse )
+ ch>lower morse-code-table at unknown-char 1string or ;
+
+: morse>ch ( str -- ch )
+ morse-code-table value-at char-gap-char or ;
+
+<PRIVATE
+
+: word>morse ( str -- morse )
+ [ ch>morse ] { } map-as " " join ;
+
+: sentence>morse ( str -- morse )
+ " " split [ word>morse ] map " / " join ;
+
+: trim-blanks ( str -- newstr )
+ [ blank? ] trim ; inline
+
+: morse>word ( morse -- str )
+ " " split [ morse>ch ] "" map-as ;
+
+: morse>sentence ( morse -- sentence )
+ "/" split [ trim-blanks morse>word ] map " " join ;
+
+: 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 ;
+
+SYNTAX: [MORSE "MORSE]" parse-multiline-string morse> parsed ;
+
+<PRIVATE
+
+SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
+
+: queue ( symbol -- )
+ get source get swap queue-buffer ;
+
+: dot ( -- ) dot-buffer queue ;
+: dash ( -- ) dash-buffer queue ;
+: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
+: letter-gap ( -- ) letter-gap-buffer queue ;
+
+CONSTANT: beep-freq 880
+
+: <morse-buffer> ( -- buffer )
+ half-sample-freq <8bit-mono-buffer> ;
+
+: sine-buffer ( seconds -- id )
+ beep-freq swap <morse-buffer> >sine-wave-buffer
+ send-buffer id>> ;
+
+: silent-buffer ( seconds -- id )
+ <morse-buffer> >silent-buffer send-buffer id>> ;
+
+: make-buffers ( unit-length -- )
+ {
+ [ sine-buffer dot-buffer set ]
+ [ 3 * sine-buffer dash-buffer set ]
+ [ silent-buffer intra-char-gap-buffer set ]
+ [ 3 * silent-buffer letter-gap-buffer set ]
+ } cleave ;
+
+: playing-morse ( quot unit-length -- )
+ [
+ init-openal 1 gen-sources first source set make-buffers
+ call
+ source get source-play
+ ] with-scope ; inline
+
+: 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 ;
+
+PRIVATE>
+
+: play-as-morse* ( str unit-length -- )
+ [
+ [ letter-gap ] [ ch>morse play-char ] interleave
+ ] swap playing-morse ; inline
+
+: play-as-morse ( str -- )
+ 0.05 play-as-morse* ; inline
--- /dev/null
+Converts between text and morse code, and plays morse code.
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences vectors classes classes.algebra
-combinators arrays words assocs parser namespaces make
-definitions prettyprint prettyprint.backend prettyprint.custom
-quotations generalizations debugger io compiler.units
-kernel.private effects accessors hashtables sorting shuffle
-math.order sets see effects.parser ;
-IN: multi-methods
-
-! PART I: Converting hook specializers
-: canonicalize-specializer-0 ( specializer -- specializer' )
- [ \ f or ] map ;
-
-SYMBOL: args
-
-SYMBOL: hooks
-
-SYMBOL: total
-
-: canonicalize-specializer-1 ( specializer -- specializer' )
- [
- [ class? ] filter
- [ length <reversed> [ 1+ neg ] map ] keep zip
- [ length args [ max ] change ] keep
- ]
- [
- [ pair? ] filter
- [ keys [ hooks get adjoin ] each ] keep
- ] bi append ;
-
-: canonicalize-specializer-2 ( specializer -- specializer' )
- [
- [
- {
- { [ dup integer? ] [ ] }
- { [ dup word? ] [ hooks get index ] }
- } cond args get +
- ] dip
- ] assoc-map ;
-
-: canonicalize-specializer-3 ( specializer -- specializer' )
- [ total get object <array> dup <enum> ] dip update ;
-
-: canonicalize-specializers ( methods -- methods' hooks )
- [
- [ [ canonicalize-specializer-0 ] dip ] assoc-map
-
- 0 args set
- V{ } clone hooks set
-
- [ [ canonicalize-specializer-1 ] dip ] assoc-map
-
- hooks [ natural-sort ] change
-
- [ [ canonicalize-specializer-2 ] dip ] assoc-map
-
- args get hooks get length + total set
-
- [ [ canonicalize-specializer-3 ] dip ] assoc-map
-
- hooks get
- ] with-scope ;
-
-: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
-
-: prepare-method ( method n -- quot )
- [ 1quotation ] [ drop-n-quot ] bi* prepend ;
-
-: prepare-methods ( methods -- methods' prologue )
- canonicalize-specializers
- [ length [ prepare-method ] curry assoc-map ] keep
- [ [ get ] curry ] map concat [ ] like ;
-
-! Part II: Topologically sorting specializers
-: maximal-element ( seq quot -- n elt )
- dupd [
- swapd [ call +lt+ = ] 2curry filter empty?
- ] 2curry find [ "Topological sort failed" throw ] unless* ;
- inline
-
-: topological-sort ( seq quot -- newseq )
- [ >vector [ dup empty? not ] ] dip
- [ dupd maximal-element [ over delete-nth ] dip ] curry
- produce nip ; inline
-
-: classes< ( seq1 seq2 -- lt/eq/gt )
- [
- {
- { [ 2dup eq? ] [ +eq+ ] }
- { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
- { [ 2dup class<= ] [ +lt+ ] }
- { [ 2dup swap class<= ] [ +gt+ ] }
- [ +eq+ ]
- } cond 2nip
- ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
-
-: sort-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
-! PART III: Creating dispatch quotation
-: picker ( n -- quot )
- {
- { 0 [ [ dup ] ] }
- { 1 [ [ over ] ] }
- { 2 [ [ pick ] ] }
- [ 1- picker [ dip swap ] curry ]
- } case ;
-
-: (multi-predicate) ( class picker -- quot )
- swap "predicate" word-prop append ;
-
-: multi-predicate ( classes -- quot )
- dup length <reversed>
- [ picker 2array ] 2map
- [ drop object eq? not ] assoc-filter
- [ [ t ] ] [
- [ (multi-predicate) ] { } assoc>map
- unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
- ] if-empty ;
-
-: argument-count ( methods -- n )
- keys 0 [ length max ] reduce ;
-
-ERROR: no-method arguments generic ;
-
-: make-default-method ( methods generic -- quot )
- [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
-
-: multi-dispatch-quot ( methods generic -- quot )
- [ make-default-method ]
- [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
- 2bi alist>quot ;
-
-! Generic words
-PREDICATE: generic < word
- "multi-methods" word-prop >boolean ;
-
-: methods ( word -- alist )
- "multi-methods" word-prop >alist ;
-
-: make-generic ( generic -- quot )
- [
- [ methods prepare-methods % sort-methods ] keep
- multi-dispatch-quot %
- ] [ ] make ;
-
-: update-generic ( word -- )
- dup make-generic define ;
-
-! Methods
-PREDICATE: method-body < word
- "multi-method-generic" word-prop >boolean ;
-
-M: method-body stack-effect
- "multi-method-generic" word-prop stack-effect ;
-
-M: method-body crossref?
- "forgotten" word-prop not ;
-
-: method-word-name ( specializer generic -- string )
- [ name>> % "-" % unparse % ] "" make ;
-
-: method-word-props ( specializer generic -- assoc )
- [
- "multi-method-generic" set
- "multi-method-specializer" set
- ] H{ } make-assoc ;
-
-: <method> ( specializer generic -- word )
- [ method-word-props ] 2keep
- method-word-name f <word>
- swap >>props ;
-
-: with-methods ( word quot -- )
- over [
- [ "multi-methods" word-prop ] dip call
- ] dip update-generic ; inline
-
-: reveal-method ( method classes generic -- )
- [ set-at ] with-methods ;
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: create-method ( classes generic -- method )
- 2dup method dup [
- 2nip
- ] [
- drop [ <method> dup ] 2keep reveal-method
- ] if ;
-
-: niceify-method ( seq -- seq )
- [ dup \ f eq? [ drop f ] when ] map ;
-
-M: no-method error.
- "Type check error" print
- nl
- "Generic word " write dup generic>> pprint
- " does not have a method applicable to inputs:" print
- dup arguments>> short.
- nl
- "Inputs have signature:" print
- dup arguments>> [ class ] map niceify-method .
- nl
- "Available methods: " print
- generic>> methods canonicalize-specializers drop sort-methods
- keys [ niceify-method ] map stack. ;
-
-: forget-method ( specializer generic -- )
- [ delete-at ] with-methods ;
-
-: method>spec ( method -- spec )
- [ "multi-method-specializer" word-prop ]
- [ "multi-method-generic" word-prop ] bi prefix ;
-
-: define-generic ( word effect -- )
- over set-stack-effect
- dup "multi-methods" word-prop [ drop ] [
- [ H{ } clone "multi-methods" set-word-prop ]
- [ update-generic ]
- bi
- ] if ;
-
-! Syntax
-SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
-
-: parse-method ( -- quot classes generic )
- parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-
-: create-method-in ( specializer generic -- method )
- create-method dup save-location f set-word ;
-
-: CREATE-METHOD ( -- method )
- scan-word scan-object swap create-method-in ;
-
-: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
-
-SYNTAX: METHOD: (METHOD:) define ;
-
-! For compatibility
-SYNTAX: M:
- scan-word 1array scan-word create-method-in
- parse-definition
- define ;
-
-! Definition protocol. We qualify core generics here
-QUALIFIED: syntax
-
-syntax:M: generic definer drop \ GENERIC: f ;
-
-syntax:M: generic definition drop f ;
-
-PREDICATE: method-spec < array
- unclip generic? [ [ class? ] all? ] dip and ;
-
-syntax:M: method-spec where
- dup unclip method [ ] [ first ] ?if where ;
-
-syntax:M: method-spec set-where
- unclip method set-where ;
-
-syntax:M: method-spec definer
- unclip method definer ;
-
-syntax:M: method-spec definition
- unclip method definition ;
-
-syntax:M: method-spec synopsis*
- unclip method synopsis* ;
-
-syntax:M: method-spec forget*
- unclip method forget* ;
-
-syntax:M: method-body definer
- drop \ METHOD: \ ; ;
-
-syntax:M: method-body synopsis*
- dup definer.
- [ "multi-method-generic" word-prop pprint-word ]
- [ "multi-method-specializer" word-prop pprint* ] bi ;
+++ /dev/null
-Experimental multiple dispatch implementation
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings ;
-
-[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
-
-: setup-canon-test ( -- )
- 0 args set
- V{ } clone hooks set ;
-
-: canon-test-1 ( -- seq )
- { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
-
-[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- ] with-scope
-] unit-test
-
-[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- ] with-scope
-] unit-test
-
-[ { integer sequence x86 } ] [
- [
- setup-canon-test
- canon-test-1
- canonicalize-specializer-2
- args get hooks get length + total set
- canonicalize-specializer-3
- ] with-scope
-] unit-test
-
-CONSTANT: example-1
- {
- { { { cpu x86 } { os linux } } "a" }
- { { { cpu ppc } } "b" }
- { { string { os windows } } "c" }
- }
-
-[
- {
- { { object x86 linux } "a" }
- { { object ppc object } "b" }
- { { string object windows } "c" }
- }
- { cpu os }
-] [
- example-1 canonicalize-specializers
-] unit-test
-
-[
- {
- { { object x86 linux } [ drop drop "a" ] }
- { { object ppc object } [ drop drop "b" ] }
- { { string object windows } [ drop drop "c" ] }
- }
- [ \ cpu get \ os get ]
-] [
- example-1 prepare-methods
-] unit-test
+++ /dev/null
-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
-
-[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
-
-[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
-[ { } \ fake method-word-props ] unit-test
-
-[ t ] [ { } \ fake <method> method-body? ] unit-test
-
-[
- [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
-
- [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
-
- [ t ] [ \ fake make-generic quotation? ] unit-test
-
- [ ] [ \ fake update-generic ] unit-test
-
- DEFER: testing
-
- [ ] [ \ testing (( -- )) define-generic ] unit-test
-
- [ t ] [ \ testing generic? ] unit-test
-] with-compilation-unit
+++ /dev/null
-IN: multi-methods.tests
-USING: math strings sequences tools.test ;
-
-GENERIC: legacy-test ( a -- b )
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
+++ /dev/null
-IN: multi-methods.tests
-USING: multi-methods tools.test math sequences namespaces system
-kernel strings definitions prettyprint debugger arrays
-hashtables continuations classes assocs accessors see ;
-
-GENERIC: first-test ( -- )
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-SINGLETON: paper INSTANCE: paper thing
-SINGLETON: scissors INSTANCE: scissors thing
-SINGLETON: rock INSTANCE: rock thing
-
-GENERIC: beats? ( obj1 obj2 -- ? )
-
-METHOD: beats? { paper scissors } t ;
-METHOD: beats? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
-
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ { { } 3 } ] [ error get arguments>> ] unit-test
-[ t ] [ paper scissors play ] unit-test
-[ f ] [ scissors paper play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-SYMBOL: some-var
-
-GENERIC: hook-test ( -- obj )
-
-METHOD: hook-test { array { some-var array } } reverse ;
-METHOD: hook-test { { some-var array } } class ;
-METHOD: hook-test { hashtable { some-var number } } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-"error" some-var set
-[ H{ } hook-test ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ { H{ } "error" } ] [ error get arguments>> ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
+++ /dev/null
-USING: kernel multi-methods tools.test math arrays sequences
-math.order ;
-IN: multi-methods.tests
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ +lt+ ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ +eq+ ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ +gt+ ] [
- { object object } { number sequence } classes<
-] unit-test
+++ /dev/null
-
-USING: kernel sequences assocs circular sets fry ;
-
-USING: math multi-methods ;
-
-QUALIFIED: sequences
-QUALIFIED: assocs
-QUALIFIED: circular
-QUALIFIED: sets
-
-IN: newfx
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! Now, we can see a new world coming into view.
-! A world in which there is the very real prospect of a new world order.
-!
-! - George Herbert Walker Bush
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: at ( col key -- val )
-GENERIC: of ( key col -- val )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: grab ( col key -- col val )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: is ( col key val -- col )
-GENERIC: as ( col val key -- col )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: is-of ( key val col -- col )
-GENERIC: as-of ( val key col -- col )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: mutate-at ( col key val -- )
-GENERIC: mutate-as ( col val key -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: at-mutate ( key val col -- )
-GENERIC: as-mutate ( val key col -- )
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! sequence
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at { sequence number } swap nth ;
-METHOD: of { number sequence } nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: grab { sequence number } dupd swap nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is { sequence number object } swap pick set-nth ;
-METHOD: as { sequence object number } pick set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is-of { number object sequence } dup [ swapd set-nth ] dip ;
-METHOD: as-of { object number sequence } dup [ set-nth ] dip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: mutate-at { sequence number object } swap rot set-nth ;
-METHOD: mutate-as { sequence object number } rot set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at-mutate { number object sequence } swapd set-nth ;
-METHOD: as-mutate { object number sequence } set-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! assoc
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at { assoc object } swap assocs:at ;
-METHOD: of { object assoc } assocs:at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: grab { assoc object } dupd swap assocs:at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is { assoc object object } swap pick set-at ;
-METHOD: as { assoc object object } pick set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: is-of { object object assoc } dup [ swapd set-at ] dip ;
-METHOD: as-of { object object assoc } dup [ set-at ] dip ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: mutate-at { assoc object object } swap rot set-at ;
-METHOD: mutate-as { assoc object object } rot set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-METHOD: at-mutate { object object assoc } swapd set-at ;
-METHOD: as-mutate { object object assoc } set-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: push ( seq obj -- seq ) over sequences:push ;
-: push-on ( obj seq -- seq ) tuck sequences:push ;
-: pushed ( seq obj -- ) swap sequences:push ;
-: pushed-on ( obj seq -- ) sequences:push ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: member? ( seq obj -- ? ) swap sequences:member? ;
-: member-of? ( obj seq -- ? ) sequences:member? ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: delete-at-key ( tbl key -- tbl ) over delete-at ;
-: delete-key-of ( key tbl -- tbl ) tuck delete-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: delete ( seq elt -- seq ) over sequences:delete ;
-: delete-from ( elt seq -- seq ) tuck sequences:delete ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: deleted ( seq elt -- ) swap sequences:delete ;
-: deleted-from ( elt seq -- ) sequences:delete ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: remove ( seq obj -- seq ) swap sequences:remove ;
-: remove-from ( obj seq -- seq ) sequences:remove ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: filter-of ( quot seq -- seq ) swap filter ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: map-over ( quot seq -- seq ) swap map ; inline
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: push-circular ( seq elt -- seq ) over circular:push-circular ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prefix-on ( elt seq -- seq ) swap prefix ;
-: suffix-on ( elt seq -- seq ) swap suffix ;
-
-: suffix! ( seq elt -- seq ) over sequences:push ;
-: suffix-on! ( elt seq -- seq ) tuck sequences:push ;
-: suffixed! ( seq elt -- ) swap sequences:push ;
-: suffixed-on! ( elt seq -- ) sequences:push ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: subseq ( seq from to -- subseq ) rot sequences:subseq ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: key ( table val -- key ) swap assocs:value-at ;
-
-: key-of ( val table -- key ) assocs:value-at ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: index ( seq obj -- i ) swap sequences:index ;
-: index-of ( obj seq -- i ) sequences:index ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: 1st ( seq -- obj ) 0 swap nth ;
-: 2nd ( seq -- obj ) 1 swap nth ;
-: 3rd ( seq -- obj ) 2 swap nth ;
-: 4th ( seq -- obj ) 3 swap nth ;
-: 5th ( seq -- obj ) 4 swap nth ;
-: 6th ( seq -- obj ) 5 swap nth ;
-: 7th ( seq -- obj ) 6 swap nth ;
-: 8th ( seq -- obj ) 7 swap nth ;
-: 9th ( seq -- obj ) 8 swap nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! A note about the 'mutate' qualifier. Other words also technically mutate
-! their primary object. However, the 'mutate' qualifier is supposed to
-! indicate that this is the main objective of the word, as a side effect.
-
-: adjoin ( seq elt -- seq ) over sets:adjoin ;
-: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ;
-: adjoined ( set elt -- ) swap sets:adjoin ;
-: adjoined-on ( elt set -- ) sets:adjoin ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: start ( seq subseq -- i ) swap sequences:start ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pluck ( seq i -- seq ) cut-slice rest-slice append ;
-: pluck-from ( i seq -- seq ) swap pluck ;
-: pluck! ( seq i -- seq ) over delete-nth ;
-: pluck-from! ( i seq -- seq ) tuck delete-nth ;
-: plucked! ( seq i -- ) swap delete-nth ;
-: plucked-from! ( i seq -- ) delete-nth ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: snip ( seq a b -- seq ) [ over ] dip [ head ] [ tail ] 2bi* append ;
-: snip-this ( a b seq -- seq ) -rot snip ;
-: snip! ( seq a b -- seq ) pick delete-slice ;
-: snip-this! ( a b seq -- seq ) -rot pick delete-slice ;
-: snipped! ( seq a b -- ) rot delete-slice ;
-: snipped-from! ( a b seq -- ) delete-slice ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: invert-index ( seq i -- seq i ) [ dup length 1 - ] dip - ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: append! ( a b -- ab ) over sequences:push-all ;
-: append-to! ( b a -- ab ) swap over sequences:push-all ;
-: appended! ( a b -- ) swap sequences:push-all ;
-: appended-to! ( b a -- ) sequences:push-all ;
-
-: prepend! ( a b -- ba ) over append 0 pick copy ;
-: prepended! ( a b -- ) over append 0 rot copy ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: insert ( seq i obj -- seq ) [ cut ] dip prefix append ;
-
-: splice ( seq i seq -- seq ) [ cut ] dip prepend append ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: purge ( seq quot -- seq ) [ not ] compose filter ; inline
-
-: purge! ( seq quot -- seq )
- dupd '[ swap @ [ pluck! ] [ drop ] if ] each-index ; inline
--- /dev/null
+Chris Double
--- /dev/null
+Chris Double
--- /dev/null
+USING: namespaces system ;
+IN: openal.backend
+
+HOOK: load-wav-file os ( filename -- format data size frequency )
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: calendar kernel openal sequences threads ;\r
+IN: openal.example\r
+\r
+: play-hello ( -- )\r
+ init-openal\r
+ 1 gen-sources\r
+ first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param\r
+ source-play\r
+ 1000 milliseconds sleep ;\r
+ \r
+: (play-file) ( source -- )\r
+ 100 milliseconds sleep\r
+ dup source-playing? [ (play-file) ] [ drop ] if ;\r
+\r
+: play-file ( filename -- )\r
+ init-openal\r
+ create-buffer-from-file \r
+ 1 gen-sources\r
+ first dup [ AL_BUFFER rot set-source-param ] dip\r
+ dup source-play\r
+ check-error\r
+ (play-file) ;\r
+\r
+: play-wav ( filename -- )\r
+ init-openal\r
+ create-buffer-from-wav \r
+ 1 gen-sources\r
+ first dup [ AL_BUFFER rot set-source-param ] dip\r
+ dup source-play\r
+ check-error\r
+ (play-file) ;\r
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel alien alien.syntax shuffle
+openal.backend namespaces system generalizations ;
+IN: openal.macosx
+
+LIBRARY: alut
+
+FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
+
+M: macosx load-wav-file ( path -- format data size frequency )
+ 0 <int> f <void*> 0 <int> 0 <int>
+ [ alutLoadWAVFile ] 4 nkeep
+ [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors arrays alien system combinators alien.syntax namespaces
+ alien.c-types sequences vocabs.loader shuffle
+ openal.backend specialized-arrays.uint alien.libraries generalizations ;
+IN: openal
+
+<< "alut" {
+ { [ os windows? ] [ "alut.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libalut.so" ] }
+ } cond "cdecl" add-library >>
+
+<< "openal" {
+ { [ os windows? ] [ "OpenAL32.dll" ] }
+ { [ os macosx? ] [
+ "/System/Library/Frameworks/OpenAL.framework/OpenAL"
+ ] }
+ { [ os unix? ] [ "libopenal.so" ] }
+ } cond "cdecl" add-library >>
+
+LIBRARY: openal
+
+TYPEDEF: char ALboolean
+TYPEDEF: char ALchar
+TYPEDEF: char ALbyte
+TYPEDEF: uchar ALubyte
+TYPEDEF: short ALshort
+TYPEDEF: ushort ALushort
+TYPEDEF: int ALint
+TYPEDEF: uint ALuint
+TYPEDEF: int ALsizei
+TYPEDEF: int ALenum
+TYPEDEF: float ALfloat
+TYPEDEF: double ALdouble
+
+CONSTANT: AL_INVALID -1
+CONSTANT: AL_NONE 0
+CONSTANT: AL_FALSE 0
+CONSTANT: AL_TRUE 1
+CONSTANT: AL_SOURCE_RELATIVE HEX: 202
+CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001
+CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002
+CONSTANT: AL_PITCH HEX: 1003
+CONSTANT: AL_POSITION HEX: 1004
+CONSTANT: AL_DIRECTION HEX: 1005
+CONSTANT: AL_VELOCITY HEX: 1006
+CONSTANT: AL_LOOPING HEX: 1007
+CONSTANT: AL_BUFFER HEX: 1009
+CONSTANT: AL_GAIN HEX: 100A
+CONSTANT: AL_MIN_GAIN HEX: 100D
+CONSTANT: AL_MAX_GAIN HEX: 100E
+CONSTANT: AL_ORIENTATION HEX: 100F
+CONSTANT: AL_CHANNEL_MASK HEX: 3000
+CONSTANT: AL_SOURCE_STATE HEX: 1010
+CONSTANT: AL_INITIAL HEX: 1011
+CONSTANT: AL_PLAYING HEX: 1012
+CONSTANT: AL_PAUSED HEX: 1013
+CONSTANT: AL_STOPPED HEX: 1014
+CONSTANT: AL_BUFFERS_QUEUED HEX: 1015
+CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016
+CONSTANT: AL_SEC_OFFSET HEX: 1024
+CONSTANT: AL_SAMPLE_OFFSET HEX: 1025
+CONSTANT: AL_BYTE_OFFSET HEX: 1026
+CONSTANT: AL_SOURCE_TYPE HEX: 1027
+CONSTANT: AL_STATIC HEX: 1028
+CONSTANT: AL_STREAMING HEX: 1029
+CONSTANT: AL_UNDETERMINED HEX: 1030
+CONSTANT: AL_FORMAT_MONO8 HEX: 1100
+CONSTANT: AL_FORMAT_MONO16 HEX: 1101
+CONSTANT: AL_FORMAT_STEREO8 HEX: 1102
+CONSTANT: AL_FORMAT_STEREO16 HEX: 1103
+CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020
+CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021
+CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022
+CONSTANT: AL_MAX_DISTANCE HEX: 1023
+CONSTANT: AL_FREQUENCY HEX: 2001
+CONSTANT: AL_BITS HEX: 2002
+CONSTANT: AL_CHANNELS HEX: 2003
+CONSTANT: AL_SIZE HEX: 2004
+CONSTANT: AL_UNUSED HEX: 2010
+CONSTANT: AL_PENDING HEX: 2011
+CONSTANT: AL_PROCESSED HEX: 2012
+CONSTANT: AL_NO_ERROR AL_FALSE
+CONSTANT: AL_INVALID_NAME HEX: A001
+CONSTANT: AL_ILLEGAL_ENUM HEX: A002
+CONSTANT: AL_INVALID_ENUM HEX: A002
+CONSTANT: AL_INVALID_VALUE HEX: A003
+CONSTANT: AL_ILLEGAL_COMMAND HEX: A004
+CONSTANT: AL_INVALID_OPERATION HEX: A004
+CONSTANT: AL_OUT_OF_MEMORY HEX: A005
+CONSTANT: AL_VENDOR HEX: B001
+CONSTANT: AL_VERSION HEX: B002
+CONSTANT: AL_RENDERER HEX: B003
+CONSTANT: AL_EXTENSIONS HEX: B004
+CONSTANT: AL_DOPPLER_FACTOR HEX: C000
+CONSTANT: AL_DOPPLER_VELOCITY HEX: C001
+CONSTANT: AL_SPEED_OF_SOUND HEX: C003
+CONSTANT: AL_DISTANCE_MODEL HEX: D000
+CONSTANT: AL_INVERSE_DISTANCE HEX: D001
+CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002
+CONSTANT: AL_LINEAR_DISTANCE HEX: D003
+CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004
+CONSTANT: AL_EXPONENT_DISTANCE HEX: D005
+CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006
+
+FUNCTION: void alEnable ( ALenum capability ) ;
+FUNCTION: void alDisable ( ALenum capability ) ;
+FUNCTION: ALboolean alIsEnabled ( ALenum capability ) ;
+FUNCTION: ALchar* alGetString ( ALenum param ) ;
+FUNCTION: void alGetBooleanv ( ALenum param, ALboolean* data ) ;
+FUNCTION: void alGetIntegerv ( ALenum param, ALint* data ) ;
+FUNCTION: void alGetFloatv ( ALenum param, ALfloat* data ) ;
+FUNCTION: void alGetDoublev ( ALenum param, ALdouble* data ) ;
+FUNCTION: ALboolean alGetBoolean ( ALenum param ) ;
+FUNCTION: ALint alGetInteger ( ALenum param ) ;
+FUNCTION: ALfloat alGetFloat ( ALenum param ) ;
+FUNCTION: ALdouble alGetDouble ( ALenum param ) ;
+FUNCTION: ALenum alGetError ( ) ;
+FUNCTION: ALboolean alIsExtensionPresent ( ALchar* extname ) ;
+FUNCTION: void* alGetProcAddress ( ALchar* fname ) ;
+FUNCTION: ALenum alGetEnumValue ( ALchar* ename ) ;
+FUNCTION: void alListenerf ( ALenum param, ALfloat value ) ;
+FUNCTION: void alListener3f ( ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
+FUNCTION: void alListenerfv ( ALenum param, ALfloat* values ) ;
+FUNCTION: void alListeneri ( ALenum param, ALint value ) ;
+FUNCTION: void alListener3i ( ALenum param, ALint value1, ALint value2, ALint value3 ) ;
+FUNCTION: void alListeneriv ( ALenum param, ALint* values ) ;
+FUNCTION: void alGetListenerf ( ALenum param, ALfloat* value ) ;
+FUNCTION: void alGetListener3f ( ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3 ) ;
+FUNCTION: void alGetListenerfv ( ALenum param, ALfloat* values ) ;
+FUNCTION: void alGetListeneri ( ALenum param, ALint* value ) ;
+FUNCTION: void alGetListener3i ( ALenum param, ALint* value1, ALint* value2, ALint* value3 ) ;
+FUNCTION: void alGetListeneriv ( ALenum param, ALint* values ) ;
+FUNCTION: void alGenSources ( ALsizei n, ALuint* sources ) ;
+FUNCTION: void alDeleteSources ( ALsizei n, ALuint* sources ) ;
+FUNCTION: ALboolean alIsSource ( ALuint sid ) ;
+FUNCTION: void alSourcef ( ALuint sid, ALenum param, ALfloat value ) ;
+FUNCTION: void alSource3f ( ALuint sid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
+FUNCTION: void alSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alSourcei ( ALuint sid, ALenum param, ALint value ) ;
+FUNCTION: void alSource3i ( ALuint sid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
+FUNCTION: void alSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
+FUNCTION: void alGetSourcef ( ALuint sid, ALenum param, ALfloat* value ) ;
+FUNCTION: void alGetSource3f ( ALuint sid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
+FUNCTION: void alGetSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alGetSourcei ( ALuint sid, ALenum param, ALint* value ) ;
+FUNCTION: void alGetSource3i ( ALuint sid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
+FUNCTION: void alGetSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
+FUNCTION: void alSourcePlayv ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourceStopv ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourceRewindv ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourcePausev ( ALsizei ns, ALuint* sids ) ;
+FUNCTION: void alSourcePlay ( ALuint sid ) ;
+FUNCTION: void alSourceStop ( ALuint sid ) ;
+FUNCTION: void alSourceRewind ( ALuint sid ) ;
+FUNCTION: void alSourcePause ( ALuint sid ) ;
+FUNCTION: void alSourceQueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
+FUNCTION: void alSourceUnqueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
+FUNCTION: void alGenBuffers ( ALsizei n, ALuint* buffers ) ;
+FUNCTION: void alDeleteBuffers ( ALsizei n, ALuint* buffers ) ;
+FUNCTION: ALboolean alIsBuffer ( ALuint bid ) ;
+FUNCTION: void alBufferData ( ALuint bid, ALenum format, void* data, ALsizei size, ALsizei freq ) ;
+FUNCTION: void alBufferf ( ALuint bid, ALenum param, ALfloat value ) ;
+FUNCTION: void alBuffer3f ( ALuint bid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
+FUNCTION: void alBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alBufferi ( ALuint bid, ALenum param, ALint value ) ;
+FUNCTION: void alBuffer3i ( ALuint bid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
+FUNCTION: void alBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
+FUNCTION: void alGetBufferf ( ALuint bid, ALenum param, ALfloat* value ) ;
+FUNCTION: void alGetBuffer3f ( ALuint bid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
+FUNCTION: void alGetBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
+FUNCTION: void alGetBufferi ( ALuint bid, ALenum param, ALint* value ) ;
+FUNCTION: void alGetBuffer3i ( ALuint bid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
+FUNCTION: void alGetBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
+FUNCTION: void alDopplerFactor ( ALfloat value ) ;
+FUNCTION: void alDopplerVelocity ( ALfloat value ) ;
+FUNCTION: void alSpeedOfSound ( ALfloat value ) ;
+FUNCTION: void alDistanceModel ( ALenum distanceModel ) ;
+
+LIBRARY: alut
+
+CONSTANT: ALUT_API_MAJOR_VERSION 1
+CONSTANT: ALUT_API_MINOR_VERSION 1
+CONSTANT: ALUT_ERROR_NO_ERROR 0
+CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
+CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
+CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
+CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
+CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
+CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
+CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
+CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
+CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
+CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
+CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
+CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
+CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
+CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
+CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
+CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
+CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
+CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
+CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
+CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
+CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
+CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
+CONSTANT: ALUT_LOADER_BUFFER HEX: 300
+CONSTANT: ALUT_LOADER_MEMORY HEX: 301
+
+FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
+FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
+FUNCTION: ALboolean alutExit ( ) ;
+FUNCTION: ALenum alutGetError ( ) ;
+FUNCTION: char* alutGetErrorString ( ALenum error ) ;
+FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
+FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
+FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
+FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
+FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
+FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
+FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
+FUNCTION: ALint alutGetMajorVersion ( ) ;
+FUNCTION: ALint alutGetMinorVersion ( ) ;
+FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
+
+FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
+
+SYMBOL: init
+
+: init-openal ( -- )
+ init get-global expired? [
+ f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
+ 1337 <alien> init set-global
+ ] when ;
+
+: exit-openal ( -- )
+ init get-global expired? [
+ alutExit 0 = [ "Could not close OpenAL" throw ] when
+ f init set-global
+ ] unless ;
+
+: gen-sources ( size -- seq )
+ dup <uint-array> [ alGenSources ] keep ;
+
+: gen-buffers ( size -- seq )
+ dup <uint-array> [ alGenBuffers ] keep ;
+
+: gen-buffer ( -- buffer ) 1 gen-buffers first ;
+
+: create-buffer-from-file ( filename -- buffer )
+ alutCreateBufferFromFile dup AL_NONE = [
+ "create-buffer-from-file failed" throw
+ ] when ;
+
+os macosx? "openal.macosx" "openal.other" ? require
+
+: create-buffer-from-wav ( filename -- buffer )
+ gen-buffer dup rot load-wav-file
+ [ alBufferData ] 4 nkeep alutUnloadWAV ;
+
+: queue-buffers ( source buffers -- )
+ [ length ] [ >uint-array ] bi alSourceQueueBuffers ;
+
+: queue-buffer ( source buffer -- )
+ 1array queue-buffers ;
+
+: set-source-param ( source param value -- )
+ alSourcei ;
+
+: get-source-param ( source param -- value )
+ 0 <uint> dup [ alGetSourcei ] dip *uint ;
+
+: set-buffer-param ( source param value -- )
+ alBufferi ;
+
+: get-buffer-param ( source param -- value )
+ 0 <uint> dup [ alGetBufferi ] dip *uint ;
+
+: source-play ( source -- ) alSourcePlay ;
+
+: source-stop ( source -- ) alSourceStop ;
+
+: check-error ( -- )
+ alGetError dup ALUT_ERROR_NO_ERROR = [
+ drop
+ ] [
+ alGetString throw
+ ] if ;
+
+: source-playing? ( source -- bool )
+ AL_SOURCE_STATE get-source-param AL_PLAYING = ;
--- /dev/null
+Chris Double
--- /dev/null
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax combinators generalizations
+kernel openal.backend ;
+IN: openal.other
+
+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 ] 4 nkeep
+ { [ *int ] [ *void* ] [ *int ] [ *int ] } spread ;
--- /dev/null
+OpenAL 3D audio library binding
--- /dev/null
+bindings
+audio
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
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 ;
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
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2005 Alex Chapman.
+! See http://factorcode.org/license.txt for BSD license.
+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*
+TYPEDEF: void* GLUtesselator*
+TYPEDEF: void* GLubyte*
+TYPEDEF: void* GLUfuncptr
+
+! StringName
+CONSTANT: GLU_VERSION 100800
+CONSTANT: GLU_EXTENSIONS 100801
+
+! ErrorCode
+CONSTANT: GLU_INVALID_ENUM 100900
+CONSTANT: GLU_INVALID_VALUE 100901
+CONSTANT: GLU_OUT_OF_MEMORY 100902
+CONSTANT: GLU_INCOMPATIBLE_GL_VERSION 100903
+CONSTANT: GLU_INVALID_OPERATION 100904
+
+! NurbsDisplay
+CONSTANT: GLU_OUTLINE_POLYGON 100240
+CONSTANT: GLU_OUTLINE_PATCH 100241
+
+! NurbsCallback
+CONSTANT: GLU_NURBS_ERROR 100103
+CONSTANT: GLU_ERROR 100103
+CONSTANT: GLU_NURBS_BEGIN 100164
+CONSTANT: GLU_NURBS_BEGIN_EXT 100164
+CONSTANT: GLU_NURBS_VERTEX 100165
+CONSTANT: GLU_NURBS_VERTEX_EXT 100165
+CONSTANT: GLU_NURBS_NORMAL 100166
+CONSTANT: GLU_NURBS_NORMAL_EXT 100166
+CONSTANT: GLU_NURBS_COLOR 100167
+CONSTANT: GLU_NURBS_COLOR_EXT 100167
+CONSTANT: GLU_NURBS_TEXTURE_COORD 100168
+CONSTANT: GLU_NURBS_TEX_COORD_EXT 100168
+CONSTANT: GLU_NURBS_END 100169
+CONSTANT: GLU_NURBS_END_EXT 100169
+CONSTANT: GLU_NURBS_BEGIN_DATA 100170
+CONSTANT: GLU_NURBS_BEGIN_DATA_EXT 100170
+CONSTANT: GLU_NURBS_VERTEX_DATA 100171
+CONSTANT: GLU_NURBS_VERTEX_DATA_EXT 100171
+CONSTANT: GLU_NURBS_NORMAL_DATA 100172
+CONSTANT: GLU_NURBS_NORMAL_DATA_EXT 100172
+CONSTANT: GLU_NURBS_COLOR_DATA 100173
+CONSTANT: GLU_NURBS_COLOR_DATA_EXT 100173
+CONSTANT: GLU_NURBS_TEXTURE_COORD_DATA 100174
+CONSTANT: GLU_NURBS_TEX_COORD_DATA_EXT 100174
+CONSTANT: GLU_NURBS_END_DATA 100175
+CONSTANT: GLU_NURBS_END_DATA_EXT 100175
+
+! NurbsError
+CONSTANT: GLU_NURBS_ERROR1 100251
+CONSTANT: GLU_NURBS_ERROR2 100252
+CONSTANT: GLU_NURBS_ERROR3 100253
+CONSTANT: GLU_NURBS_ERROR4 100254
+CONSTANT: GLU_NURBS_ERROR5 100255
+CONSTANT: GLU_NURBS_ERROR6 100256
+CONSTANT: GLU_NURBS_ERROR7 100257
+CONSTANT: GLU_NURBS_ERROR8 100258
+CONSTANT: GLU_NURBS_ERROR9 100259
+CONSTANT: GLU_NURBS_ERROR10 100260
+CONSTANT: GLU_NURBS_ERROR11 100261
+CONSTANT: GLU_NURBS_ERROR12 100262
+CONSTANT: GLU_NURBS_ERROR13 100263
+CONSTANT: GLU_NURBS_ERROR14 100264
+CONSTANT: GLU_NURBS_ERROR15 100265
+CONSTANT: GLU_NURBS_ERROR16 100266
+CONSTANT: GLU_NURBS_ERROR17 100267
+CONSTANT: GLU_NURBS_ERROR18 100268
+CONSTANT: GLU_NURBS_ERROR19 100269
+CONSTANT: GLU_NURBS_ERROR20 100270
+CONSTANT: GLU_NURBS_ERROR21 100271
+CONSTANT: GLU_NURBS_ERROR22 100272
+CONSTANT: GLU_NURBS_ERROR23 100273
+CONSTANT: GLU_NURBS_ERROR24 100274
+CONSTANT: GLU_NURBS_ERROR25 100275
+CONSTANT: GLU_NURBS_ERROR26 100276
+CONSTANT: GLU_NURBS_ERROR27 100277
+CONSTANT: GLU_NURBS_ERROR28 100278
+CONSTANT: GLU_NURBS_ERROR29 100279
+CONSTANT: GLU_NURBS_ERROR30 100280
+CONSTANT: GLU_NURBS_ERROR31 100281
+CONSTANT: GLU_NURBS_ERROR32 100282
+CONSTANT: GLU_NURBS_ERROR33 100283
+CONSTANT: GLU_NURBS_ERROR34 100284
+CONSTANT: GLU_NURBS_ERROR35 100285
+CONSTANT: GLU_NURBS_ERROR36 100286
+CONSTANT: GLU_NURBS_ERROR37 100287
+
+! NurbsProperty
+CONSTANT: GLU_AUTO_LOAD_MATRIX 100200
+CONSTANT: GLU_CULLING 100201
+CONSTANT: GLU_SAMPLING_TOLERANCE 100203
+CONSTANT: GLU_DISPLAY_MODE 100204
+CONSTANT: GLU_PARAMETRIC_TOLERANCE 100202
+CONSTANT: GLU_SAMPLING_METHOD 100205
+CONSTANT: GLU_U_STEP 100206
+CONSTANT: GLU_V_STEP 100207
+CONSTANT: GLU_NURBS_MODE 100160
+CONSTANT: GLU_NURBS_MODE_EXT 100160
+CONSTANT: GLU_NURBS_TESSELLATOR 100161
+CONSTANT: GLU_NURBS_TESSELLATOR_EXT 100161
+CONSTANT: GLU_NURBS_RENDERER 100162
+CONSTANT: GLU_NURBS_RENDERER_EXT 100162
+
+! NurbsSampling
+CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR 100208
+CONSTANT: GLU_OBJECT_PARAMETRIC_ERROR_EXT 100208
+CONSTANT: GLU_OBJECT_PATH_LENGTH 100209
+CONSTANT: GLU_OBJECT_PATH_LENGTH_EXT 100209
+CONSTANT: GLU_PATH_LENGTH 100215
+CONSTANT: GLU_PARAMETRIC_ERROR 100216
+CONSTANT: GLU_DOMAIN_DISTANCE 100217
+
+! NurbsTrim
+CONSTANT: GLU_MAP1_TRIM_2 100210
+CONSTANT: GLU_MAP1_TRIM_3 100211
+
+! QuadricDrawStyle
+CONSTANT: GLU_POINT 100010
+CONSTANT: GLU_LINE 100011
+CONSTANT: GLU_FILL 100012
+CONSTANT: GLU_SILHOUETTE 100013
+
+! QuadricNormal
+CONSTANT: GLU_SMOOTH 100000
+CONSTANT: GLU_FLAT 100001
+CONSTANT: GLU_NONE 100002
+
+! QuadricOrientation
+CONSTANT: GLU_OUTSIDE 100020
+CONSTANT: GLU_INSIDE 100021
+
+! TessCallback
+CONSTANT: GLU_TESS_BEGIN 100100
+CONSTANT: GLU_BEGIN 100100
+CONSTANT: GLU_TESS_VERTEX 100101
+CONSTANT: GLU_VERTEX 100101
+CONSTANT: GLU_TESS_END 100102
+CONSTANT: GLU_END 100102
+CONSTANT: GLU_TESS_ERROR 100103
+CONSTANT: GLU_TESS_EDGE_FLAG 100104
+CONSTANT: GLU_EDGE_FLAG 100104
+CONSTANT: GLU_TESS_COMBINE 100105
+CONSTANT: GLU_TESS_BEGIN_DATA 100106
+CONSTANT: GLU_TESS_VERTEX_DATA 100107
+CONSTANT: GLU_TESS_END_DATA 100108
+CONSTANT: GLU_TESS_ERROR_DATA 100109
+CONSTANT: GLU_TESS_EDGE_FLAG_DATA 100110
+CONSTANT: GLU_TESS_COMBINE_DATA 100111
+
+! TessContour
+CONSTANT: GLU_CW 100120
+CONSTANT: GLU_CCW 100121
+CONSTANT: GLU_INTERIOR 100122
+CONSTANT: GLU_EXTERIOR 100123
+CONSTANT: GLU_UNKNOWN 100124
+
+! TessProperty
+CONSTANT: GLU_TESS_WINDING_RULE 100140
+CONSTANT: GLU_TESS_BOUNDARY_ONLY 100141
+CONSTANT: GLU_TESS_TOLERANCE 100142
+
+! TessError
+CONSTANT: GLU_TESS_ERROR1 100151
+CONSTANT: GLU_TESS_ERROR2 100152
+CONSTANT: GLU_TESS_ERROR3 100153
+CONSTANT: GLU_TESS_ERROR4 100154
+CONSTANT: GLU_TESS_ERROR5 100155
+CONSTANT: GLU_TESS_ERROR6 100156
+CONSTANT: GLU_TESS_ERROR7 100157
+CONSTANT: GLU_TESS_ERROR8 100158
+CONSTANT: GLU_TESS_MISSING_BEGIN_POLYGON 100151
+CONSTANT: GLU_TESS_MISSING_BEGIN_CONTOUR 100152
+CONSTANT: GLU_TESS_MISSING_END_POLYGON 100153
+CONSTANT: GLU_TESS_MISSING_END_CONTOUR 100154
+CONSTANT: GLU_TESS_COORD_TOO_LARGE 100155
+CONSTANT: GLU_TESS_NEED_COMBINE_CALLBACK 100156
+
+! TessWinding
+CONSTANT: GLU_TESS_WINDING_ODD 100130
+CONSTANT: GLU_TESS_WINDING_NONZERO 100131
+CONSTANT: GLU_TESS_WINDING_POSITIVE 100132
+CONSTANT: GLU_TESS_WINDING_NEGATIVE 100133
+CONSTANT: GLU_TESS_WINDING_ABS_GEQ_TWO 100134
+
+LIBRARY: glu
+
+FUNCTION: void gluBeginCurve ( GLUnurbs* nurb ) ;
+FUNCTION: void gluBeginPolygon ( GLUtesselator* tess ) ;
+FUNCTION: void gluBeginSurface ( GLUnurbs* nurb ) ;
+FUNCTION: void gluBeginTrim ( GLUnurbs* nurb ) ;
+
+FUNCTION: void gluCylinder ( GLUquadric* quad, GLdouble base, GLdouble top, GLdouble height, GLint slices, GLint stacks ) ;
+FUNCTION: void gluDeleteNurbsRenderer ( GLUnurbs* nurb ) ;
+FUNCTION: void gluDeleteQuadric ( GLUquadric* quad ) ;
+FUNCTION: void gluDeleteTess ( GLUtesselator* tess ) ;
+FUNCTION: void gluDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops ) ;
+FUNCTION: void gluEndCurve ( GLUnurbs* nurb ) ;
+FUNCTION: void gluEndPolygon ( GLUtesselator* tess ) ;
+FUNCTION: void gluEndSurface ( GLUnurbs* nurb ) ;
+FUNCTION: void gluEndTrim ( GLUnurbs* nurb ) ;
+FUNCTION: char* gluErrorString ( GLenum error ) ;
+FUNCTION: void gluGetNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat* data ) ;
+FUNCTION: char* gluGetString ( GLenum name ) ;
+FUNCTION: void gluGetTessProperty ( GLUtesselator* tess, GLenum which, GLdouble* data ) ;
+FUNCTION: void gluLoadSamplingMatrices ( GLUnurbs* nurb, GLfloat* model, GLfloat* perspective, GLint* view ) ;
+FUNCTION: void gluLookAt ( GLdouble eyeX, GLdouble eyeY, GLdouble eyeZ, GLdouble centerX, GLdouble centerY, GLdouble centerZ, GLdouble upX, GLdouble upY, GLdouble upZ ) ;
+FUNCTION: GLUnurbs* gluNewNurbsRenderer ( ) ;
+FUNCTION: GLUquadric* gluNewQuadric ( ) ;
+FUNCTION: GLUtesselator* gluNewTess ( ) ;
+FUNCTION: void gluNextContour ( GLUtesselator* tess, GLenum type ) ;
+FUNCTION: void gluNurbsCallback ( GLUnurbs* nurb, GLenum which, GLUfuncptr CallBackFunc ) ;
+! FUNCTION: void gluNurbsCallbackData ( GLUnurbs* nurb, GLvoid* userData ) ;
+! FUNCTION: void gluNurbsCallbackDataEXT ( GLUnurbs* nurb, GLvoid* userData ) ;
+FUNCTION: void gluNurbsCurve ( GLUnurbs* nurb, GLint knotCount, GLfloat *knots, GLint stride, GLfloat *control, GLint order, GLenum type ) ;
+FUNCTION: void gluNurbsProperty ( GLUnurbs* nurb, GLenum property, GLfloat value ) ;
+FUNCTION: void gluNurbsSurface ( GLUnurbs* nurb, GLint sKnotCount, GLfloat* sKnots, GLint tKnotCount, GLfloat* tKnots, GLint sStride, GLint tStride, GLfloat* control, GLint sOrder, GLint tOrder, GLenum type ) ;
+FUNCTION: void gluOrtho2D ( GLdouble left, GLdouble right, GLdouble bottom, GLdouble top ) ;
+FUNCTION: void gluPartialDisk ( GLUquadric* quad, GLdouble inner, GLdouble outer, GLint slices, GLint loops, GLdouble start, GLdouble sweep ) ;
+FUNCTION: void gluPerspective ( GLdouble fovy, GLdouble aspect, GLdouble zNear, GLdouble zFar ) ;
+FUNCTION: void gluPickMatrix ( GLdouble x, GLdouble y, GLdouble delX, GLdouble delY, GLint* viewport ) ;
+FUNCTION: GLint gluProject ( GLdouble objX, GLdouble objY, GLdouble objZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* winX, GLdouble* winY, GLdouble* winZ ) ;
+FUNCTION: void gluPwlCurve ( GLUnurbs* nurb, GLint count, GLfloat* data, GLint stride, GLenum type ) ;
+FUNCTION: void gluQuadricCallback ( GLUquadric* quad, GLenum which, GLUfuncptr CallBackFunc ) ;
+FUNCTION: void gluQuadricDrawStyle ( GLUquadric* quad, GLenum draw ) ;
+FUNCTION: void gluQuadricNormals ( GLUquadric* quad, GLenum normal ) ;
+FUNCTION: void gluQuadricOrientation ( GLUquadric* quad, GLenum orientation ) ;
+FUNCTION: void gluQuadricTexture ( GLUquadric* quad, GLboolean texture ) ;
+FUNCTION: GLint gluScaleImage ( GLenum format, GLsizei wIn, GLsizei hIn, GLenum typeIn, void* dataIn, GLsizei wOut, GLsizei hOut, GLenum typeOut, GLvoid* dataOut ) ;
+FUNCTION: void gluSphere ( GLUquadric* quad, GLdouble radius, GLint slices, GLint stacks ) ;
+FUNCTION: void gluTessBeginContour ( GLUtesselator* tess ) ;
+FUNCTION: void gluTessBeginPolygon ( GLUtesselator* tess, GLvoid* data ) ;
+FUNCTION: void gluTessCallback ( GLUtesselator* tess, GLenum which, GLUfuncptr CallBackFunc ) ;
+FUNCTION: void gluTessEndContour ( GLUtesselator* tess ) ;
+FUNCTION: void gluTessEndPolygon ( GLUtesselator* tess ) ;
+FUNCTION: void gluTessNormal ( GLUtesselator* tess, GLdouble valueX, GLdouble valueY, GLdouble valueZ ) ;
+FUNCTION: void gluTessProperty ( GLUtesselator* tess, GLenum which, GLdouble data ) ;
+FUNCTION: void gluTessVertex ( GLUtesselator* tess, GLdouble* location, GLvoid* data ) ;
+FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble* model, GLdouble* proj, GLint* view, GLdouble* objX, GLdouble* objY, GLdouble* objZ ) ;
+
+! Not present on Windows
+! FUNCTION: GLint gluBuild1DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
+! FUNCTION: GLint gluBuild1DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLenum format, GLenum type, void* data ) ;
+! FUNCTION: GLint gluBuild2DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
+! FUNCTION: GLint gluBuild2DMipmaps ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLenum format, GLenum type, void* data ) ;
+! FUNCTION: GLint gluBuild3DMipmapLevels ( GLenum target, GLint internalFormat, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLint level, GLint base, GLint max, void* data ) ;
+! 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
--- /dev/null
+OpenGL binding - libGLU
! 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 -- )
--- /dev/null
+! (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
--- /dev/null
+! (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:) ;
--- /dev/null
+Order-insensitive double dispatch generics
--- /dev/null
+! (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 } } "> }
+}
+;
+
--- /dev/null
+! (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
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: arrays kernel parser sequences ;
+IN: pair-rocket
+
+SYNTAX: => dup pop scan-object 2array parsed ;
+
--- /dev/null
+H{ "foo" => 1 "bar" => 2 } style literal syntax
over empty? [
2drop nil
] [
- quot>> [ unclip-slice dup ] dip call
+ quot>> [ unclip-slice dup ] dip call( char -- ? )
[ swap <parse-results> ] [ 2drop nil ] if
] if ;
: 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
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
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 ;
: 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
-reflection
\ No newline at end of file
+extensions
+reflection
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
accessors multiline sequences math peg.ebnf ;
IN: peg.javascript.parser.tests
-\ javascript must-infer
-
{
T{
ast-begin
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 }
--- /dev/null
+! 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 }
--- /dev/null
+Aaron Schaefer
\ No newline at end of file
--- /dev/null
+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." } ;
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+5-card poker hand evaluator
[ 233168 ] [ euler001a ] unit-test
[ 233168 ] [ euler001b ] unit-test
[ 233168 ] [ euler001c ] unit-test
+[ 233168 ] [ euler001d ] unit-test
! 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
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
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 )
! [ 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
! SOLUTION
! --------
-: nth-prime ( n -- n )
- 1- lprimes lnth ;
-
: euler007 ( -- answer )
10001 nth-prime ;
: euler011 ( -- answer )
[
{ [ horizontal ] [ vertical ] [ diagonal/ ] [ diagonal\ ] }
- [ call 4 max-product , ] each
+ [ call( -- matrix ) 4 max-product , ] each
] { } make supremum ;
! [ euler011 ] 100 ave-time
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>
<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
--- /dev/null
+USING: project-euler.054 tools.test ;
+IN: project-euler.054.tests
+
+[ 376 ] [ euler054 ] unit-test
--- /dev/null
+! 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
--- /dev/null
+8C TS KC 9H 4S 7D 2S 5D 3S AC\r
+5C AD 5D AC 9C 7C 5H 8D TD KS\r
+3H 7H 6S KC JS QH TD JC 2D 8S\r
+TH 8H 5C QS TC 9H 4D JC KS JS\r
+7C 5H KC QH JD AS KH 4C AD 4S\r
+5H KS 9C 7D 9H 8D 3S 5D 5C AH\r
+6H 4H 5C 3H 2H 3S QH 5S 6S AS\r
+TD 8C 4H 7C TC KC 4C 3H 7S KS\r
+7C 9C 6D KD 3H 4C QS QC AC KH\r
+JC 6S 5H 2H 2D KD 9D 7C AS JS\r
+AD QH TH 9D 8H TS 6D 3S AS AC\r
+2H 4S 5C 5S TC KC JD 6C TS 3C\r
+QD AS 6H JS 2C 3D 9H KC 4H 8S\r
+KD 8S 9S 7C 2S 3S 6D 6S 4H KC\r
+3C 8C 2D 7D 4D 9S 4S QH 4H JD\r
+8C KC 7S TC 2D TS 8H QD AC 5C\r
+3D KH QD 6C 6S AD AS 8H 2H QS\r
+6S 8D 4C 8S 6C QH TC 6D 7D 9D\r
+2S 8D 8C 4C TS 9S 9D 9C AC 3D\r
+3C QS 2S 4H JH 3D 2D TD 8S 9H\r
+5H QS 8S 6D 3C 8C JD AS 7H 7D\r
+6H TD 9D AS JH 6C QC 9S KD JC\r
+AH 8S QS 4D TH AC TS 3C 3D 5C\r
+5S 4D JS 3D 8H 6C TS 3S AD 8C\r
+6D 7C 5D 5H 3S 5C JC 2H 5S 3D\r
+5H 6H 2S KS 3D 5D JD 7H JS 8H\r
+KH 4H AS JS QS QC TC 6D 7C KS\r
+3D QS TS 2H JS 4D AS 9S JC KD\r
+QD 5H 4D 5D KH 7H 3D JS KD 4H\r
+2C 9H 6H 5C 9D 6C JC 2D TH 9S\r
+7D 6D AS QD JH 4D JS 7C QS 5C\r
+3H KH QD AD 8C 8H 3S TH 9D 5S\r
+AH 9S 4D 9D 8S 4H JS 3C TC 8D\r
+2C KS 5H QD 3S TS 9H AH AD 8S\r
+5C 7H 5D KD 9H 4D 3D 2D KS AD\r
+KS KC 9S 6D 2C QH 9D 9H TS TC\r
+9C 6H 5D QH 4D AD 6D QC JS KH\r
+9S 3H 9D JD 5C 4D 9H AS TC QH\r
+2C 6D JC 9C 3C AD 9S KH 9D 7D\r
+KC 9C 7C JC JS KD 3H AS 3C 7D\r
+QD KH QS 2C 3S 8S 8H 9H 9C JC\r
+QH 8D 3C KC 4C 4H 6D AD 9H 9D\r
+3S KS QS 7H KH 7D 5H 5D JD AD\r
+2H 2C 6H TH TC 7D 8D 4H 8C AS\r
+4S 2H AC QC 3S 6D TH 4D 4C KH\r
+4D TC KS AS 7C 3C 6D 2D 9H 6C\r
+8C TD 5D QS 2C 7H 4C 9C 3H 9H\r
+5H JH TS 7S TD 6H AD QD 8H 8S\r
+5S AD 9C 8C 7C 8D 5H 9D 8S 2S\r
+4H KH KS 9S 2S KC 5S AD 4S 7D\r
+QS 9C QD 6H JS 5D AC 8D 2S AS\r
+KH AC JC 3S 9D 9S 3C 9C 5S JS\r
+AD 3C 3D KS 3S 5C 9C 8C TS 4S\r
+JH 8D 5D 6H KD QS QD 3D 6C KC\r
+8S JD 6C 3S 8C TC QC 3C QH JS\r
+KC JC 8H 2S 9H 9C JH 8S 8C 9S\r
+8S 2H QH 4D QC 9D KC AS TH 3C\r
+8S 6H TH 7C 2H 6S 3C 3H AS 7S\r
+QH 5S JS 4H 5H TS 8H AH AC JC\r
+9D 8H 2S 4S TC JC 3C 7H 3H 5C\r
+3D AD 3C 3S 4C QC AS 5D TH 8C\r
+6S 9D 4C JS KH AH TS JD 8H AD\r
+4C 6S 9D 7S AC 4D 3D 3S TC JD\r
+AD 7H 6H 4H JH KC TD TS 7D 6S\r
+8H JH TC 3S 8D 8C 9S 2C 5C 4D\r
+2C 9D KC QH TH QS JC 9C 4H TS\r
+QS 3C QD 8H KH 4H 8D TD 8S AC\r
+7C 3C TH 5S 8H 8C 9C JD TC KD\r
+QC TC JD TS 8C 3H 6H KD 7C TD\r
+JH QS KS 9C 6D 6S AS 9H KH 6H\r
+2H 4D AH 2D JH 6H TD 5D 4H JD\r
+KD 8C 9S JH QD JS 2C QS 5C 7C\r
+4S TC 7H 8D 2S 6H 7S 9C 7C KC\r
+8C 5D 7H 4S TD QC 8S JS 4H KS\r
+AD 8S JH 6D TD KD 7C 6C 2D 7D\r
+JC 6H 6S JS 4H QH 9H AH 4C 3C\r
+6H 5H AS 7C 7S 3D KH KC 5D 5C\r
+JC 3D TD AS 4D 6D 6S QH JD KS\r
+8C 7S 8S QH 2S JD 5C 7H AH QD\r
+8S 3C 6H 6C 2C 8D TD 7D 4C 4D\r
+5D QH KH 7C 2S 7H JS 6D QC QD\r
+AD 6C 6S 7D TH 6H 2H 8H KH 4H\r
+KS JS KD 5D 2D KH 7D 9C 8C 3D\r
+9C 6D QD 3C KS 3S 7S AH JD 2D\r
+AH QH AS JC 8S 8H 4C KC TH 7D\r
+JC 5H TD 7C 5D KD 4C AD 8H JS\r
+KC 2H AC AH 7D JH KH 5D 7S 6D\r
+9S 5S 9C 6H 8S TD JD 9H 6C AC\r
+7D 8S 6D TS KD 7H AC 5S 7C 5D\r
+AH QC JC 4C TC 8C 2H TS 2C 7D\r
+KD KC 6S 3D 7D 2S 8S 3H 5S 5C\r
+8S 5D 8H 4C 6H KC 3H 7C 5S KD\r
+JH 8C 3D 3C 6C KC TD 7H 7C 4C\r
+JC KC 6H TS QS TD KS 8H 8C 9S\r
+6C 5S 9C QH 7D AH KS KC 9S 2C\r
+4D 4S 8H TD 9C 3S 7D 9D AS TH\r
+6S 7D 3C 6H 5D KD 2C 5C 9D 9C\r
+2H KC 3D AD 3H QD QS 8D JC 4S\r
+8C 3H 9C 7C AD 5D JC 9D JS AS\r
+5D 9H 5C 7H 6S 6C QC JC QD 9S\r
+JC QS JH 2C 6S 9C QC 3D 4S TC\r
+4H 5S 8D 3D 4D 2S KC 2H JS 2C\r
+TD 3S TH KD 4D 7H JH JS KS AC\r
+7S 8C 9S 2D 8S 7D 5C AD 9D AS\r
+8C 7H 2S 6C TH 3H 4C 3S 8H AC\r
+KD 5H JC 8H JD 2D 4H TD JH 5C\r
+3D AS QH KS 7H JD 8S 5S 6D 5H\r
+9S 6S TC QS JC 5C 5D 9C TH 8C\r
+5H 3S JH 9H 2S 2C 6S 7S AS KS\r
+8C QD JC QS TC QC 4H AC KH 6C\r
+TC 5H 7D JH 4H 2H 8D JC KS 4D\r
+5S 9C KH KD 9H 5C TS 3D 7D 2D\r
+5H AS TC 4D 8C 2C TS 9D 3H 8D\r
+6H 8D 2D 9H JD 6C 4S 5H 5S 6D\r
+AD 9C JC 7D 6H 9S 6D JS 9H 3C\r
+AD JH TC QS 4C 5D 9S 7C 9C AH\r
+KD 6H 2H TH 8S QD KS 9D 9H AS\r
+4H 8H 8D 5H 6C AH 5S AS AD 8S\r
+QS 5D 4S 2H TD KS 5H AC 3H JC\r
+9C 7D QD KD AC 6D 5H QH 6H 5S\r
+KC AH QH 2H 7D QS 3H KS 7S JD\r
+6C 8S 3H 6D KS QD 5D 5C 8H TC\r
+9H 4D 4S 6S 9D KH QC 4H 6C JD\r
+TD 2D QH 4S 6H JH KD 3C QD 8C\r
+4S 6H 7C QD 9D AS AH 6S AD 3C\r
+2C KC TH 6H 8D AH 5C 6D 8S 5D\r
+TD TS 7C AD JC QD 9H 3C KC 7H\r
+5D 4D 5S 8H 4H 7D 3H JD KD 2D\r
+JH TD 6H QS 4S KD 5C 8S 7D 8H\r
+AC 3D AS 8C TD 7H KH 5D 6C JD\r
+9D KS 7C 6D QH TC JD KD AS KC\r
+JH 8S 5S 7S 7D AS 2D 3D AD 2H\r
+2H 5D AS 3C QD KC 6H 9H 9S 2C\r
+9D 5D TH 4C JH 3H 8D TC 8H 9H\r
+6H KD 2C TD 2H 6C 9D 2D JS 8C\r
+KD 7S 3C 7C AS QH TS AD 8C 2S\r
+QS 8H 6C JS 4C 9S QC AD TD TS\r
+2H 7C TS TC 8C 3C 9H 2D 6D JC\r
+TC 2H 8D JH KS 6D 3H TD TH 8H\r
+9D TD 9H QC 5D 6C 8H 8C KC TS\r
+2H 8C 3D AH 4D TH TC 7D 8H KC\r
+TS 5C 2D 8C 6S KH AH 5H 6H KC\r
+5S 5D AH TC 4C JD 8D 6H 8C 6C\r
+KC QD 3D 8H 2D JC 9H 4H AD 2S\r
+TD 6S 7D JS KD 4H QS 2S 3S 8C\r
+4C 9H JH TS 3S 4H QC 5S 9S 9C\r
+2C KD 9H JS 9S 3H JC TS 5D AC\r
+AS 2H 5D AD 5H JC 7S TD JS 4C\r
+2D 4S 8H 3D 7D 2C AD KD 9C TS\r
+7H QD JH 5H JS AC 3D TH 4C 8H\r
+6D KH KC QD 5C AD 7C 2D 4H AC\r
+3D 9D TC 8S QD 2C JC 4H JD AH\r
+6C TD 5S TC 8S AH 2C 5D AS AC\r
+TH 7S 3D AS 6C 4C 7H 7D 4H AH\r
+5C 2H KS 6H 7S 4H 5H 3D 3C 7H\r
+3C 9S AC 7S QH 2H 3D 6S 3S 3H\r
+2D 3H AS 2C 6H TC JS 6S 9C 6C\r
+QH KD QD 6D AC 6H KH 2C TS 8C\r
+8H 7D 3S 9H 5D 3H 4S QC 9S 5H\r
+2D 9D 7H 6H 3C 8S 5H 4D 3S 4S\r
+KD 9S 4S TC 7S QC 3S 8S 2H 7H\r
+TC 3D 8C 3H 6C 2H 6H KS KD 4D\r
+KC 3D 9S 3H JS 4S 8H 2D 6C 8S\r
+6H QS 6C TC QD 9H 7D 7C 5H 4D\r
+TD 9D 8D 6S 6C TC 5D TS JS 8H\r
+4H KC JD 9H TC 2C 6S 5H 8H AS\r
+JS 9C 5C 6S 9D JD 8H KC 4C 6D\r
+4D 8D 8S 6C 7C 6H 7H 8H 5C KC\r
+TC 3D JC 6D KS 9S 6H 7S 9C 2C\r
+6C 3S KD 5H TS 7D 9H 9S 6H KH\r
+3D QD 4C 6H TS AC 3S 5C 2H KD\r
+4C AS JS 9S 7C TS 7H 9H JC KS\r
+4H 8C JD 3H 6H AD 9S 4S 5S KS\r
+4C 2C 7D 3D AS 9C 2S QS KC 6C\r
+8S 5H 3D 2S AC 9D 6S 3S 4D TD\r
+QD TH 7S TS 3D AC 7H 6C 5D QC\r
+TC QD AD 9C QS 5C 8D KD 3D 3C\r
+9D 8H AS 3S 7C 8S JD 2D 8D KC\r
+4C TH AC QH JS 8D 7D 7S 9C KH\r
+9D 8D 4C JH 2C 2S QD KD TS 4H\r
+4D 6D 5D 2D JH 3S 8S 3H TC KH\r
+AD 4D 2C QS 8C KD JH JD AH 5C\r
+5C 6C 5H 2H JH 4H KS 7C TC 3H\r
+3C 4C QC 5D JH 9C QD KH 8D TC\r
+3H 9C JS 7H QH AS 7C 9H 5H JC\r
+2D 5S QD 4S 3C KC 6S 6C 5C 4C\r
+5D KH 2D TS 8S 9C AS 9S 7C 4C\r
+7C AH 8C 8D 5S KD QH QS JH 2C\r
+8C 9D AH 2H AC QC 5S 8H 7H 2C\r
+QD 9H 5S QS QC 9C 5H JC TH 4H\r
+6C 6S 3H 5H 3S 6H KS 8D AC 7S\r
+AC QH 7H 8C 4S KC 6C 3D 3S TC\r
+9D 3D JS TH AC 5H 3H 8S 3S TC\r
+QD KH JS KS 9S QC 8D AH 3C AC\r
+5H 6C KH 3S 9S JH 2D QD AS 8C\r
+6C 4D 7S 7H 5S JC 6S 9H 4H JH\r
+AH 5S 6H 9S AD 3S TH 2H 9D 8C\r
+4C 8D 9H 7C QC AD 4S 9C KC 5S\r
+9D 6H 4D TC 4C JH 2S 5D 3S AS\r
+2H 6C 7C KH 5C AD QS TH JD 8S\r
+3S 4S 7S AH AS KC JS 2S AD TH\r
+JS KC 2S 7D 8C 5C 9C TS 5H 9D\r
+7S 9S 4D TD JH JS KH 6H 5D 2C\r
+JD JS JC TH 2D 3D QD 8C AC 5H\r
+7S KH 5S 9D 5D TD 4S 6H 3C 2D\r
+4S 5D AC 8D 4D 7C AD AS AH 9C\r
+6S TH TS KS 2C QC AH AS 3C 4S\r
+2H 8C 3S JC 5C 7C 3H 3C KH JH\r
+7S 3H JC 5S 6H 4C 2S 4D KC 7H\r
+4D 7C 4H 9S 8S 6S AD TC 6C JC\r
+KH QS 3S TC 4C 8H 8S AC 3C TS\r
+QD QS TH 3C TS 7H 7D AH TD JC\r
+TD JD QC 4D 9S 7S TS AD 7D AC\r
+AH 7H 4S 6D 7C 2H 9D KS JC TD\r
+7C AH JD 4H 6D QS TS 2H 2C 5C\r
+TC KC 8C 9S 4C JS 3C JC 6S AH\r
+AS 7D QC 3D 5S JC JD 9D TD KH\r
+TH 3C 2S 6H AH AC 5H 5C 7S 8H\r
+QC 2D AC QD 2S 3S JD QS 6S 8H\r
+KC 4H 3C 9D JS 6H 3S 8S AS 8C\r
+7H KC 7D JD 2H JC QH 5S 3H QS\r
+9H TD 3S 8H 7S AC 5C 6C AH 7C\r
+8D 9H AH JD TD QS 7D 3S 9C 8S\r
+AH QH 3C JD KC 4S 5S 5D TD KS\r
+9H 7H 6S JH TH 4C 7C AD 5C 2D\r
+7C KD 5S TC 9D 6S 6C 5D 2S TH\r
+KC 9H 8D 5H 7H 4H QC 3D 7C AS\r
+6S 8S QC TD 4S 5C TH QS QD 2S\r
+8S 5H TH QC 9H 6S KC 7D 7C 5C\r
+7H KD AH 4D KH 5C 4S 2D KC QH\r
+6S 2C TD JC AS 4D 6C 8C 4H 5S\r
+JC TC JD 5S 6S 8D AS 9D AD 3S\r
+6D 6H 5D 5S TC 3D 7D QS 9D QD\r
+4S 6C 8S 3S 7S AD KS 2D 7D 7C\r
+KC QH JC AC QD 5D 8D QS 7H 7D\r
+JS AH 8S 5H 3D TD 3H 4S 6C JH\r
+4S QS 7D AS 9H JS KS 6D TC 5C\r
+2D 5C 6H TC 4D QH 3D 9H 8S 6C\r
+6D 7H TC TH 5S JD 5C 9C KS KD\r
+8D TD QH 6S 4S 6C 8S KC 5C TC\r
+5S 3D KS AC 4S 7D QD 4C TH 2S\r
+TS 8H 9S 6S 7S QH 3C AH 7H 8C\r
+4C 8C TS JS QC 3D 7D 5D 7S JH\r
+8S 7S 9D QC AC 7C 6D 2H JH KC\r
+JS KD 3C 6S 4S 7C AH QC KS 5H\r
+KS 6S 4H JD QS TC 8H KC 6H AS\r
+KH 7C TC 6S TD JC 5C 7D AH 3S\r
+3H 4C 4H TC TH 6S 7H 6D 9C QH\r
+7D 5H 4S 8C JS 4D 3D 8S QH KC\r
+3H 6S AD 7H 3S QC 8S 4S 7S JS\r
+3S JD KH TH 6H QS 9C 6C 2D QD\r
+4S QH 4D 5H KC 7D 6D 8D TH 5S\r
+TD AD 6S 7H KD KH 9H 5S KC JC\r
+3H QC AS TS 4S QD KS 9C 7S KC\r
+TS 6S QC 6C TH TC 9D 5C 5D KD\r
+JS 3S 4H KD 4C QD 6D 9S JC 9D\r
+8S JS 6D 4H JH 6H 6S 6C KS KH\r
+AC 7D 5D TC 9S KH 6S QD 6H AS\r
+AS 7H 6D QH 8D TH 2S KH 5C 5H\r
+4C 7C 3D QC TC 4S KH 8C 2D JS\r
+6H 5D 7S 5H 9C 9H JH 8S TH 7H\r
+AS JS 2S QD KH 8H 4S AC 8D 8S\r
+3H 4C TD KD 8C JC 5C QS 2D JD\r
+TS 7D 5D 6C 2C QS 2H 3C AH KS\r
+4S 7C 9C 7D JH 6C 5C 8H 9D QD\r
+2S TD 7S 6D 9C 9S QS KH QH 5C\r
+JC 6S 9C QH JH 8D 7S JS KH 2H\r
+8D 5H TH KC 4D 4S 3S 6S 3D QS\r
+2D JD 4C TD 7C 6D TH 7S JC AH\r
+QS 7S 4C TH 9D TS AD 4D 3H 6H\r
+2D 3H 7D JD 3D AS 2S 9C QC 8S\r
+4H 9H 9C 2C 7S JH KD 5C 5D 6H\r
+TC 9H 8H JC 3C 9S 8D KS AD KC\r
+TS 5H JD QS QH QC 8D 5D KH AH\r
+5D AS 8S 6S 4C AH QC QD TH 7H\r
+3H 4H 7D 6S 4S 9H AS 8H JS 9D\r
+JD 8C 2C 9D 7D 5H 5S 9S JC KD\r
+KD 9C 4S QD AH 7C AD 9D AC TD\r
+6S 4H 4S 9C 8D KS TC 9D JH 7C\r
+5S JC 5H 4S QH AC 2C JS 2S 9S\r
+8C 5H AS QD AD 5C 7D 8S QC TD\r
+JC 4C 8D 5C KH QS 4D 6H 2H 2C\r
+TH 4S 2D KC 3H QD AC 7H AD 9D\r
+KH QD AS 8H TH KC 8D 7S QH 8C\r
+JC 6C 7D 8C KH AD QS 2H 6S 2D\r
+JC KH 2D 7D JS QC 5H 4C 5D AD\r
+TS 3S AD 4S TD 2D TH 6S 9H JH\r
+9H 2D QS 2C 4S 3D KH AS AC 9D\r
+KH 6S 8H 4S KD 7D 9D TS QD QC\r
+JH 5H AH KS AS AD JC QC 5S KH\r
+5D 7D 6D KS KD 3D 7C 4D JD 3S\r
+AC JS 8D 5H 9C 3H 4H 4D TS 2C\r
+6H KS KH 9D 7C 2S 6S 8S 2H 3D\r
+6H AC JS 7S 3S TD 8H 3H 4H TH\r
+9H TC QC KC 5C KS 6H 4H AC 8S\r
+TC 7D QH 4S JC TS 6D 6C AC KH\r
+QH 7D 7C JH QS QD TH 3H 5D KS\r
+3D 5S 8D JS 4C 2C KS 7H 9C 4H\r
+5H 8S 4H TD 2C 3S QD QC 3H KC\r
+QC JS KD 9C AD 5S 9D 7D 7H TS\r
+8C JC KH 7C 7S 6C TS 2C QD TH\r
+5S 9D TH 3C 7S QH 8S 9C 2H 5H\r
+5D 9H 6H 2S JS KH 3H 7C 2H 5S\r
+JD 5D 5S 2C TC 2S 6S 6C 3C 8S\r
+4D KH 8H 4H 2D KS 3H 5C 2S 9H\r
+3S 2D TD 7H 8S 6H JD KC 9C 8D\r
+6S QD JH 7C 9H 5H 8S 8H TH TD\r
+QS 7S TD 7D TS JC KD 7C 3C 2C\r
+3C JD 8S 4H 2D 2S TD AS 4D AC\r
+AH KS 6C 4C 4S 7D 8C 9H 6H AS\r
+5S 3C 9S 2C QS KD 4D 4S AC 5D\r
+2D TS 2C JS KH QH 5D 8C AS KC\r
+KD 3H 6C TH 8S 7S KH 6H 9S AC\r
+6H 7S 6C QS AH 2S 2H 4H 5D 5H\r
+5H JC QD 2C 2S JD AS QC 6S 7D\r
+6C TC AS KD 8H 9D 2C 7D JH 9S\r
+2H 4C 6C AH 8S TD 3H TH 7C TS\r
+KD 4S TS 6C QH 8D 9D 9C AH 7D\r
+6D JS 5C QD QC 9C 5D 8C 2H KD\r
+3C QH JH AD 6S AH KC 8S 6D 6H\r
+3D 7C 4C 7S 5S 3S 6S 5H JC 3C\r
+QH 7C 5H 3C 3S 8C TS 4C KD 9C\r
+QD 3S 7S 5H 7H QH JC 7C 8C KD\r
+3C KD KH 2S 4C TS AC 6S 2C 7C\r
+2C KH 3C 4C 6H 4D 5H 5S 7S QD\r
+4D 7C 8S QD TS 9D KS 6H KD 3C\r
+QS 4D TS 7S 4C 3H QD 8D 9S TC\r
+TS QH AC 6S 3C 9H 9D QS 8S 6H\r
+3S 7S 5D 4S JS 2D 6C QH 6S TH\r
+4C 4H AS JS 5D 3D TS 9C AC 8S\r
+6S 9C 7C 3S 5C QS AD AS 6H 3C\r
+9S 8C 7H 3H 6S 7C AS 9H JD KH\r
+3D 3H 7S 4D 6C 7C AC 2H 9C TH\r
+4H 5S 3H AC TC TH 9C 9H 9S 8D\r
+8D 9H 5H 4D 6C 2H QD 6S 5D 3S\r
+4C 5C JD QS 4D 3H TH AC QH 8C\r
+QC 5S 3C 7H AD 4C KS 4H JD 6D\r
+QS AH 3H KS 9H 2S JS JH 5H 2H\r
+2H 5S TH 6S TS 3S KS 3C 5H JS\r
+2D 9S 7H 3D KC JH 6D 7D JS TD\r
+AC JS 8H 2C 8C JH JC 2D TH 7S\r
+5D 9S 8H 2H 3D TC AH JC KD 9C\r
+9D QD JC 2H 6D KH TS 9S QH TH\r
+2C 8D 4S JD 5H 3H TH TC 9C KC\r
+AS 3D 9H 7D 4D TH KH 2H 7S 3H\r
+4H 7S KS 2S JS TS 8S 2H QD 8D\r
+5S 6H JH KS 8H 2S QC AC 6S 3S\r
+JC AS AD QS 8H 6C KH 4C 4D QD\r
+2S 3D TS TD 9S KS 6S QS 5C 8D\r
+3C 6D 4S QC KC JH QD TH KH AD\r
+9H AH 4D KS 2S 8D JH JC 7C QS\r
+2D 6C TH 3C 8H QD QH 2S 3S KS\r
+6H 5D 9S 4C TS TD JS QD 9D JD\r
+5H 8H KH 8S KS 7C TD AD 4S KD\r
+2C 7C JC 5S AS 6C 7D 8S 5H 9C\r
+6S QD 9S TS KH QS 5S QH 3C KC\r
+7D 3H 3C KD 5C AS JH 7H 6H JD\r
+9D 5C 9H KC 8H KS 4S AD 4D 2S\r
+3S JD QD 8D 2S 7C 5S 6S 5H TS\r
+6D 9S KC TD 3S 6H QD JD 5C 8D\r
+5H 9D TS KD 8D 6H TD QC 4C 7D\r
+6D 4S JD 9D AH 9S AS TD 9H QD\r
+2D 5S 2H 9C 6H 9S TD QC 7D TC\r
+3S 2H KS TS 2C 9C 8S JS 9D 7D\r
+3C KC 6D 5D 6C 6H 8S AS 7S QS\r
+JH 9S 2H 8D 4C 8H 9H AD TH KH\r
+QC AS 2S JS 5C 6H KD 3H 7H 2C\r
+QD 8H 2S 8D 3S 6D AH 2C TC 5C\r
+JD JS TS 8S 3H 5D TD KC JC 6H\r
+6S QS TC 3H 5D AH JC 7C 7D 4H\r
+7C 5D 8H 9C 2H 9H JH KH 5S 2C\r
+9C 7H 6S TH 3S QC QD 4C AC JD\r
+2H 5D 9S 7D KC 3S QS 2D AS KH\r
+2S 4S 2H 7D 5C TD TH QH 9S 4D\r
+6D 3S TS 6H 4H KS 9D 8H 5S 2D\r
+9H KS 4H 3S 5C 5D KH 6H 6S JS\r
+KC AS 8C 4C JC KH QC TH QD AH\r
+6S KH 9S 2C 5H TC 3C 7H JC 4D\r
+JD 4S 6S 5S 8D 7H 7S 4D 4C 2H\r
+7H 9H 5D KH 9C 7C TS TC 7S 5H\r
+4C 8D QC TS 4S 9H 3D AD JS 7C\r
+8C QS 5C 5D 3H JS AH KC 4S 9D\r
+TS JD 8S QS TH JH KH 2D QD JS\r
+JD QC 5D 6S 9H 3S 2C 8H 9S TS\r
+2S 4C AD 7H JC 5C 2D 6D 4H 3D\r
+7S JS 2C 4H 8C AD QD 9C 3S TD\r
+JD TS 4C 6H 9H 7D QD 6D 3C AS\r
+AS 7C 4C 6S 5D 5S 5C JS QC 4S\r
+KD 6S 9S 7C 3C 5S 7D JH QD JS\r
+4S 7S JH 2C 8S 5D 7H 3D QH AD\r
+TD 6H 2H 8D 4H 2D 7C AD KH 5D\r
+TS 3S 5H 2C QD AH 2S 5C KH TD\r
+KC 4D 8C 5D AS 6C 2H 2S 9H 7C\r
+KD JS QC TS QS KH JH 2C 5D AD\r
+3S 5H KC 6C 9H 3H 2H AD 7D 7S\r
+7S JS JH KD 8S 7D 2S 9H 7C 2H\r
+9H 2D 8D QC 6S AD AS 8H 5H 6C\r
+2S 7H 6C 6D 7D 8C 5D 9D JC 3C\r
+7C 9C 7H JD 2H KD 3S KH AD 4S\r
+QH AS 9H 4D JD KS KD TS KH 5H\r
+4C 8H 5S 3S 3D 7D TD AD 7S KC\r
+JS 8S 5S JC 8H TH 9C 4D 5D KC\r
+7C 5S 9C QD 2C QH JS 5H 8D KH\r
+TD 2S KS 3D AD KC 7S TC 3C 5D\r
+4C 2S AD QS 6C 9S QD TH QH 5C\r
+8C AD QS 2D 2S KC JD KS 6C JC\r
+8D 4D JS 2H 5D QD 7S 7D QH TS\r
+6S 7H 3S 8C 8S 9D QS 8H 6C 9S\r
+4S TC 2S 5C QD 4D QS 6D TH 6S\r
+3S 5C 9D 6H 8D 4C 7D TC 7C TD\r
+AH 6S AS 7H 5S KD 3H 5H AC 4C\r
+8D 8S AH KS QS 2C AD 6H 7D 5D\r
+6H 9H 9S 2H QS 8S 9C 5D 2D KD\r
+TS QC 5S JH 7D 7S TH 9S 9H AC\r
+7H 3H 6S KC 4D 6D 5C 4S QD TS\r
+TD 2S 7C QD 3H JH 9D 4H 7S 7H\r
+KS 3D 4H 5H TC 2S AS 2D 6D 7D\r
+8H 3C 7H TD 3H AD KC TH 9C KH\r
+TC 4C 2C 9S 9D 9C 5C 2H JD 3C\r
+3H AC TS 5D AD 8D 6H QC 6S 8C\r
+2S TS 3S JD 7H 8S QH 4C 5S 8D\r
+AC 4S 6C 3C KH 3D 7C 2D 8S 2H\r
+4H 6C 8S TH 2H 4S 8H 9S 3H 7S\r
+7C 4C 9C 2C 5C AS 5D KD 4D QH\r
+9H 4H TS AS 7D 8D 5D 9S 8C 2H\r
+QC KD AC AD 2H 7S AS 3S 2D 9S\r
+2H QC 8H TC 6D QD QS 5D KH 3C\r
+TH JD QS 4C 2S 5S AD 7H 3S AS\r
+7H JS 3D 6C 3S 6D AS 9S AC QS\r
+9C TS AS 8C TC 8S 6H 9D 8D 6C\r
+4D JD 9C KC 7C 6D KS 3S 8C AS\r
+3H 6S TC 8D TS 3S KC 9S 7C AS\r
+8C QC 4H 4S 8S 6C 3S TC AH AC\r
+4D 7D 5C AS 2H 6S TS QC AD TC\r
+QD QC 8S 4S TH 3D AH TS JH 4H\r
+5C 2D 9S 2C 3H 3C 9D QD QH 7D\r
+KC 9H 6C KD 7S 3C 4D AS TC 2D\r
+3D JS 4D 9D KS 7D TH QC 3H 3C\r
+8D 5S 2H 9D 3H 8C 4C 4H 3C TH\r
+JC TH 4S 6S JD 2D 4D 6C 3D 4C\r
+TS 3S 2D 4H AC 2C 6S 2H JH 6H\r
+TD 8S AD TC AH AC JH 9S 6S 7S\r
+6C KC 4S JD 8D 9H 5S 7H QH AH\r
+KD 8D TS JH 5C 5H 3H AD AS JS\r
+2D 4H 3D 6C 8C 7S AD 5D 5C 8S\r
+TD 5D 7S 9C 4S 5H 6C 8C 4C 8S\r
+JS QH 9C AS 5C QS JC 3D QC 7C\r
+JC 9C KH JH QS QC 2C TS 3D AD\r
+5D JH AC 5C 9S TS 4C JD 8C KS\r
+KC AS 2D KH 9H 2C 5S 4D 3D 6H\r
+TH AH 2D 8S JC 3D 8C QH 7S 3S\r
+8H QD 4H JC AS KH KS 3C 9S 6D\r
+9S QH 7D 9C 4S AC 7H KH 4D KD\r
+AH AD TH 6D 9C 9S KD KS QH 4H\r
+QD 6H 9C 7C QS 6D 6S 9D 5S JH\r
+AH 8D 5H QD 2H JC KS 4H KH 5S\r
+5C 2S JS 8D 9C 8C 3D AS KC AH\r
+JD 9S 2H QS 8H 5S 8C TH 5C 4C\r
+QC QS 8C 2S 2C 3S 9C 4C KS KH\r
+2D 5D 8S AH AD TD 2C JS KS 8C\r
+TC 5S 5H 8H QC 9H 6H JD 4H 9S\r
+3C JH 4H 9H AH 4S 2H 4C 8D AC\r
+8S TH 4D 7D 6D QD QS 7S TC 7C\r
+KH 6D 2D JD 5H JS QD JH 4H 4S\r
+9C 7S JH 4S 3S TS QC 8C TC 4H\r
+QH 9D 4D JH QS 3S 2C 7C 6C 2D\r
+4H 9S JD 5C 5H AH 9D TS 2D 4C\r
+KS JH TS 5D 2D AH JS 7H AS 8D\r
+JS AH 8C AD KS 5S 8H 2C 6C TH\r
+2H 5D AD AC KS 3D 8H TS 6H QC\r
+6D 4H TS 9C 5H JS JH 6S JD 4C\r
+JH QH 4H 2C 6D 3C 5D 4C QS KC\r
+6H 4H 6C 7H 6S 2S 8S KH QC 8C\r
+3H 3D 5D KS 4H TD AD 3S 4D TS\r
+5S 7C 8S 7D 2C KS 7S 6C 8C JS\r
+5D 2H 3S 7C 5C QD 5H 6D 9C 9H\r
+JS 2S KD 9S 8D TD TS AC 8C 9D\r
+5H QD 2S AC 8C 9H KS 7C 4S 3C\r
+KH AS 3H 8S 9C JS QS 4S AD 4D\r
+AS 2S TD AD 4D 9H JC 4C 5H QS\r
+5D 7C 4H TC 2D 6C JS 4S KC 3S\r
+4C 2C 5D AC 9H 3D JD 8S QS QH\r
+2C 8S 6H 3C QH 6D TC KD AC AH\r
+QC 6C 3S QS 4S AC 8D 5C AD KH\r
+5S 4C AC KH AS QC 2C 5C 8D 9C\r
+8H JD 3C KH 8D 5C 9C QD QH 9D\r
+7H TS 2C 8C 4S TD JC 9C 5H QH\r
+JS 4S 2C 7C TH 6C AS KS 7S JD\r
+JH 7C 9H 7H TC 5H 3D 6D 5D 4D\r
+2C QD JH 2H 9D 5S 3D TD AD KS\r
+JD QH 3S 4D TH 7D 6S QS KS 4H\r
+TC KS 5S 8D 8H AD 2S 2D 4C JH\r
+5S JH TC 3S 2D QS 9D 4C KD 9S\r
+AC KH 3H AS 9D KC 9H QD 6C 6S\r
+9H 7S 3D 5C 7D KC TD 8H 4H 6S\r
+3C 7H 8H TC QD 4D 7S 6S QH 6C\r
+6D AD 4C QD 6C 5D 7D 9D KS TS\r
+JH 2H JD 9S 7S TS KH 8D 5D 8H\r
+2D 9S 4C 7D 9D 5H QD 6D AC 6S\r
+7S 6D JC QD JH 4C 6S QS 2H 7D\r
+8C TD JH KD 2H 5C QS 2C JS 7S\r
+TC 5H 4H JH QD 3S 5S 5D 8S KH\r
+KS KH 7C 2C 5D JH 6S 9C 6D JC\r
+5H AH JD 9C JS KC 2H 6H 4D 5S\r
+AS 3C TH QC 6H 9C 8S 8C TD 7C\r
+KC 2C QD 9C KH 4D 7S 3C TS 9H\r
+9C QC 2S TS 8C TD 9S QD 3S 3C\r
+4D 9D TH JH AH 6S 2S JD QH JS\r
+QD 9H 6C KD 7D 7H 5D 6S 8H AH\r
+8H 3C 4S 2H 5H QS QH 7S 4H AC\r
+QS 3C 7S 9S 4H 3S AH KS 9D 7C\r
+AD 5S 6S 2H 2D 5H TC 4S 3C 8C\r
+QH TS 6S 4D JS KS JH AS 8S 6D\r
+2C 8S 2S TD 5H AS TC TS 6C KC\r
+KC TS 8H 2H 3H 7C 4C 5S TH TD\r
+KD AD KH 7H 7S 5D 5H 5S 2D 9C\r
+AD 9S 3D 7S 8C QC 7C 9C KD KS\r
+3C QC 9S 8C 4D 5C AS QD 6C 2C\r
+2H KC 8S JD 7S AC 8D 5C 2S 4D\r
+9D QH 3D 2S TC 3S KS 3C 9H TD\r
+KD 6S AC 2C 7H 5H 3S 6C 6H 8C\r
+QH TC 8S 6S KH TH 4H 5D TS 4D\r
+8C JS 4H 6H 2C 2H 7D AC QD 3D\r
+QS KC 6S 2D 5S 4H TD 3H JH 4C\r
+7S 5H 7H 8H KH 6H QS TH KD 7D\r
+5H AD KD 7C KH 5S TD 6D 3C 6C\r
+8C 9C 5H JD 7C KC KH 7H 2H 3S\r
+7S 4H AD 4D 8S QS TH 3D 7H 5S\r
+8D TC KS KD 9S 6D AD JD 5C 2S\r
+7H 8H 6C QD 2H 6H 9D TC 9S 7C\r
+8D 6D 4C 7C 6C 3C TH KH JS JH\r
+5S 3S 8S JS 9H AS AD 8H 7S KD\r
+JH 7C 2C KC 5H AS AD 9C 9S JS\r
+AD AC 2C 6S QD 7C 3H TH KS KD\r
+9D JD 4H 8H 4C KH 7S TS 8C KC\r
+3S 5S 2H 7S 6H 7D KS 5C 6D AD\r
+5S 8C 9H QS 7H 7S 2H 6C 7D TD\r
+QS 5S TD AC 9D KC 3D TC 2D 4D\r
+TD 2H 7D JD QD 4C 7H 5D KC 3D\r
+4C 3H 8S KD QH 5S QC 9H TC 5H\r
+9C QD TH 5H TS 5C 9H AH QH 2C\r
+4D 6S 3C AC 6C 3D 2C 2H TD TH\r
+AC 9C 5D QC 4D AD 8D 6D 8C KC\r
+AD 3C 4H AC 8D 8H 7S 9S TD JC\r
+4H 9H QH JS 2D TH TD TC KD KS\r
+5S 6S 9S 8D TH AS KH 5H 5C 8S\r
+JD 2S 9S 6S 5S 8S 5D 7S 7H 9D\r
+5D 8C 4C 9D AD TS 2C 7D KD TC\r
+8S QS 4D KC 5C 8D 4S KH JD KD\r
+AS 5C AD QH 7D 2H 9S 7H 7C TC\r
+2S 8S JD KH 7S 6C 6D AD 5D QC\r
+9H 6H 3S 8C 8H AH TC 4H JS TD\r
+2C TS 4D 7H 2D QC 9C 5D TH 7C\r
+6C 8H QC 5D TS JH 5C 5H 9H 4S\r
+2D QC 7H AS JS 8S 2H 4C 4H 8D\r
+JS 6S AC KD 3D 3C 4S 7H TH KC\r
+QH KH 6S QS 5S 4H 3C QD 3S 3H\r
+7H AS KH 8C 4H 9C 5S 3D 6S TS\r
+9C 7C 3H 5S QD 2C 3D AD AC 5H\r
+JH TD 2D 4C TS 3H KH AD 3S 7S\r
+AS 4C 5H 4D 6S KD JC 3C 6H 2D\r
+3H 6S 8C 2D TH 4S AH QH AD 5H\r
+7C 2S 9H 7H KC 5C 6D 5S 3H JC\r
+3C TC 9C 4H QD TD JH 6D 9H 5S\r
+7C 6S 5C 5D 6C 4S 7H 9H 6H AH\r
+AD 2H 7D KC 2C 4C 2S 9S 7H 3S\r
+TH 4C 8S 6S 3S AD KS AS JH TD\r
+5C TD 4S 4D AD 6S 5D TC 9C 7D\r
+8H 3S 4D 4S 5S 6H 5C AC 3H 3D\r
+9H 3C AC 4S QS 8S 9D QH 5H 4D\r
+JC 6C 5H TS AC 9C JD 8C 7C QD\r
+8S 8H 9C JD 2D QC QH 6H 3C 8D\r
+KS JS 2H 6H 5H QH QS 3H 7C 6D\r
+TC 3H 4S 7H QC 2H 3S 8C JS KH\r
+AH 8H 5S 4C 9H JD 3H 7S JC AC\r
+3C 2D 4C 5S 6C 4S QS 3S JD 3D\r
+5H 2D TC AH KS 6D 7H AD 8C 6H\r
+6C 7S 3C JD 7C 8H KS KH AH 6D\r
+AH 7D 3H 8H 8S 7H QS 5H 9D 2D\r
+JD AC 4H 7S 8S 9S KS AS 9D QH\r
+7S 2C 8S 5S JH QS JC AH KD 4C\r
+AH 2S 9H 4H 8D TS TD 6H QH JD\r
+4H JC 3H QS 6D 7S 9C 8S 9D 8D\r
+5H TD 4S 9S 4C 8C 8D 7H 3H 3D\r
+QS KH 3S 2C 2S 3C 7S TD 4S QD\r
+7C TD 4D 5S KH AC AS 7H 4C 6C\r
+2S 5H 6D JD 9H QS 8S 2C 2H TD\r
+2S TS 6H 9H 7S 4H JC 4C 5D 5S\r
+2C 5H 7D 4H 3S QH JC JS 6D 8H\r
+4C QH 7C QD 3S AD TH 8S 5S TS\r
+9H TC 2S TD JC 7D 3S 3D TH QH\r
+7D 4C 8S 5C JH 8H 6S 3S KC 3H\r
+JC 3H KH TC QH TH 6H 2C AC 5H\r
+QS 2H 9D 2C AS 6S 6C 2S 8C 8S\r
+9H 7D QC TH 4H KD QS AC 7S 3C\r
+4D JH 6S 5S 8H KS 9S QC 3S AS\r
+JD 2D 6S 7S TC 9H KC 3H 7D KD\r
+2H KH 7C 4D 4S 3H JS QD 7D KC\r
+4C JC AS 9D 3C JS 6C 8H QD 4D\r
+AH JS 3S 6C 4C 3D JH 6D 9C 9H\r
+9H 2D 8C 7H 5S KS 6H 9C 2S TC\r
+6C 8C AD 7H 6H 3D KH AS 5D TH\r
+KS 8C 3S TS 8S 4D 5S 9S 6C 4H\r
+9H 4S 4H 5C 7D KC 2D 2H 9D JH\r
+5C JS TC 9D 9H 5H 7S KH JC 6S\r
+7C 9H 8H 4D JC KH JD 2H TD TC\r
+8H 6C 2H 2C KH 6H 9D QS QH 5H\r
+AC 7D 2S 3D QD JC 2D 8D JD JH\r
+2H JC 2D 7H 2C 3C 8D KD TD 4H\r
+3S 4H 6D 8D TS 3H TD 3D 6H TH\r
+JH JC 3S AC QH 9H 7H 8S QC 2C\r
+7H TD QS 4S 8S 9C 2S 5D 4D 2H\r
+3D TS 3H 2S QC 8H 6H KC JC KS\r
+5D JD 7D TC 8C 6C 9S 3D 8D AC\r
+8H 6H JH 6C 5D 8D 8S 4H AD 2C\r
+9D 4H 2D 2C 3S TS AS TC 3C 5D\r
+4D TH 5H KS QS 6C 4S 2H 3D AD\r
+5C KC 6H 2C 5S 3C 4D 2D 9H 9S\r
+JD 4C 3H TH QH 9H 5S AH 8S AC\r
+7D 9S 6S 2H TD 9C 4H 8H QS 4C\r
+3C 6H 5D 4H 8C 9C KC 6S QD QS\r
+3S 9H KD TC 2D JS 8C 6S 4H 4S\r
+2S 4C 8S QS 6H KH 3H TH 8C 5D\r
+2C KH 5S 3S 7S 7H 6C 9D QD 8D\r
+8H KS AC 2D KH TS 6C JS KC 7H\r
+9C KS 5C TD QC AH 6C 5H 9S 7C\r
+5D 4D 3H 4H 6S 7C 7S AH QD TD\r
+2H 7D QC 6S TC TS AH 7S 9D 3H\r
+TH 5H QD 9S KS 7S 7C 6H 8C TD\r
+TH 2D 4D QC 5C 7D JD AH 9C 4H\r
+4H 3H AH 8D 6H QC QH 9H 2H 2C\r
+2D AD 4C TS 6H 7S TH 4H QS TD\r
+3C KD 2H 3H QS JD TC QC 5D 8H\r
+KS JC QD TH 9S KD 8D 8C 2D 9C\r
+3C QD KD 6D 4D 8D AH AD QC 8S\r
+8H 3S 9D 2S 3H KS 6H 4C 7C KC\r
+TH 9S 5C 3D 7D 6H AC 7S 4D 2C\r
+5C 3D JD 4D 2D 6D 5H 9H 4C KH\r
+AS 7H TD 6C 2H 3D QD KS 4C 4S\r
+JC 3C AC 7C JD JS 8H 9S QC 5D\r
+JD 6S 5S 2H AS 8C 7D 5H JH 3D\r
+8D TC 5S 9S 8S 3H JC 5H 7S AS\r
+5C TD 3D 7D 4H 8D 7H 4D 5D JS\r
+QS 9C KS TD 2S 8S 5C 2H 4H AS\r
+TH 7S 4H 7D 3H JD KD 5D 2S KC\r
+JD 7H 4S 8H 4C JS 6H QH 5S 4H\r
+2C QS 8C 5S 3H QC 2S 6C QD AD\r
+8C 3D JD TC 4H 2H AD 5S AC 2S\r
+5D 2C JS 2D AD 9D 3D 4C 4S JH\r
+8D 5H 5D 6H 7S 4D KS 9D TD JD\r
+3D 6D 9C 2S AS 7D 5S 5C 8H JD\r
+7C 8S 3S 6S 5H JD TC AD 7H 7S\r
+2S 9D TS 4D AC 8D 6C QD JD 3H\r
+9S KH 2C 3C AC 3D 5H 6H 8D 5D\r
+KS 3D 2D 6S AS 4C 2S 7C 7H KH\r
+AC 2H 3S JC 5C QH 4D 2D 5H 7S\r
+TS AS JD 8C 6H JC 8S 5S 2C 5D\r
+7S QH 7H 6C QC 8H 2D 7C JD 2S\r
+2C QD 2S 2H JC 9C 5D 2D JD JH\r
+7C 5C 9C 8S 7D 6D 8D 6C 9S JH\r
+2C AD 6S 5H 3S KS 7S 9D KH 4C\r
+7H 6C 2C 5C TH 9D 8D 3S QC AH\r
+5S KC 6H TC 5H 8S TH 6D 3C AH\r
+9C KD 4H AD TD 9S 4S 7D 6H 5D\r
+7H 5C 5H 6D AS 4C KD KH 4H 9D\r
+3C 2S 5C 6C JD QS 2H 9D 7D 3H\r
+AC 2S 6S 7S JS QD 5C QS 6H AD\r
+5H TH QC 7H TC 3S 7C 6D KC 3D\r
+4H 3D QC 9S 8H 2C 3S JC KS 5C\r
+4S 6S 2C 6H 8S 3S 3D 9H 3H JS\r
+4S 8C 4D 2D 8H 9H 7D 9D AH TS\r
+9S 2C 9H 4C 8D AS 7D 3D 6D 5S\r
+6S 4C 7H 8C 3H 5H JC AH 9D 9C\r
+2S 7C 5S JD 8C 3S 3D 4D 7D 6S\r
+3C KC 4S 5D 7D 3D JD 7H 3H 4H\r
+9C 9H 4H 4D TH 6D QD 8S 9S 7S\r
+2H AC 8S 4S AD 8C 2C AH 7D TC\r
+TS 9H 3C AD KS TC 3D 8C 8H JD\r
+QC 8D 2C 3C 7D 7C JD 9H 9C 6C\r
+AH 6S JS JH 5D AS QC 2C JD TD\r
+9H KD 2H 5D 2D 3S 7D TC AH TS\r
+TD 8H AS 5D AH QC AC 6S TC 5H\r
+KS 4S 7H 4D 8D 9C TC 2H 6H 3H\r
+3H KD 4S QD QH 3D 8H 8C TD 7S\r
+8S JD TC AH JS QS 2D KH KS 4D\r
+3C AD JC KD JS KH 4S TH 9H 2C\r
+QC 5S JS 9S KS AS 7C QD 2S JD\r
+KC 5S QS 3S 2D AC 5D 9H 8H KS\r
+6H 9C TC AD 2C 6D 5S JD 6C 7C\r
+QS KH TD QD 2C 3H 8S 2S QC AH\r
+9D 9H JH TC QH 3C 2S JS 5C 7H\r
+6C 3S 3D 2S 4S QD 2D TH 5D 2C\r
+2D 6H 6D 2S JC QH AS 7H 4H KH\r
+5H 6S KS AD TC TS 7C AC 4S 4H\r
+AD 3C 4H QS 8C 9D KS 2H 2D 4D\r
+4S 9D 6C 6D 9C AC 8D 3H 7H KD\r
+JC AH 6C TS JD 6D AD 3S 5D QD\r
+JC JH JD 3S 7S 8S JS QC 3H 4S\r
+JD TH 5C 2C AD JS 7H 9S 2H 7S\r
+8D 3S JH 4D QC AS JD 2C KC 6H\r
+2C AC 5H KD 5S 7H QD JH AH 2D\r
+JC QH 8D 8S TC 5H 5C AH 8C 6C\r
+3H JS 8S QD JH 3C 4H 6D 5C 3S\r
+6D 4S 4C AH 5H 5S 3H JD 7C 8D\r
+8H AH 2H 3H JS 3C 7D QC 4H KD\r
+6S 2H KD 5H 8H 2D 3C 8S 7S QD\r
+2S 7S KC QC AH TC QS 6D 4C 8D\r
+5S 9H 2C 3S QD 7S 6C 2H 7C 9D\r
+3C 6C 5C 5S JD JC KS 3S 5D TS\r
+7C KS 6S 5S 2S 2D TC 2H 5H QS\r
+AS 7H 6S TS 5H 9S 9D 3C KD 2H\r
+4S JS QS 3S 4H 7C 2S AC 6S 9D\r
+8C JH 2H 5H 7C 5D QH QS KH QC\r
+3S TD 3H 7C KC 8D 5H 8S KH 8C\r
+4H KH JD TS 3C 7H AS QC JS 5S\r
+AH 9D 2C 8D 4D 2D 6H 6C KC 6S\r
+2S 6H 9D 3S 7H 4D KH 8H KD 3D\r
+9C TC AC JH KH 4D JD 5H TD 3S\r
+7S 4H 9D AS 4C 7D QS 9S 2S KH\r
+3S 8D 8S KS 8C JC 5C KH 2H 5D\r
+8S QH 2C 4D KC JS QC 9D AC 6H\r
+8S 8C 7C JS JD 6S 4C 9C AC 4S\r
+QH 5D 2C 7D JC 8S 2D JS JH 4C\r
+JS 4C 7S TS JH KC KH 5H QD 4S\r
+QD 8C 8D 2D 6S TD 9D AC QH 5S\r
+QH QC JS 3D 3C 5C 4H KH 8S 7H\r
+7C 2C 5S JC 8S 3H QC 5D 2H KC\r
+5S 8D KD 6H 4H QD QH 6D AH 3D\r
+7S KS 6C 2S 4D AC QS 5H TS JD\r
+7C 2D TC 5D QS AC JS QC 6C KC\r
+2C KS 4D 3H TS 8S AD 4H 7S 9S\r
+QD 9H QH 5H 4H 4D KH 3S JC AD\r
+4D AC KC 8D 6D 4C 2D KH 2C JD\r
+2C 9H 2D AH 3H 6D 9C 7D TC KS\r
+8C 3H KD 7C 5C 2S 4S 5H AS AH\r
+TH JD 4H KD 3H TC 5C 3S AC KH\r
+6D 7H AH 7S QC 6H 2D TD JD AS\r
+JH 5D 7H TC 9S 7D JC AS 5S KH\r
+2H 8C AD TH 6H QD KD 9H 6S 6C\r
+QH KC 9D 4D 3S JS JH 4H 2C 9H\r
+TC 7H KH 4H JC 7D 9S 3H QS 7S\r
+AD 7D JH 6C 7H 4H 3S 3H 4D QH\r
+JD 2H 5C AS 6C QC 4D 3C TC JH\r
+AC JD 3H 6H 4C JC AD 7D 7H 9H\r
+4H TC TS 2C 8C 6S KS 2H JD 9S\r
+4C 3H QS QC 9S 9H 6D KC 9D 9C\r
+5C AD 8C 2C QH TH QD JC 8D 8H\r
+QC 2C 2S QD 9C 4D 3S 8D JH QS\r
+9D 3S 2C 7S 7C JC TD 3C TC 9H\r
+3C TS 8H 5C 4C 2C 6S 8D 7C 4H\r
+KS 7H 2H TC 4H 2C 3S AS AH QS\r
+8C 2D 2H 2C 4S 4C 6S 7D 5S 3S\r
+TH QC 5D TD 3C QS KD KC KS AS\r
+4D AH KD 9H KS 5C 4C 6H JC 7S\r
+KC 4H 5C QS TC 2H JC 9S AH QH\r
+4S 9H 3H 5H 3C QD 2H QC JH 8H\r
+5D AS 7H 2C 3D JH 6H 4C 6S 7D\r
+9C JD 9H AH JS 8S QH 3H KS 8H\r
+3S AC QC TS 4D AD 3D AH 8S 9H\r
+7H 3H QS 9C 9S 5H JH JS AH AC\r
+8D 3C JD 2H AC 9C 7H 5S 4D 8H\r
+7C JH 9H 6C JS 9S 7H 8C 9D 4H\r
+2D AS 9S 6H 4D JS JH 9H AD QD\r
+6H 7S JH KH AH 7H TD 5S 6S 2C\r
+8H JH 6S 5H 5S 9D TC 4C QC 9S\r
+7D 2C KD 3H 5H AS QD 7H JS 4D\r
+TS QH 6C 8H TH 5H 3C 3H 9C 9D\r
+AD KH JS 5D 3H AS AC 9S 5C KC\r
+2C KH 8C JC QS 6D AH 2D KC TC\r
+9D 3H 2S 7C 4D 6D KH KS 8D 7D\r
+9H 2S TC JH AC QC 3H 5S 3S 8H\r
+3S AS KD 8H 4C 3H 7C JH QH TS\r
+7S 6D 7H 9D JH 4C 3D 3S 6C AS\r
+4S 2H 2C 4C 8S 5H KC 8C QC QD\r
+3H 3S 6C QS QC 2D 6S 5D 2C 9D\r
+2H 8D JH 2S 3H 2D 6C 5C 7S AD\r
+9H JS 5D QH 8S TS 2H 7S 6S AD\r
+6D QC 9S 7H 5H 5C 7D KC JD 4H\r
+QC 5S 9H 9C 4D 6S KS 2S 4C 7C\r
+9H 7C 4H 8D 3S 6H 5C 8H JS 7S\r
+2D 6H JS TD 4H 4D JC TH 5H KC\r
+AC 7C 8D TH 3H 9S 2D 4C KC 4D\r
+KD QS 9C 7S 3D KS AD TS 4C 4H\r
+QH 9C 8H 2S 7D KS 7H 5D KD 4C\r
+9C 2S 2H JC 6S 6C TC QC JH 5C\r
+7S AC 8H KC 8S 6H QS JC 3D 6S\r
+JS 2D JH 8C 4S 6H 8H 6D 5D AD\r
+6H 7D 2S 4H 9H 7C AS AC 8H 5S\r
+3C JS 4S 6D 5H 2S QH 6S 9C 2C\r
+3D 5S 6S 9S 4C QS 8D QD 8S TC\r
+9C 3D AH 9H 5S 2C 7D AD JC 3S\r
+7H TC AS 3C 6S 6D 7S KH KC 9H\r
+3S TC 8H 6S 5H JH 8C 7D AC 2S\r
+QD 9D 9C 3S JC 8C KS 8H 5D 4D\r
+JS AH JD 6D 9D 8C 9H 9S 8H 3H\r
+2D 6S 4C 4D 8S AD 4S TC AH 9H\r
+TS AC QC TH KC 6D 4H 7S 8C 2H\r
+3C QD JS 9D 5S JC AH 2H TS 9H\r
+3H 4D QH 5D 9C 5H 7D 4S JC 3S\r
+8S TH 3H 7C 2H JD JS TS AC 8D\r
+9C 2H TD KC JD 2S 8C 5S AD 2C\r
+3D KD 7C 5H 4D QH QD TC 6H 7D\r
+7H 2C KC 5S KD 6H AH QC 7S QH\r
+6H 5C AC 5H 2C 9C 2D 7C TD 2S\r
+4D 9D AH 3D 7C JD 4H 8C 4C KS\r
+TH 3C JS QH 8H 4C AS 3D QS QC\r
+4D 7S 5H JH 6D 7D 6H JS KH 3C\r
+QD 8S 7D 2H 2C 7C JC 2S 5H 8C\r
+QH 8S 9D TC 2H AD 7C 8D QD 6S\r
+3S 7C AD 9H 2H 9S JD TS 4C 2D\r
+3S AS 4H QC 2C 8H 8S 7S TD TC\r
+JH TH TD 3S 4D 4H 5S 5D QS 2C\r
+8C QD QH TC 6D 4S 9S 9D 4H QC\r
+8C JS 9D 6H JD 3H AD 6S TD QC\r
+KC 8S 3D 7C TD 7D 8D 9H 4S 3S\r
+6C 4S 3D 9D KD TC KC KS AC 5S\r
+7C 6S QH 3D JS KD 6H 6D 2D 8C\r
+JD 2S 5S 4H 8S AC 2D 6S TS 5C\r
+5H 8C 5S 3C 4S 3D 7C 8D AS 3H\r
+AS TS 7C 3H AD 7D JC QS 6C 6H\r
+3S 9S 4C AC QH 5H 5D 9H TS 4H\r
+6C 5C 7H 7S TD AD JD 5S 2H 2S\r
+7D 6C KC 3S JD 8D 8S TS QS KH\r
+8S QS 8D 6C TH AC AH 2C 8H 9S\r
+7H TD KH QH 8S 3D 4D AH JD AS\r
+TS 3D 2H JC 2S JH KH 6C QC JS\r
+KC TH 2D 6H 7S 2S TC 8C 9D QS\r
+3C 9D 6S KH 8H 6D 5D TH 2C 2H\r
+6H TC 7D AD 4D 8S TS 9H TD 7S\r
+JS 6D JD JC 2H AC 6C 3D KH 8D\r
+KH JD 9S 5D 4H 4C 3H 7S QS 5C\r
+4H JD 5D 3S 3C 4D KH QH QS 7S\r
+JD TS 8S QD AH 4C 6H 3S 5S 2C\r
+QS 3D JD AS 8D TH 7C 6S QC KS\r
+7S 2H 8C QC 7H AC 6D 2D TH KH\r
+5S 6C 7H KH 7D AH 8C 5C 7S 3D\r
+3C KD AD 7D 6C 4D KS 2D 8C 4S\r
+7C 8D 5S 2D 2S AH AD 2C 9D TD\r
+3C AD 4S KS JH 7C 5C 8C 9C TH\r
+AS TD 4D 7C JD 8C QH 3C 5H 9S\r
+3H 9C 8S 9S 6S QD KS AH 5H JH\r
+QC 9C 5S 4H 2H TD 7D AS 8C 9D\r
+8C 2C 9D KD TC 7S 3D KH QC 3C\r
+4D AS 4C QS 5S 9D 6S JD QH KS\r
+6D AH 6C 4C 5H TS 9H 7D 3D 5S\r
+QS JD 7C 8D 9C AC 3S 6S 6C KH\r
+8H JH 5D 9S 6D AS 6S 3S QC 7H\r
+QD AD 5C JH 2H AH 4H AS KC 2C\r
+JH 9C 2C 6H 2D JS 5D 9H KC 6D\r
+7D 9D KD TH 3H AS 6S QC 6H AD\r
+JD 4H 7D KC 3H JS 3C TH 3D QS\r
+4C 3H 8C QD 5H 6H AS 8H AD JD\r
+TH 8S KD 5D QC 7D JS 5S 5H TS\r
+7D KC 9D QS 3H 3C 6D TS 7S AH\r
+7C 4H 7H AH QC AC 4D 5D 6D TH\r
+3C 4H 2S KD 8H 5H JH TC 6C JD\r
+4S 8C 3D 4H JS TD 7S JH QS KD\r
+7C QC KD 4D 7H 6S AD TD TC KH\r
+5H 9H KC 3H 4D 3D AD 6S QD 6H\r
+TH 7C 6H TS QH 5S 2C KC TD 6S\r
+7C 4D 5S JD JH 7D AC KD KH 4H\r
+7D 6C 8D 8H 5C JH 8S QD TH JD\r
+8D 7D 6C 7C 9D KD AS 5C QH JH\r
+9S 2C 8C 3C 4C KS JH 2D 8D 4H\r
+7S 6C JH KH 8H 3H 9D 2D AH 6D\r
+4D TC 9C 8D 7H TD KS TH KD 3C\r
+JD 9H 8D QD AS KD 9D 2C 2S 9C\r
+8D 3H 5C 7H KS 5H QH 2D 8C 9H\r
+2D TH 6D QD 6C KC 3H 3S AD 4C\r
+4H 3H JS 9D 3C TC 5H QH QC JC\r
+3D 5C 6H 3S 3C JC 5S 7S 2S QH\r
+AC 5C 8C 4D 5D 4H 2S QD 3C 3H\r
+2C TD AH 9C KD JS 6S QD 4C QC\r
+QS 8C 3S 4H TC JS 3H 7C JC AD\r
+5H 4D 9C KS JC TD 9S TS 8S 9H\r
+QD TS 7D AS AC 2C TD 6H 8H AH\r
+6S AD 8C 4S 9H 8D 9D KH 8S 3C\r
+QS 4D 2D 7S KH JS JC AD 4C 3C\r
+QS 9S 7H KC TD TH 5H JS AC JH\r
+6D AC 2S QS 7C AS KS 6S KH 5S\r
+6D 8H KH 3C QS 2H 5C 9C 9D 6C\r
+JS 2C 4C 6H 7D JC AC QD TD 3H\r
+4H QC 8H JD 4C KD KS 5C KC 7S\r
+6D 2D 3H 2S QD 5S 7H AS TH 6S\r
+AS 6D 8D 2C 8S TD 8H QD JC AH\r
+9C 9H 2D TD QH 2H 5C TC 3D 8H\r
+KC 8S 3D KH 2S TS TC 6S 4D JH\r
+9H 9D QS AC KC 6H 5D 4D 8D AH\r
+9S 5C QS 4H 7C 7D 2H 8S AD JS\r
+3D AC 9S AS 2C 2D 2H 3H JC KH\r
+7H QH KH JD TC KS 5S 8H 4C 8D\r
+2H 7H 3S 2S 5H QS 3C AS 9H KD\r
+AD 3D JD 6H 5S 9C 6D AC 9S 3S\r
+3D 5D 9C 2D AC 4S 2S AD 6C 6S\r
+QC 4C 2D 3H 6S KC QH QD 2H JH\r
+QC 3C 8S 4D 9S 2H 5C 8H QS QD\r
+6D KD 6S 7H 3S KH 2H 5C JC 6C\r
+3S 9S TC 6S 8H 2D AD 7S 8S TS\r
+3C 6H 9C 3H 5C JC 8H QH TD QD\r
+3C JS QD 5D TD 2C KH 9H TH AS\r
+9S TC JD 3D 5C 5H AD QH 9H KC\r
+TC 7H 4H 8H 3H TD 6S AC 7C 2S\r
+QS 9D 5D 3C JC KS 4D 6C JH 2S\r
+9S 6S 3C 7H TS 4C KD 6D 3D 9C\r
+2D 9H AH AC 7H 2S JH 3S 7C QC\r
+QD 9H 3C 2H AC AS 8S KD 8C KH\r
+2D 7S TD TH 6D JD 8D 4D 2H 5S\r
+8S QH KD JD QS JH 4D KC 5H 3S\r
+3C KH QC 6D 8H 3S AH 7D TD 2D\r
+5S 9H QH 4S 6S 6C 6D TS TH 7S\r
+6C 4C 6D QS JS 9C TS 3H 8D 8S\r
+JS 5C 7S AS 2C AH 2H AD 5S TC\r
+KD 6C 9C 9D TS 2S JC 4H 2C QD\r
+QS 9H TC 3H KC KS 4H 3C AD TH\r
+KH 9C 2H KD 9D TC 7S KC JH 2D\r
+7C 3S KC AS 8C 5D 9C 9S QH 3H\r
+2D 8C TD 4C 2H QC 5D TC 2C 7D\r
+KS 4D 6C QH TD KH 5D 7C AD 8D\r
+2S 9S 8S 4C 8C 3D 6H QD 7C 7H\r
+6C 8S QH 5H TS 5C 3C 4S 2S 2H\r
+8S 6S 2H JC 3S 3H 9D 8C 2S 7H\r
+QC 2C 8H 9C AC JD 4C 4H 6S 3S\r
+3H 3S 7D 4C 9S 5H 8H JC 3D TC\r
+QH 2S 2D 9S KD QD 9H AD 6D 9C\r
+8D 2D KS 9S JC 4C JD KC 4S TH\r
+KH TS 6D 4D 5C KD 5H AS 9H AD\r
+QD JS 7C 6D 5D 5C TH 5H QH QS\r
+9D QH KH 5H JH 4C 4D TC TH 6C\r
+KH AS TS 9D KD 9C 7S 4D 8H 5S\r
+KH AS 2S 7D 9D 4C TS TH AH 7C\r
+KS 4D AC 8S 9S 8D TH QH 9D 5C\r
+5D 5C 8C QS TC 4C 3D 3S 2C 8D\r
+9D KS 2D 3C KC 4S 8C KH 6C JC\r
+8H AH 6H 7D 7S QD 3C 4C 6C KC\r
+3H 2C QH 8H AS 7D 4C 8C 4H KC\r
+QD 5S 4H 2C TD AH JH QH 4C 8S\r
+3H QS 5S JS 8H 2S 9H 9C 3S 2C\r
+6H TS 7S JC QD AC TD KC 5S 3H\r
+QH AS QS 7D JC KC 2C 4C 5C 5S\r
+QH 3D AS JS 4H 8D 7H JC 2S 9C\r
+5D 4D 2S 4S 9D 9C 2D QS 8H 7H\r
+6D 7H 3H JS TS AC 2D JH 7C 8S\r
+JH 5H KC 3C TC 5S 9H 4C 8H 9D\r
+8S KC 5H 9H AD KS 9D KH 8D AH\r
+JC 2H 9H KS 6S 3H QC 5H AH 9C\r
+5C KH 5S AD 6C JC 9H QC 9C TD\r
+5S 5D JC QH 2D KS 8H QS 2H TS\r
+JH 5H 5S AH 7H 3C 8S AS TD KH\r
+6H 3D JD 2C 4C KC 7S AH 6C JH\r
+4C KS 9D AD 7S KC 7D 8H 3S 9C\r
+7H 5C 5H 3C 8H QC 3D KH 6D JC\r
+2D 4H 5D 7D QC AD AH 9H QH 8H\r
+KD 8C JS 9D 3S 3C 2H 5D 6D 2S\r
+8S 6S TS 3C 6H 8D 5S 3H TD 6C\r
+KS 3D JH 9C 7C 9S QS 5S 4H 6H\r
+7S 6S TH 4S KC KD 3S JC JH KS\r
+7C 3C 2S 6D QH 2C 7S 5H 8H AH\r
+KC 8D QD 6D KH 5C 7H 9D 3D 9C\r
+6H 2D 8S JS 9S 2S 6D KC 7C TC\r
+KD 9C JH 7H KC 8S 2S 7S 3D 6H\r
+4H 9H 2D 4C 8H 7H 5S 8S 2H 8D\r
+AD 7C 3C 7S 5S 4D 9H 3D JC KH\r
+5D AS 7D 6D 9C JC 4C QH QS KH\r
+KD JD 7D 3D QS QC 8S 6D JS QD\r
+6S 8C 5S QH TH 9H AS AC 2C JD\r
+QC KS QH 7S 3C 4C 5C KC 5D AH\r
+6C 4H 9D AH 2C 3H KD 3D TS 5C\r
+TD 8S QS AS JS 3H KD AC 4H KS\r
+7D 5D TS 9H 4H 4C 9C 2H 8C QC\r
+2C 7D 9H 4D KS 4C QH AD KD JS\r
+QD AD AH KH 9D JS 9H JC KD JD\r
+8S 3C 4S TS 7S 4D 5C 2S 6H 7C\r
+JS 7S 5C KD 6D QH 8S TD 2H 6S\r
+QH 6C TC 6H TD 4C 9D 2H QC 8H\r
+3D TS 4D 2H 6H 6S 2C 7H 8S 6C\r
+9H 9D JD JH 3S AH 2C 6S 3H 8S\r
+2C QS 8C 5S 3H 2S 7D 3C AD 4S\r
+5C QC QH AS TS 4S 6S 4C 5H JS\r
+JH 5C TD 4C 6H JS KD KH QS 4H\r
+TC KH JC 4D 9H 9D 8D KC 3C 8H\r
+2H TC 8S AD 9S 4H TS 7H 2C 5C\r
+4H 2S 6C 5S KS AH 9C 7C 8H KD\r
+TS QH TD QS 3C JH AH 2C 8D 7D\r
+5D KC 3H 5S AC 4S 7H QS 4C 2H\r
+3D 7D QC KH JH 6D 6C TD TH KD\r
+5S 8D TH 6C 9D 7D KH 8C 9S 6D\r
+JD QS 7S QC 2S QH JC 4S KS 8D\r
+7S 5S 9S JD KD 9C JC AD 2D 7C\r
+4S 5H AH JH 9C 5D TD 7C 2D 6S\r
+KC 6C 7H 6S 9C QD 5S 4H KS TD\r
+6S 8D KS 2D TH TD 9H JD TS 3S\r
+KH JS 4H 5D 9D TC TD QC JD TS\r
+QS QD AC AD 4C 6S 2D AS 3H KC\r
+4C 7C 3C TD QS 9C KC AS 8D AD\r
+KC 7H QC 6D 8H 6S 5S AH 7S 8C\r
+3S AD 9H JC 6D JD AS KH 6S JH\r
+AD 3D TS KS 7H JH 2D JS QD AC\r
+9C JD 7C 6D TC 6H 6C JC 3D 3S\r
+QC KC 3S JC KD 2C 8D AH QS TS\r
+AS KD 3D JD 8H 7C 8C 5C QD 6C\r
--- /dev/null
+USING: project-euler.058 tools.test ;
+
+{ 26241 } [ euler058 ] unit-test
--- /dev/null
+! 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
--- /dev/null
+USING: project-euler.063 tools.test ;
+
+{ 49 } [ euler063 ] unit-test
--- /dev/null
+! 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
--- /dev/null
+USING: project-euler.069 tools.test ;
+
+{ 510510 } [ euler069 ] unit-test
+{ 510510 } [ euler069a ] unit-test
--- /dev/null
+! 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
! 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 ;
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 -
-! 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
! 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
: number-length ( n -- m )
log10 floor 1+ >integer ;
+: nth-prime ( n -- n )
+ 1- lprimes lnth ;
+
: nth-triangle ( n -- n )
dup 1+ * 2 / ;
: 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 )
-! 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
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
--- /dev/null
+! (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" } "> }
+} ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: qw tools.test ;
+IN: qw.tests
+
+[ { "zippity" "doo" "dah" } ] [ qw{ zippity doo dah } ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: lexer parser ;
+IN: qw
+
+SYNTAX: qw{ "}" parse-tokens parsed ;
--- /dev/null
+Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar })
! 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
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 ;
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 {
[ 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 )
[ <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> ;
--- /dev/null
+! (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." } ;
+
--- /dev/null
+! (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
--- /dev/null
+! (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 ;
+
+
--- /dev/null
+Mixins for tuples
--- /dev/null
+Maxim Savchenko
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
--- /dev/null
+Basic sandboxing
--- /dev/null
+! 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: ;
--- /dev/null
+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
--- /dev/null
+! 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 ;
--- /dev/null
+! (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"
-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
--- /dev/null
+! (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
+
--- /dev/null
+Cartesian products of sequences
+++ /dev/null
-
-USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
- newfx ;
-
-IN: shell.parser
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-TUPLE: basic-expr command stdin stdout background ;
-TUPLE: pipeline-expr commands stdin stdout background ;
-TUPLE: single-quoted-expr expr ;
-TUPLE: double-quoted-expr expr ;
-TUPLE: back-quoted-expr expr ;
-TUPLE: glob-expr expr ;
-TUPLE: variable-expr expr ;
-TUPLE: factor-expr expr ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
-
-: ast>pipeline-expr ( ast -- obj )
- pipeline-expr new
- over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
- over 2nd >>stdin
- over 6th >>stdout
- swap 7th >>background ;
-
-: ast>single-quoted-expr ( ast -- obj )
- 2nd >string single-quoted-expr boa ;
-
-: ast>double-quoted-expr ( ast -- obj )
- 2nd >string double-quoted-expr boa ;
-
-: ast>back-quoted-expr ( ast -- obj )
- 2nd >string back-quoted-expr boa ;
-
-: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
-
-: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
-
-: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-EBNF: expr
-
-space = " "
-
-tab = "\t"
-
-white = (space | tab)
-
-_ = (white)* => [[ drop ignore ]]
-
-sq = "'"
-dq = '"'
-bq = "`"
-
-single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]]
-double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]]
-back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]]
-
-factor = "$(" (!(")") .)* ")" => [[ ast>factor-expr ]]
-
-variable = "$" other => [[ ast>variable-expr ]]
-
-glob-char = ("*" | "?")
-
-non-glob-char = !(glob-char | white) .
-
-glob-beginning-string = (non-glob-char)* => [[ >string ]]
-
-glob-rest-string = (non-glob-char)+ => [[ >string ]]
-
-glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]]
-
-other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]]
-
-element = (single-quoted | double-quoted | back-quoted | factor | variable | glob | other)
-
-command = (element _)+
-
-to-file = ">" _ other => [[ second ]]
-in-file = "<" _ other => [[ second ]]
-ap-file = ">>" _ other => [[ second ]]
-
-basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]]
-
-pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]]
-
-submission = (pipeline | basic)
-
-;EBNF
\ No newline at end of file
+++ /dev/null
-USING: kernel parser words continuations namespaces debugger
-sequences combinators splitting prettyprint system io io.files
-io.pathnames io.launcher io.directories io.encodings.utf8 io.pipes
-sequences.deep accessors multi-methods newfx shell.parser
-combinators.short-circuit eval environment ;
-IN: shell
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: cd ( args -- )
- dup empty?
- [ drop home set-current-directory ]
- [ first set-current-directory ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pwd ( args -- )
- drop
- current-directory get
- print ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: swords ( -- seq ) { "cd" "pwd" } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-GENERIC: expand ( expr -- expr )
-
-METHOD: expand { single-quoted-expr } expr>> ;
-
-METHOD: expand { double-quoted-expr } expr>> ;
-
-METHOD: expand { variable-expr } expr>> os-env ;
-
-METHOD: expand { glob-expr }
- expr>>
- dup "*" =
- [ drop current-directory get directory-files ]
- [ ]
- if ;
-
-METHOD: expand { factor-expr } expr>> eval unparse ;
-
-DEFER: expansion
-
-METHOD: expand { back-quoted-expr }
- expr>>
- expr
- command>>
- expansion
- utf8 <process-stream>
- contents
- " \n" split
- "" remove ;
-
-METHOD: expand { object } ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: expansion ( command -- command ) [ expand ] map flatten ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-sword ( basic-expr -- )
- command>> expansion unclip "shell" lookup execute ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: run-foreground ( process -- )
- [ try-process ] [ print-error drop ] recover ;
-
-: run-background ( process -- ) run-detached drop ;
-
-: run-basic-expr ( basic-expr -- )
- <process>
- over command>> expansion >>command
- over stdin>> >>stdin
- over stdout>> >>stdout
- swap background>>
- [ run-background ]
- [ run-foreground ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: basic-chant ( basic-expr -- )
- dup command>> first swords member-of?
- [ run-sword ]
- [ run-basic-expr ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: chant ( obj -- )
- dup basic-expr?
- [ basic-chant ]
- [ pipeline-chant ]
- if ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: prompt ( -- )
- current-directory get write
- " $ " write
- flush ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-DEFER: shell
-
-: handle ( input -- )
- {
- { [ dup f = ] [ drop ] }
- { [ dup "exit" = ] [ drop ] }
- { [ dup "" = ] [ drop shell ] }
- { [ dup expr ] [ expr chant shell ] }
- { [ t ] [ drop "ix: ignoring input" print shell ] }
- }
- cond ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: shell ( -- )
- prompt
- readln
- handle ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: ix ( -- ) shell ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-MAIN: ix
! 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
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 }
{ "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 ;
+
+C: <spidering-site> spidering-site
+
+SLOT: site
-<PRIVATE
+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? ;
[ [ 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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
! 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
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
[ 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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
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
}
;
-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 )
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 ;
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* ]
[ 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 -- )
[ drop 0 0 (reflection-dim) glViewport ]
[
GL_PROJECTION glMatrixMode
- glLoadIdentity
+ glPushMatrix glLoadIdentity
reflection-frustum glFrustum
GL_MODELVIEW glMatrixMode
glLoadIdentity
[ 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 ]
[
]
} 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
! 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
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 -- )
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 ;
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 ;
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
: 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 ;
-
-:: 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 ;
+ ] 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 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
[ [ 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 ;
: 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
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+String Frying
\ No newline at end of file
--- /dev/null
+Alex Chapman
--- /dev/null
+Alex Chapman
--- /dev/null
+! 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 specialized-arrays.uchar specialized-arrays.short ;
+IN: synth.buffers
+
+TUPLE: buffer sample-freq 8bit? id ;
+
+: <buffer> ( sample-freq 8bit? -- buffer )
+ f buffer boa ;
+
+TUPLE: mono-buffer < buffer data ;
+
+: <mono-buffer> ( sample-freq 8bit? -- buffer )
+ f f mono-buffer boa ;
+
+: <8bit-mono-buffer> ( sample-freq -- buffer ) t <mono-buffer> ;
+: <16bit-mono-buffer> ( sample-freq -- buffer ) f <mono-buffer> ;
+
+TUPLE: stereo-buffer < buffer left-data right-data ;
+
+: <stereo-buffer> ( sample-freq 8bit? -- buffer )
+ f f f stereo-buffer boa ;
+
+: <8bit-stereo-buffer> ( sample-freq -- buffer ) t <stereo-buffer> ;
+: <16bit-stereo-buffer> ( sample-freq -- buffer ) f <stereo-buffer> ;
+
+PREDICATE: 8bit-buffer < buffer 8bit?>> ;
+PREDICATE: 16bit-buffer < buffer 8bit?>> not ;
+INTERSECTION: 8bit-mono-buffer 8bit-buffer mono-buffer ;
+INTERSECTION: 16bit-mono-buffer 16bit-buffer mono-buffer ;
+INTERSECTION: 8bit-stereo-buffer 8bit-buffer stereo-buffer ;
+INTERSECTION: 16bit-stereo-buffer 16bit-buffer stereo-buffer ;
+
+GENERIC: buffer-format ( buffer -- format )
+M: 8bit-mono-buffer buffer-format drop AL_FORMAT_MONO8 ;
+M: 16bit-mono-buffer buffer-format drop AL_FORMAT_MONO16 ;
+M: 8bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO8 ;
+M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ;
+
+: 8bit-buffer-data ( seq -- data size )
+ [ 128 * >integer 128 + ] uchar-array{ } map-as [ underlying>> ] [ length ] bi ;
+
+: 16bit-buffer-data ( seq -- data size )
+ [ 32768 * >integer ] short-array{ } map-as [ underlying>> ] [ byte-length ] bi ;
+
+: stereo-data ( stereo-buffer -- left right )
+ [ left-data>> ] [ right-data>> ] bi@ ;
+
+: interleaved-stereo-data ( stereo-buffer -- data )
+ stereo-data <2merged> ;
+
+GENERIC: buffer-data ( buffer -- data size )
+M: 8bit-mono-buffer buffer-data data>> 8bit-buffer-data ;
+M: 16bit-mono-buffer buffer-data data>> 16bit-buffer-data ;
+M: 8bit-stereo-buffer buffer-data
+ interleaved-stereo-data 8bit-buffer-data ;
+M: 16bit-stereo-buffer buffer-data
+ interleaved-stereo-data 16bit-buffer-data ;
+
+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 )
+ {
+ [ gen-buffer dup [ >>id ] dip ]
+ [ buffer-format ]
+ [ buffer-data ]
+ [ sample-freq>> alBufferData ]
+ } cleave ;
+
+: ?send-buffer ( buffer -- buffer )
+ dup id>> [ send-buffer ] unless ;
+
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel namespaces make openal sequences
+synth synth.buffers ;
+IN: synth.example
+
+: play-sine-wave ( freq seconds sample-freq -- )
+ init-openal
+ <16bit-mono-buffer> >sine-wave-buffer send-buffer id>>
+ 1 gen-sources first
+ [ AL_BUFFER rot set-source-param ] [ source-play ] bi
+ check-error ;
+
+: test-instrument1 ( -- harmonics )
+ [
+ 1 0.5 <harmonic> ,
+ 2 0.125 <harmonic> ,
+ 3 0.0625 <harmonic> ,
+ 4 0.03125 <harmonic> ,
+ ] { } make ;
+
+: test-instrument2 ( -- harmonics )
+ [
+ 1 0.25 <harmonic> ,
+ 2 0.25 <harmonic> ,
+ 3 0.25 <harmonic> ,
+ 4 0.25 <harmonic> ,
+ ] { } make ;
+
+: sine-instrument ( -- harmonics )
+ 1 1 <harmonic> 1array ;
+
+: test-note-buffer ( note -- )
+ init-openal
+ test-instrument2 swap cd-sample-freq <16bit-mono-buffer>
+ >note send-buffer id>>
+ 1 gen-sources first [ swap queue-buffer ] [ source-play ] bi
+ check-error ;
--- /dev/null
+Simple sound synthesis using OpenAL.
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
+IN: synth
+
+MEMO: single-sine-wave ( samples/wave -- seq )
+ pi 2 * over / [ * sin ] curry map ;
+
+: (sine-wave) ( samples/wave n-samples -- seq )
+ [ single-sine-wave ] dip <repeating> ;
+
+: sine-wave ( sample-freq freq seconds -- seq )
+ pick * >integer [ /i ] dip (sine-wave) ;
+
+: >sine-wave-buffer ( freq seconds buffer -- buffer )
+ [ sample-freq>> -rot sine-wave ] keep swap >>data ;
+
+: >silent-buffer ( seconds buffer -- buffer )
+ tuck sample-freq>> * >integer 0 <repetition> >>data ;
+
+TUPLE: harmonic n amplitude ;
+C: <harmonic> harmonic
+
+TUPLE: note hz secs ;
+C: <note> note
+
+: harmonic-freq ( note harmonic -- freq )
+ n>> swap hz>> * ;
+
+:: note-harmonic-data ( harmonic note buffer -- data )
+ buffer sample-freq>> note harmonic harmonic-freq note secs>> sine-wave
+ harmonic amplitude>> <scaled> ;
+
+: >note ( harmonics note buffer -- buffer )
+ dup -roll [ note-harmonic-data ] 2curry map <summed> >>data ;
+
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 )
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 ;
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 )
+! 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
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 ;
-
-: header-checksum ( seq -- x )
- 148 cut-slice 8 tail-slice
- [ sum ] bi@ + 256 + ;
+ 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 ;
+
+: checksum-header ( seq -- n )
+ 148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
: read-data-blocks ( tar-header -- )
dup size>> 0 > [
] 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 -- )
! Directory
: typeflag-5 ( header -- )
- name>> tar-prepend-path make-directories ;
+ name>> prepend-current-directory make-directories ;
! FIFO
: typeflag-6 ( header -- ) unknown-typeflag ;
! 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 ;
! 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>>
{
! { 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 ;
: draw-tetris ( width height tetris -- )
#! width and height are in pixels
- GL_MODELVIEW [
+ [
{
[ board>> scale-board ]
[ board>> draw-board ]
--- /dev/null
+Sam Anklesaria
--- /dev/null
+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." ;
+
--- /dev/null
+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
--- /dev/null
+Utilities for functional reactive programming in user interfaces
-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
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+Really simple dialog boxes
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+Easily switch between pages of book views
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+Combo boxes have a model choosen from a list of options
\ No newline at end of file
: invoke-value-action ( list -- )
dup list-empty? [
- dup hook>> call
+ dup hook>> call( list -- )
] [
[ index>> ] keep nth-gadget invoke-secondary
] if ;
+++ /dev/null
-! Copyright (C) 2008 Joe Groff.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations ui.gadgets
-images strings ui.gadgets.worlds ;
-IN: ui.offscreen
-
-HELP: <offscreen-world>
-{ $values
- { "gadget" gadget } { "title" string } { "status" "a boolean" }
- { "world" offscreen-world }
-}
-{ $description "Constructs an " { $link offscreen-world } " gadget with " { $snippet "gadget" } " as its only child. Generally you should use " { $link open-offscreen } " or " { $link do-offscreen } " instead of calling this word directly." } ;
-
-HELP: close-offscreen
-{ $values
- { "world" offscreen-world }
-}
-{ $description "Releases the resources used by the rendering buffer for " { $snippet "world" } "." } ;
-
-HELP: do-offscreen
-{ $values
- { "gadget" gadget } { "quot" quotation }
-}
-{ $description "Constructs an " { $link offscreen-world } " around " { $snippet "gadget" } " with " { $link open-offscreen } ", calls " { $snippet "quotation" } " with the world on the top of the stack, and cleans up the world with " { $link close-offscreen } " at the end of " { $snippet "quotation" } "." } ;
-
-HELP: gadget>bitmap
-{ $values
- { "gadget" gadget }
- { "image" image }
-}
-{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ;
-
-HELP: offscreen-world
-{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
-
-HELP: offscreen-world>bitmap
-{ $values
- { "world" offscreen-world }
- { "image" image }
-}
-{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ;
-
-HELP: open-offscreen
-{ $values
- { "gadget" gadget }
- { "world" offscreen-world }
-}
-{ $description "Creates and sets up an " { $link offscreen-world } " with " { $snippet "gadget" } " as its only child." } ;
-
-{ offscreen-world open-offscreen close-offscreen do-offscreen } related-words
-
-ARTICLE: "ui.offscreen" "Offscreen UI rendering"
-"The " { $vocab-link "ui.offscreen" } " provides words for rendering gadgets to an offscreen buffer so that bitmaps can be made from their contents."
-{ $subsection offscreen-world }
-"Opening gadgets offscreen:"
-{ $subsection open-offscreen }
-{ $subsection close-offscreen }
-{ $subsection do-offscreen }
-"Creating bitmaps from offscreen buffers:"
-{ $subsection offscreen-world>bitmap }
-{ $subsection gadget>bitmap } ;
-
-ABOUT: "ui.offscreen"
+++ /dev/null
-! (c) 2008 Joe Groff, see license for details
-USING: accessors alien.c-types continuations images kernel math
-sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.private ui ui.backend destructors locals ;
-IN: ui.offscreen
-
-TUPLE: offscreen-world < world ;
-
-: <offscreen-world> ( gadget title status -- world )
- offscreen-world new-world ;
-
-M: offscreen-world graft*
- (open-offscreen-buffer) ;
-
-M: offscreen-world ungraft*
- [ (ungraft-world) ]
- [ handle>> (close-offscreen-buffer) ]
- [ reset-world ] tri ;
-
-: open-offscreen ( gadget -- world )
- "" f <offscreen-world>
- [ open-world-window ] [ relayout-1 ] [ ] tri
- notify-queued ;
-
-: close-offscreen ( world -- )
- ungraft notify-queued ;
-
-:: bgrx>bitmap ( alien w h -- image )
- <image>
- { w h } >>dim
- alien w h * 4 * memory>byte-array >>bitmap
- BGRX >>component-order ;
-
-: offscreen-world>bitmap ( world -- image )
- offscreen-pixels bgrx>bitmap ;
-
-: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
- [ open-offscreen ] dip
- over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
-
-: gadget>bitmap ( gadget -- image )
- [ offscreen-world>bitmap ] do-offscreen ;
+++ /dev/null
-Offscreen world gadgets for rendering UI elements to bitmaps
+++ /dev/null
-ui
-graphics
dup class
{
{ \ string [ ] }
- { \ quotation [ call ] }
- { \ word [ execute ] }
+ { \ quotation [ call( -- string ) ] }
+ { \ word [ execute( -- string ) ] }
{ \ fixnum [ number>string ] }
{ \ array [ to-strings concat ] }
}
! 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
: <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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
--- /dev/null
+<?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>
--- /dev/null
+<?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>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<html>
+ <head>
+ <title>SiteWatcher</title>
+ </head>
+ <body>
+ <h1>SiteWatcher</h1>
+ <h2>It tells you if your web site goes down.</h2>
+ <t:call-next-template />
+ </body>
+</html>
+
+</t:chloe>
--- /dev/null
+<?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>
--- /dev/null
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+<h3>Enter your contact details</h3>
+
+<t:form t:action="$site-watcher-app/update-notify">
+<table>
+ <tr><th>E-mail:</th><td><t:field t:name="email" t:size="80" /></td></tr>
+ <tr><th>Twitter:</th><td><t:field t:name="twitter" t:size="80" /></td></tr>
+ <tr><th>SMS:</th><td><t:field t:name="sms" t:size="80" /></td></tr>
+</table>
+<p> <button type="submit">Done</button> </p>
+</t:form>
+
+</t:chloe>
+++ /dev/null
-<?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>
+++ /dev/null
-<?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>
! 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>
: <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' )
8431 >>secure ;
: site-watcher-db ( -- db )
- "resource:test.db" <sqlite-db> ;
+ "test.db" temp-file <sqlite-db> ;
<site-watcher-app>
<login-config>
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 ( -- )
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<html>
- <head>
- <title>SiteWatcher</title>
- </head>
- <body>
- <h1>SiteWatcher</h1>
- <h2>It tells you if your web site goes down.</h2>
- <t:call-next-template />
- </body>
-</html>
-
-</t:chloe>
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
+++ /dev/null
-<?xml version='1.0' ?>
-
-<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
-
-<h3>Enter your contact details</h3>
-
-<t:form t:action="$site-watcher-app/update-notify">
-<table>
- <tr><th>E-mail:</th><td><t:field t:name="email" t:size="80" /></td></tr>
- <tr><th>Twitter:</th><td><t:field t:name="twitter" t:size="80" /></td></tr>
- <tr><th>SMS:</th><td><t:field t:name="sms" t:size="80" /></td></tr>
-</table>
-<p> <button type="submit">Done</button> </p>
-</t:form>
-
-</t:chloe>
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
: 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 ;
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
correct-for-timing-overhead
"total time:" write
] dip pprint
- print-word-timings ;
+ print-word-timings ; inline
-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:
(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)
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")
(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)
(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")
(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)
(,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))
(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"))))
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"))
("\\_<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 ">"))
("\\_<\\(}\\)\\_>" (1 "){"))
;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()"))
+ ("\\_<call\\((\\)\\_>" (1 "()"))
("\\_<\\()\\)\\_>" (1 ")("))
("\\_<(\\((\\)\\_>" (1 "()"))
("\\_<\\()\\))\\_>" (1 ")("))
--- /dev/null
+IN: advice
+USING: help.markup help.syntax tools.annotations words coroutines ;
+
+HELP: make-advised
+{ $values { "word" "a word to annotate in preparation of advising" } }
+{ $description "Prepares a word for being advised. This is done by: "
+ { $list
+ { "Annotating it to call the appropriate words before, around, and after the original body " }
+ { "Adding " { $snippet "before" } ", " { $snippet "around" } ", and " { $snippet "after" } " properties, which will contain the advice" }
+ { "Adding an " { $snippet "advised" } "property, which can later be used to determine if a given word is defined (see " { $link advised? } ")" }
+ }
+}
+{ $see-also advised? annotate } ;
+
+HELP: advised?
+{ $values { "word" "a word" } { "?" "t or f, indicating if " { $snippet "word" } " is advised" } }
+{ $description "Determines whether or not the given word has any advice on it." } ;
+
+HELP: ad-do-it
+{ $values { "input" "an object" } { "result" "an object" } }
+{ $description "Calls either the next applicable around advice or the main body, returning back to the point it was called from when finished. This word should only be called from inside advice." }
+{ $see-also coyield } ;
+
+ARTICLE: "advice" "Advice"
+"Advice is a simple way of adding additition functionality to words by adding 'hooks' to a word, which can act before, after, or around the calling of the word." ;
+
+ABOUT: "advice"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences io io.streams.string math tools.test advice math.parser
+parser namespaces multiline eval words assocs ;
+IN: advice.tests
+
+[
+ [ ad-do-it ] must-fail
+
+ : foo ( -- str ) "foo" ;
+ \ foo make-advised
+
+ { "bar" "foo" } [
+ [ "bar" ] "barify" \ foo advise-before
+ foo
+ ] unit-test
+
+ { "bar" "foo" "baz" } [
+ [ "baz" ] "bazify" \ foo advise-after
+ foo
+ ] unit-test
+
+ { "foo" "baz" } [
+ "barify" \ foo before remove-advice
+ foo
+ ] unit-test
+
+ : bar ( a -- b ) 1 + ;
+ \ bar make-advised
+
+ { 11 } [
+ [ 2 * ] "double" \ bar advise-before
+ 5 bar
+ ] unit-test
+
+ { 11/3 } [
+ [ 3 / ] "third" \ bar advise-after
+ 5 bar
+ ] unit-test
+
+ { -2 } [
+ [ -1 * ad-do-it 3 + ] "frobnobicate" \ bar advise-around
+ 5 bar
+ ] unit-test
+
+ : add ( a b -- c ) + ;
+ \ add make-advised
+
+ { 10 } [
+ [ [ 2 * ] bi@ ] "double-args" \ add advise-before
+ 2 3 add
+ ] unit-test
+
+ { 21 } [
+ [ 3 * ad-do-it 1- ] "around1" \ add advise-around
+ 2 3 add
+ ] unit-test
+
+! { 9 } [
+! [ [ 1- ] bi@ ad-do-it 2 / ] "around2" \ add advise-around
+! 2 3 add
+! ] unit-test
+
+! { { "around1" "around2" } } [
+! \ add around word-prop keys
+! ] unit-test
+
+ { 5 f } [
+ \ add unadvise
+ 2 3 add \ add advised?
+ ] unit-test
+
+! : quux ( a b -- c ) * ;
+
+! { f t 3+3/4 } [
+! <" USING: advice kernel math ;
+! IN: advice.tests
+! \ quux advised?
+! ADVISE: quux halve before [ 2 / ] bi@ ;
+! \ quux advised?
+! 3 5 quux"> eval
+! ] unit-test
+
+! { 3+3/4 "1+1/2 2+1/2 3+3/4" } [
+! <" USING: advice kernel math math.parser io io.streams.string ;
+! IN: advice.tests
+! ADVISE: quux log around
+! 2dup [ number>string write " " write ] bi@
+! ad-do-it
+! dup number>string write ;
+! [ 3 5 quux ] with-string-writer"> eval
+! ] unit-test
+
+] with-scope
--- /dev/null
+! 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
+summary ;
+IN: advice
+
+SYMBOLS: before after around advised in-advice? ;
+
+: advised? ( word -- ? )
+ advised word-prop ;
+
+DEFER: make-advised
+
+<PRIVATE
+: init-around-co ( quot -- coroutine )
+ \ coreset suffix cocreate ;
+PRIVATE>
+
+: advise ( quot name word loc -- )
+ dup around eq? [ [ init-around-co ] 3dip ] when
+ over advised? [ over make-advised ] unless
+ word-prop set-at ;
+
+: advise-before ( quot name word -- ) before advise ;
+
+: advise-after ( quot name word -- ) after advise ;
+
+: advise-around ( quot name word -- ) around advise ;
+
+: get-advice ( word type -- seq )
+ word-prop values ;
+
+: call-before ( word -- )
+ before get-advice [ call ] each ;
+
+: call-after ( word -- )
+ after get-advice [ call ] each ;
+
+: call-around ( main word -- )
+ t in-advice? [
+ around get-advice tuck
+ [ [ coresume ] each ] [ call ] [ <reversed> [ coresume ] each ] tri*
+ ] with-variable ;
+
+: 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-error ] unless coyield ;
+
+: make-advised ( word -- )
+ [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ]
+ [ { before after around } [ <linked-hash> swap set-word-prop ] with each ]
+ [ t advised set-word-prop ] tri ;
+
+: unadvise ( word -- )
+ [ reset ] [ { before after around advised } [ f swap set-word-prop ] with each ] bi ;
+
+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 ;
--- /dev/null
+James Cash
--- /dev/null
+Implmentation of advice/aspects
--- /dev/null
+extensions
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays classes kernel sequences sets
+io prettyprint multi-methods ;
+IN: boolean-expr
+
+! Demonstrates the use of Unicode symbols in source files, and
+! multi-method dispatch.
+
+TUPLE: ⋀ x y ;
+TUPLE: ⋁ x y ;
+TUPLE: ¬ x ;
+
+SINGLETONS: ⊤ ⊥ ;
+
+SINGLETONS: P Q R S T U V W X Y Z ;
+
+UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ;
+
+GENERIC: ⋀ ( x y -- expr )
+
+METHOD: ⋀ { ⊤ □ } nip ;
+METHOD: ⋀ { □ ⊤ } drop ;
+METHOD: ⋀ { ⊥ □ } drop ;
+METHOD: ⋀ { □ ⊥ } nip ;
+
+METHOD: ⋀ { ⋁ □ } [ [ x>> ] dip ⋀ ] [ [ y>> ] dip ⋀ ] 2bi ⋁ ;
+METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ;
+
+METHOD: ⋀ { □ □ } \ ⋀ boa ;
+
+GENERIC: ⋁ ( x y -- expr )
+
+METHOD: ⋁ { ⊤ □ } drop ;
+METHOD: ⋁ { □ ⊤ } nip ;
+METHOD: ⋁ { ⊥ □ } nip ;
+METHOD: ⋁ { □ ⊥ } drop ;
+
+METHOD: ⋁ { □ □ } \ ⋁ boa ;
+
+GENERIC: ¬ ( x -- expr )
+
+METHOD: ¬ { ⊤ } drop ⊥ ;
+METHOD: ¬ { ⊥ } drop ⊤ ;
+
+METHOD: ¬ { ⋀ } [ x>> ¬ ] [ y>> ¬ ] bi ⋁ ;
+METHOD: ¬ { ⋁ } [ x>> ¬ ] [ y>> ¬ ] bi ⋀ ;
+
+METHOD: ¬ { □ } \ ¬ boa ;
+
+: → ( x y -- expr ) ¬ ⋀ ;
+: ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ;
+: ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ;
+
+GENERIC: (cnf) ( expr -- cnf )
+
+METHOD: (cnf) { ⋀ } [ x>> (cnf) ] [ y>> (cnf) ] bi append ;
+METHOD: (cnf) { □ } 1array ;
+
+GENERIC: cnf ( expr -- cnf )
+
+METHOD: cnf { ⋁ } [ x>> cnf ] [ y>> cnf ] bi append ;
+METHOD: cnf { □ } (cnf) 1array ;
+
+GENERIC: satisfiable? ( expr -- ? )
+
+METHOD: satisfiable? { ⊤ } drop t ;
+METHOD: satisfiable? { ⊥ } drop f ;
+
+: partition ( seq quot -- left right )
+ [ [ not ] compose filter ] [ filter ] 2bi ; inline
+
+: (satisfiable?) ( seq -- ? )
+ [ \ ¬ instance? ] partition [ x>> ] map intersect empty? ;
+
+METHOD: satisfiable? { □ }
+ cnf [ (satisfiable?) ] any? ;
+
+GENERIC: (expr.) ( expr -- )
+
+METHOD: (expr.) { □ } pprint ;
+
+: op. ( expr -- )
+ "(" write
+ [ x>> (expr.) ]
+ [ bl class pprint bl ]
+ [ y>> (expr.) ]
+ tri
+ ")" write ;
+
+METHOD: (expr.) { ⋀ } op. ;
+METHOD: (expr.) { ⋁ } op. ;
+METHOD: (expr.) { ¬ } [ class pprint ] [ x>> (expr.) ] bi ;
+
+: expr. ( expr -- ) (expr.) nl ;
--- /dev/null
+Simple boolean expression evaluator and simplifier
--- /dev/null
+William Schlieper
--- /dev/null
+! See http://factorcode.org/license.txt for BSD licence.
+USING: help.markup help.syntax ;
+
+IN: graph-theory
+
+ARTICLE: "graph-protocol" "Graph protocol"
+"All graphs must be instances of the graph mixin:"
+{ $subsection graph }
+"All graphs must implement a method on the following generic word:"
+{ $subsection vertices }
+"At least one of the following two generic words must have a method; the " { $link graph } " mixin has default definitions which are mutually recursive:"
+{ $subsection adjlist }
+{ $subsection adj? }
+"All mutable graphs must implement a method on the following generic word:"
+{ $subsection add-blank-vertex }
+"All mutable undirected graphs must implement a method on the following generic word:"
+{ $subsection add-edge }
+"Mutable directed graphs should not implement the above word, as it has a default definition defined in terms of the following generic word:"
+{ $subsection add-edge* }
+"The following two words have default definitions, but are available as generics to allow implementations to optimize them:"
+{ $subsection num-vertices }
+{ $subsection num-edges } ;
+
+HELP: graph
+{ $class-description "A mixin class whose instances are graphs. Custom implementations of the graph protocol should be declared as instances of this mixin for all graph functionality to work correctly:"
+ { $code "INSTANCE: hex-board graph" }
+} ;
+
+{ vertices num-vertices num-edges } related-words
+
+HELP: vertices
+{ $values { "graph" graph } { "seq" "The vertices" } }
+{ $description "Returns the vertices of the graph." } ;
+
+HELP: num-vertices
+{ $values { "graph" graph } { "n" "The number of vertices" } }
+{ $description "Returns the number of vertices in the graph." } ;
+
+HELP: num-edges
+{ $values { "graph" "A graph" } { "n" "The number of edges" } }
+{ $description "Returns the number of edges in the graph." } ;
+
+{ adjlist adj? } related-words
+
+HELP: adjlist
+{ $values
+ { "from" "The index of a vertex" }
+ { "graph" "The graph to be examined" }
+ { "seq" "The adjacency list" } }
+{ $description "Returns a sequence of vertices that this vertex links to" } ;
+
+HELP: adj?
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of a vertex" }
+ { "graph" "A graph" }
+ { "?" "A boolean" } }
+{ $description "Returns a boolean describing whether there is an edge in the graph between from and to." } ;
+
+{ add-blank-vertex add-blank-vertices add-edge add-edge* } related-words
+
+HELP: add-blank-vertex
+{ $values
+ { "index" "A vertex index" }
+ { "graph" "A graph" } }
+{ $description "Adds a vertex to the graph." } ;
+
+HELP: add-blank-vertices
+{ $values
+ { "seq" "A sequence of vertex indices" }
+ { "graph" "A graph" } }
+{ $description "Adds vertices with indices in seq to the graph." } ;
+
+HELP: add-edge*
+{ $values
+ { "from" "The index of a vertex" }
+ { "to" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a one-way edge to the graph, between " { $snippet "from" } " and " { $snippet "to" } "."
+ $nl
+ "If you want to add a two-way edge, use " { $link add-edge } " instead." } ;
+
+HELP: add-edge
+{ $values
+ { "u" "The index of a vertex" }
+ { "v" "The index of another vertex" }
+ { "graph" "A graph" } }
+{ $description "Adds a two-way edge to the graph, between " { $snippet "u" } " and " { $snippet "v" } "."
+ $nl
+ "If you want to add a one-way edge, use " { $link add-edge* } " instead." } ;
+
+{ depth-first full-depth-first dag? topological-sort } related-words
+
+HELP: depth-first
+{ $values
+ { "v" "The vertex to start the search at" }
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "?list" "A list of booleans describing the vertices visited in the search" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } " can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ { $emphasis "?list" } " is a list of booleans, " { $link t } " for every vertex visted during the search, and " { $link f } " for every vertex not visited." } ;
+
+HELP: full-depth-first
+{ $values
+ { "graph" "The graph to search" }
+ { "pre" "A quotation of the form ( n -- )" }
+ { "post" "A quotation of the form ( n -- )" }
+ { "tail" "A quotation of the form ( -- )" }
+ { "?" "A boolean describing whether or not the end-search error was thrown" } }
+{ $description "Performs a depth-first search on " { $emphasis "graph" } ". The variable " { $emphasis "graph" } "can be accessed in both quotations."
+ $nl
+ "The " { $emphasis "pre" } " quotation is run before the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "post" } " quotation is run after the recursive application of depth-first."
+ $nl
+ "The " { $emphasis "tail" } " quotation is run after each time the depth-first search runs out of nodes. On an undirected graph this will be each connected subgroup but on a directed graph it can be more complex." } ;
+
+HELP: dag?
+{ $values
+ { "graph" graph }
+ { "?" "A boolean indicating if the graph is acyclic" } }
+{ $description "Using a depth-first search, determines if the specified directed graph is a directed acyclic graph. An undirected graph will produce a false result, as the algorithm does not eliminate cycles of length 2, which will include any edge that goes both ways." } ;
+
+HELP: topological-sort
+{ $values
+ { "graph" graph }
+ { "seq/f" "Either a sequence of values or f" } }
+{ $description "Using a depth-first search, topologically sorts the specified directed graph. Returns f if the graph contains any cycles, and a topologically sorted sequence otherwise." } ;
--- /dev/null
+! 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 ;
+IN: graph-theory
+
+MIXIN: graph
+SYMBOL: visited?
+ERROR: end-search ;
+
+GENERIC: vertices ( graph -- seq ) flushable
+
+GENERIC: num-vertices ( graph -- n ) flushable
+
+GENERIC: num-edges ( graph -- n ) flushable
+
+GENERIC: adjlist ( from graph -- seq ) flushable
+
+GENERIC: adj? ( from to graph -- ? ) flushable
+
+GENERIC: add-blank-vertex ( index graph -- )
+
+GENERIC: delete-blank-vertex ( index graph -- )
+
+GENERIC: add-edge* ( from to graph -- )
+
+GENERIC: add-edge ( u v graph -- )
+
+GENERIC: delete-edge* ( from to graph -- )
+
+GENERIC: delete-edge ( u v graph -- )
+
+M: graph num-vertices
+ vertices length ;
+
+M: graph num-edges
+ [ vertices ] [ '[ _ adjlist length ] sigma ] bi ;
+
+M: graph adjlist
+ [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ;
+
+M: graph adj?
+ swapd adjlist index >boolean ;
+
+M: graph add-edge
+ [ add-edge* ] [ swapd add-edge* ] 3bi ;
+
+M: graph delete-edge
+ [ delete-edge* ] [ swapd delete-edge* ] 3bi ;
+
+: add-blank-vertices ( seq graph -- )
+ '[ _ add-blank-vertex ] each ;
+
+: delete-vertex ( index graph -- )
+ [ adjlist ]
+ [ '[ _ _ 3dup adj? [ delete-edge* ] [ 3drop ] if ] each ]
+ [ delete-blank-vertex ] 2tri ;
+
+<PRIVATE
+
+: search-wrap ( quot graph -- ? )
+ [ [ graph set ] [ vertices [ f 2array ] map >hashtable visited? set ] bi
+ [ t ] compose [ dup end-search? [ drop f ] [ rethrow ] if ] recover ] with-scope ; inline
+
+: (depth-first) ( v pre post -- )
+ { [ 2drop visited? get t -rot set-at ]
+ [ drop call ]
+ [ [ graph get adjlist ] 2dip
+ '[ dup visited? get at [ drop ] [ _ _ (depth-first) ] if ] each ]
+ [ nip call ] } 3cleave ; inline
+
+PRIVATE>
+
+: depth-first ( v graph pre post -- ?list ? )
+ '[ _ _ (depth-first) visited? get ] swap search-wrap ; inline
+
+: full-depth-first ( graph pre post tail -- ? )
+ '[ [ visited? get [ nip not ] assoc-find ]
+ [ drop _ _ (depth-first) @ ]
+ while 2drop ] swap search-wrap ; inline
+
+: dag? ( graph -- ? )
+ V{ } clone swap [ 2dup swap push dupd
+ '[ _ swap graph get adj? not ] all?
+ [ end-search ] unless ]
+ [ drop dup pop* ] [ ] full-depth-first nip ;
+
+: topological-sort ( graph -- seq/f )
+ dup dag?
+ [ V{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ]
+ [ drop f ] if ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel graph-theory ;
+
+IN: graph-theory.reversals
+
+TUPLE: reversal graph ;
+
+GENERIC: reverse-graph ( graph -- reversal )
+
+M: graph reverse-graph reversal boa ;
+
+M: reversal reverse-graph graph>> ;
+
+INSTANCE: reversal graph
+
+M: reversal vertices
+ graph>> vertices ;
+
+M: reversal adj?
+ swapd graph>> adj? ;
--- /dev/null
+! Copyright (C) 2008 William Schlieper <schlieper@unc.edu>
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel sequences arrays vectors sets assocs hashtables graph-theory namespaces fry ;
+
+IN: graph-theory.sparse
+
+TUPLE: sparse-graph alist ;
+
+: <sparse-graph> ( -- sparse-graph )
+ H{ } clone sparse-graph boa ;
+
+: >sparse-graph ( graph -- sparse-graph )
+ [ vertices ] keep
+ '[ dup _ adjlist 2array ] map >hashtable sparse-graph boa ;
+
+INSTANCE: sparse-graph graph
+
+M: sparse-graph vertices
+ alist>> keys ;
+
+M: sparse-graph adjlist
+ alist>> at ;
+
+M: sparse-graph add-blank-vertex
+ alist>> V{ } clone -rot set-at ;
+
+M: sparse-graph delete-blank-vertex
+ alist>> delete-at ;
+
+M: sparse-graph add-edge*
+ alist>> swapd at adjoin ;
+
+M: sparse-graph delete-edge*
+ alist>> swapd at delete ;
--- /dev/null
+Graph-theoretic algorithms
--- /dev/null
+collections
--- /dev/null
+Doug Coleman
--- /dev/null
+USING: io lint kernel math tools.test ;
+IN: lint.tests
+
+! Don't write code like this
+: lint1 ( obj -- ) [ "hi" print ] [ ] if ; ! when
+
+[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
+
+: lint2 ( n -- n' ) 1 + ; ! 1+
+[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
+
+: lint3 ( a b -- b a b ) dup -rot ; ! tuck
+
+[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.accessors arrays assocs
+combinators.short-circuit fry hashtables io
+kernel math namespaces prettyprint quotations sequences
+sequences.deep sets slots.private vectors vocabs words
+kernel.private ;
+IN: lint
+
+SYMBOL: def-hash
+SYMBOL: def-hash-keys
+
+: set-hash-vector ( val key hash -- )
+ 2dup at -rot [ ?push ] 2dip set-at ;
+
+: more-defs ( hash -- )
+ {
+ { -rot [ swap [ swap ] dip ] }
+ { -rot [ swap swapd ] }
+ { rot [ [ swap ] dip swap ] }
+ { rot [ swapd swap ] }
+ { over [ dup swap ] }
+ { tuck [ dup -rot ] }
+ { swapd [ [ swap ] dip ] }
+ { 2nip [ nip nip ] }
+ { 2drop [ drop drop ] }
+ { 3drop [ drop drop drop ] }
+ { pop* [ pop drop ] }
+ { when [ [ ] if ] }
+ { >boolean [ f = not ] }
+ } swap '[ first2 _ set-hash-vector ] each ;
+
+: accessor-words ( -- seq )
+{
+ alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
+ alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
+ <displaced-alien> alien-unsigned-cell set-alien-signed-cell
+ set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
+ set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
+ set-alien-unsigned-8 set-alien-signed-8
+ alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
+ set-alien-float alien-float
+} ;
+
+: trivial-defs ( -- seq )
+ {
+ [ drop ] [ 2array ]
+ [ bitand ]
+
+ [ . ]
+ [ get ]
+ [ t ] [ f ]
+ [ { } ]
+ [ drop f ]
+ [ "cdecl" ]
+ [ first ] [ second ] [ third ] [ fourth ]
+ [ ">" write ] [ "/>" write ]
+ } ;
+
+! ! Add definitions
+H{ } clone def-hash set-global
+
+all-words [
+ dup def>> dup callable?
+ [ def-hash get-global set-hash-vector ] [ drop ] if
+] each
+
+! ! Remove definitions
+
+! Remove empty word defs
+def-hash get-global [ drop empty? not ] assoc-filter
+
+! Remove constants [ 1 ]
+[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
+
+! Remove words that are their own definition
+[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
+
+! Remove set-alien-cell, etc.
+[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
+
+! Remove trivial defs
+[ drop trivial-defs member? not ] assoc-filter
+
+! Remove numbers only defs
+[ drop [ number? ] all? not ] assoc-filter
+
+! Remove curry only defs
+[ drop [ \ curry = ] all? not ] assoc-filter
+
+! Remove tag defs
+[
+ drop {
+ [ length 3 = ]
+ [ first \ tag = ] [ second number? ] [ third \ eq? = ]
+ } 1&& not
+] assoc-filter
+
+[
+ drop {
+ [ [ wrapper? ] deep-any? ]
+ [ [ hashtable? ] deep-any? ]
+ } 1|| not
+] assoc-filter
+
+! Remove n m shift defs
+[
+ drop dup length 3 = [
+ [ first2 [ number? ] both? ]
+ [ third \ shift = ] bi and not
+ ] [ drop t ] if
+] assoc-filter
+
+! Remove [ n slot ]
+[
+ drop dup length 2 =
+ [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
+] assoc-filter
+
+
+dup more-defs
+
+[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
+
+: find-duplicates ( -- seq )
+ def-hash get-global [ nip length 1 > ] assoc-filter ;
+
+GENERIC: lint ( obj -- seq )
+
+M: object lint ( obj -- seq ) drop f ;
+
+: subseq/member? ( subseq/member seq -- ? )
+ { [ start ] [ member? ] } 2|| ;
+
+M: callable lint ( quot -- seq )
+ [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
+
+M: word lint ( word -- seq )
+ def>> dup callable? [ lint ] [ drop f ] if ;
+
+: word-path. ( word -- )
+ [ vocabulary>> ] [ unparse ] bi ":" glue print ;
+
+: 4bl ( -- ) bl bl bl bl ;
+
+: (lint.) ( pair -- )
+ first2 [ word-path. ] dip [
+ [ 4bl . "-----------------------------------" print ]
+ [ def-hash get-global at [ 4bl word-path. ] each nl ] bi
+ ] each nl nl ;
+
+: lint. ( alist -- ) [ (lint.) ] each ;
+
+GENERIC: run-lint ( obj -- obj )
+
+: (trim-self) ( val key -- obj ? )
+ def-hash get-global at*
+ [ dupd remove empty? not ] [ drop f ] if ;
+
+: trim-self ( seq -- newseq )
+ [ [ (trim-self) ] filter ] assoc-map ;
+
+: filter-symbols ( alist -- alist )
+ [
+ nip first dup def-hash get-global at
+ [ first ] bi@ literalize = not
+ ] assoc-filter ;
+
+M: sequence run-lint ( seq -- seq )
+ [ dup lint ] { } map>assoc trim-self
+ [ second empty? not ] filter filter-symbols ;
+
+M: word run-lint ( word -- seq ) 1array run-lint ;
+
+: lint-all ( -- seq ) all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
+
+: lint-word ( word -- seq ) 1array run-lint dup lint. ;
--- /dev/null
+Finds potential mistakes in code
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax ;
-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." } ;
-
-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" } ;
-
-HELP: >morse
-{ $values
- { "str" "A string of ASCII characters which can be translated into morse code" } { "str" "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" } }
-{ $description "Translates morse code into ASCII text" }
-{ $see-also >morse morse>ch } ;
-
-HELP: play-as-morse*
-{ $values { "str" "A string of ascii characters which can be translated into morse code" } { "unit-length" "The length of a dot" } }
-{ $description "Plays a string as morse code" } ;
-
-HELP: play-as-morse
-{ $values { "str" "A string of ascii characters which can be translated into morse code" } }
-{ $description "Plays a string as morse code" } ;
+++ /dev/null
-! 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
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! 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 ;
-IN: morse
-
-<PRIVATE
-: morse-codes ( -- array )
- {
- { CHAR: a ".-" }
- { CHAR: b "-..." }
- { CHAR: c "-.-." }
- { CHAR: d "-.." }
- { CHAR: e "." }
- { CHAR: f "..-." }
- { CHAR: g "--." }
- { CHAR: h "...." }
- { CHAR: i ".." }
- { CHAR: j ".---" }
- { CHAR: k "-.-" }
- { CHAR: l ".-.." }
- { CHAR: m "--" }
- { CHAR: n "-." }
- { CHAR: o "---" }
- { CHAR: p ".--." }
- { CHAR: q "--.-" }
- { CHAR: r ".-." }
- { CHAR: s "..." }
- { CHAR: t "-" }
- { CHAR: u "..-" }
- { CHAR: v "...-" }
- { CHAR: w ".--" }
- { CHAR: x "-..-" }
- { CHAR: y "-.--" }
- { CHAR: z "--.." }
- { CHAR: 1 ".----" }
- { CHAR: 2 "..---" }
- { CHAR: 3 "...--" }
- { CHAR: 4 "....-" }
- { CHAR: 5 "....." }
- { CHAR: 6 "-...." }
- { CHAR: 7 "--..." }
- { CHAR: 8 "---.." }
- { CHAR: 9 "----." }
- { CHAR: 0 "-----" }
- { CHAR: . ".-.-.-" }
- { CHAR: , "--..--" }
- { CHAR: ? "..--.." }
- { CHAR: ' ".----." }
- { CHAR: ! "-.-.--" }
- { CHAR: / "-..-." }
- { CHAR: ( "-.--." }
- { CHAR: ) "-.--.-" }
- { CHAR: & ".-..." }
- { CHAR: : "---..." }
- { CHAR: ; "-.-.-." }
- { CHAR: = "-...- " }
- { CHAR: + ".-.-." }
- { CHAR: - "-....-" }
- { CHAR: _ "..--.-" }
- { CHAR: " ".-..-." }
- { CHAR: $ "...-..-" }
- { CHAR: @ ".--.-." }
- { CHAR: \s "/" }
- } ;
-
-: 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 "" ? ;
-
-: morse>ch ( str -- ch )
- morse>ch-assoc at* swap f ? ;
-
-: >morse ( str -- str )
- [
- [ CHAR: \s , ] [ ch>morse % ] interleave
- ] "" make ;
-
-<PRIVATE
-
-: dot-char ( -- ch ) CHAR: . ;
-: dash-char ( -- ch ) CHAR: - ;
-: char-gap-char ( -- ch ) CHAR: \s ;
-: word-gap-char ( -- ch ) CHAR: / ;
-
-: =parser ( obj -- parser )
- [ = ] curry satisfy ;
-
-LAZY: 'dot' ( -- parser )
- dot-char =parser ;
-
-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 ;
-
-PRIVATE>
-
-: morse> ( str -- str )
- 'morse-words' parse car parsed>> [
- [
- >string morse>ch
- ] map >string
- ] map [ [ CHAR: \s , ] [ % ] interleave ] "" make ;
-
-<PRIVATE
-SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
-
-: queue ( symbol -- )
- get source get swap queue-buffer ;
-
-: dot ( -- ) dot-buffer queue ;
-: dash ( -- ) dash-buffer queue ;
-: intra-char-gap ( -- ) intra-char-gap-buffer queue ;
-: letter-gap ( -- ) letter-gap-buffer queue ;
-
-: beep-freq 880 ;
-
-: <morse-buffer> ( -- buffer )
- half-sample-freq <8bit-mono-buffer> ;
-
-: sine-buffer ( seconds -- id )
- beep-freq swap <morse-buffer> >sine-wave-buffer
- send-buffer id>> ;
-
-: silent-buffer ( seconds -- id )
- <morse-buffer> >silent-buffer send-buffer id>> ;
-
-: make-buffers ( unit-length -- )
- {
- [ sine-buffer dot-buffer set ]
- [ 3 * sine-buffer dash-buffer set ]
- [ silent-buffer intra-char-gap-buffer set ]
- [ 3 * silent-buffer letter-gap-buffer set ]
- } cleave ;
-
-: playing-morse ( quot unit-length -- )
- [
- init-openal 1 gen-sources first source set make-buffers
- call
- source get source-play
- ] with-scope ;
-
-: play-char ( ch -- )
- [ intra-char-gap ] [
- {
- { dot-char [ dot ] }
- { dash-char [ dash ] }
- { word-gap-char [ intra-char-gap ] }
- } case
- ] interleave ;
-
-PRIVATE>
-
-: play-as-morse* ( str unit-length -- )
- [
- [ letter-gap ] [ ch>morse play-char ] interleave
- ] swap playing-morse ;
-
-: play-as-morse ( str -- )
- 0.05 play-as-morse* ;
+++ /dev/null
-Converts between text and morse code, and plays morse code.
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences vectors classes classes.algebra
+combinators arrays words assocs parser namespaces make
+definitions prettyprint prettyprint.backend prettyprint.custom
+quotations generalizations debugger io compiler.units
+kernel.private effects accessors hashtables sorting shuffle
+math.order sets see effects.parser ;
+IN: multi-methods
+
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
+
+SYMBOL: args
+
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] filter
+ [ length <reversed> [ 1+ neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] filter
+ [ keys [ hooks get adjoin ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ [
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get +
+ ] dip
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ [ total get object <array> dup <enum> ] dip update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ [ canonicalize-specializer-0 ] dip ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ [ canonicalize-specializer-1 ] dip ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ [ canonicalize-specializer-2 ] dip ] assoc-map
+
+ args get hooks get length + total set
+
+ [ [ canonicalize-specializer-3 ] dip ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
+: maximal-element ( seq quot -- n elt )
+ dupd [
+ swapd [ call +lt+ = ] 2curry filter empty?
+ ] 2curry find [ "Topological sort failed" throw ] unless* ;
+ inline
+
+: topological-sort ( seq quot -- newseq )
+ [ >vector [ dup empty? not ] ] dip
+ [ dupd maximal-element [ over delete-nth ] dip ] curry
+ produce nip ; inline
+
+: classes< ( seq1 seq2 -- lt/eq/gt )
+ [
+ {
+ { [ 2dup eq? ] [ +eq+ ] }
+ { [ 2dup [ class<= ] [ swap class<= ] 2bi and ] [ +eq+ ] }
+ { [ 2dup class<= ] [ +lt+ ] }
+ { [ 2dup swap class<= ] [ +gt+ ] }
+ [ +eq+ ]
+ } cond 2nip
+ ] 2map [ +eq+ eq? not ] find nip +eq+ or ;
+
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
+: picker ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1- picker [ dip swap ] curry ]
+ } case ;
+
+: (multi-predicate) ( class picker -- quot )
+ swap "predicate" word-prop append ;
+
+: multi-predicate ( classes -- quot )
+ dup length <reversed>
+ [ picker 2array ] 2map
+ [ drop object eq? not ] assoc-filter
+ [ [ t ] ] [
+ [ (multi-predicate) ] { } assoc>map
+ unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
+ ] if-empty ;
+
+: argument-count ( methods -- n )
+ keys 0 [ length max ] reduce ;
+
+ERROR: no-method arguments generic ;
+
+: make-default-method ( methods generic -- quot )
+ [ argument-count ] dip [ [ narray ] dip no-method ] 2curry ;
+
+: multi-dispatch-quot ( methods generic -- quot )
+ [ make-default-method ]
+ [ drop [ [ multi-predicate ] dip ] assoc-map reverse ]
+ 2bi alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
+: methods ( word -- alist )
+ "multi-methods" word-prop >alist ;
+
+: make-generic ( generic -- quot )
+ [
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
+ ] [ ] make ;
+
+: update-generic ( word -- )
+ dup make-generic define ;
+
+! Methods
+PREDICATE: method-body < word
+ "multi-method-generic" word-prop >boolean ;
+
+M: method-body stack-effect
+ "multi-method-generic" word-prop stack-effect ;
+
+M: method-body crossref?
+ "forgotten" word-prop not ;
+
+: method-word-name ( specializer generic -- string )
+ [ name>> % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
+ [
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
+
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
+ method-word-name f <word>
+ swap >>props ;
+
+: with-methods ( word quot -- )
+ over [
+ [ "multi-methods" word-prop ] dip call
+ ] dip update-generic ; inline
+
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
+
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
+
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
+ ] if ;
+
+: niceify-method ( seq -- seq )
+ [ dup \ f eq? [ drop f ] when ] map ;
+
+M: no-method error.
+ "Type check error" print
+ nl
+ "Generic word " write dup generic>> pprint
+ " does not have a method applicable to inputs:" print
+ dup arguments>> short.
+ nl
+ "Inputs have signature:" print
+ dup arguments>> [ class ] map niceify-method .
+ nl
+ "Available methods: " print
+ generic>> methods canonicalize-specializers drop sort-methods
+ keys [ niceify-method ] map stack. ;
+
+: forget-method ( specializer generic -- )
+ [ delete-at ] with-methods ;
+
+: method>spec ( method -- spec )
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
+
+: define-generic ( word effect -- )
+ over set-stack-effect
+ dup "multi-methods" word-prop [ drop ] [
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ update-generic ]
+ bi
+ ] if ;
+
+! Syntax
+SYNTAX: GENERIC: CREATE-WORD complete-effect define-generic ;
+
+: parse-method ( -- quot classes generic )
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
+
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
+
+: CREATE-METHOD ( -- method )
+ scan-word scan-object swap create-method-in ;
+
+: (METHOD:) ( -- method def ) CREATE-METHOD parse-definition ;
+
+SYNTAX: METHOD: (METHOD:) define ;
+
+! For compatibility
+SYNTAX: M:
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ;
+
+! Definition protocol. We qualify core generics here
+QUALIFIED: syntax
+
+syntax:M: generic definer drop \ GENERIC: f ;
+
+syntax:M: generic definition drop f ;
+
+PREDICATE: method-spec < array
+ unclip generic? [ [ class? ] all? ] dip and ;
+
+syntax:M: method-spec where
+ dup unclip method [ ] [ first ] ?if where ;
+
+syntax:M: method-spec set-where
+ unclip method set-where ;
+
+syntax:M: method-spec definer
+ unclip method definer ;
+
+syntax:M: method-spec definition
+ unclip method definition ;
+
+syntax:M: method-spec synopsis*
+ unclip method synopsis* ;
+
+syntax:M: method-spec forget*
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
--- /dev/null
+Experimental multiple dispatch implementation
--- /dev/null
+extensions
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test ( -- )
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1 ( -- seq )
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+CONSTANT: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ }
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ { cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+
+[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+[ { } \ fake method-word-props ] unit-test
+
+[ t ] [ { } \ fake <method> method-body? ] unit-test
+
+[
+ [ { } [ ] ] [ \ fake methods prepare-methods [ sort-methods ] dip ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing (( -- )) define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+] with-compilation-unit
--- /dev/null
+IN: multi-methods.tests
+USING: math strings sequences tools.test ;
+
+GENERIC: legacy-test ( a -- b )
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
--- /dev/null
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs accessors see ;
+
+GENERIC: first-test ( -- )
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+GENERIC: beats? ( obj1 obj2 -- ? )
+
+METHOD: beats? { paper scissors } t ;
+METHOD: beats? { scissors rock } t ;
+METHOD: beats? { rock paper } t ;
+METHOD: beats? { thing thing } f ;
+
+: play ( obj1 obj2 -- ? ) beats? 2nip ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ { { } 3 } ] [ error get arguments>> ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+GENERIC: hook-test ( -- obj )
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+"error" some-var set
+[ H{ } hook-test ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ { H{ } "error" } ] [ error get arguments>> ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
--- /dev/null
+USING: kernel multi-methods tools.test math arrays sequences
+math.order ;
+IN: multi-methods.tests
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ +lt+ ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ +eq+ ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ +gt+ ] [
+ { object object } { number sequence } classes<
+] unit-test
--- /dev/null
+
+USING: kernel sequences assocs circular sets fry ;
+
+USING: math multi-methods ;
+
+QUALIFIED: sequences
+QUALIFIED: assocs
+QUALIFIED: circular
+QUALIFIED: sets
+
+IN: newfx
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Now, we can see a new world coming into view.
+! A world in which there is the very real prospect of a new world order.
+!
+! - George Herbert Walker Bush
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: at ( col key -- val )
+GENERIC: of ( key col -- val )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: grab ( col key -- col val )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: is ( col key val -- col )
+GENERIC: as ( col val key -- col )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: is-of ( key val col -- col )
+GENERIC: as-of ( val key col -- col )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: mutate-at ( col key val -- )
+GENERIC: mutate-as ( col val key -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: at-mutate ( key val col -- )
+GENERIC: as-mutate ( val key col -- )
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! sequence
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at { sequence number } swap nth ;
+METHOD: of { number sequence } nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: grab { sequence number } dupd swap nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is { sequence number object } swap pick set-nth ;
+METHOD: as { sequence object number } pick set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is-of { number object sequence } dup [ swapd set-nth ] dip ;
+METHOD: as-of { object number sequence } dup [ set-nth ] dip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { sequence number object } swap rot set-nth ;
+METHOD: mutate-as { sequence object number } rot set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at-mutate { number object sequence } swapd set-nth ;
+METHOD: as-mutate { object number sequence } set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! assoc
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at { assoc object } swap assocs:at ;
+METHOD: of { object assoc } assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: grab { assoc object } dupd swap assocs:at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is { assoc object object } swap pick set-at ;
+METHOD: as { assoc object object } pick set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: is-of { object object assoc } dup [ swapd set-at ] dip ;
+METHOD: as-of { object object assoc } dup [ set-at ] dip ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: mutate-at { assoc object object } swap rot set-at ;
+METHOD: mutate-as { assoc object object } rot set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+METHOD: at-mutate { object object assoc } swapd set-at ;
+METHOD: as-mutate { object object assoc } set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push ( seq obj -- seq ) over sequences:push ;
+: push-on ( obj seq -- seq ) tuck sequences:push ;
+: pushed ( seq obj -- ) swap sequences:push ;
+: pushed-on ( obj seq -- ) sequences:push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: member? ( seq obj -- ? ) swap sequences:member? ;
+: member-of? ( obj seq -- ? ) sequences:member? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete-at-key ( tbl key -- tbl ) over delete-at ;
+: delete-key-of ( key tbl -- tbl ) tuck delete-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete ( seq elt -- seq ) over sequences:delete ;
+: delete-from ( elt seq -- seq ) tuck sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: deleted ( seq elt -- ) swap sequences:delete ;
+: deleted-from ( elt seq -- ) sequences:delete ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: remove ( seq obj -- seq ) swap sequences:remove ;
+: remove-from ( obj seq -- seq ) sequences:remove ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: filter-of ( quot seq -- seq ) swap filter ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: map-over ( quot seq -- seq ) swap map ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push-circular ( seq elt -- seq ) over circular:push-circular ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prefix-on ( elt seq -- seq ) swap prefix ;
+: suffix-on ( elt seq -- seq ) swap suffix ;
+
+: suffix! ( seq elt -- seq ) over sequences:push ;
+: suffix-on! ( elt seq -- seq ) tuck sequences:push ;
+: suffixed! ( seq elt -- ) swap sequences:push ;
+: suffixed-on! ( elt seq -- ) sequences:push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: subseq ( seq from to -- subseq ) rot sequences:subseq ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key ( table val -- key ) swap assocs:value-at ;
+
+: key-of ( val table -- key ) assocs:value-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: index ( seq obj -- i ) swap sequences:index ;
+: index-of ( obj seq -- i ) sequences:index ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: 1st ( seq -- obj ) 0 swap nth ;
+: 2nd ( seq -- obj ) 1 swap nth ;
+: 3rd ( seq -- obj ) 2 swap nth ;
+: 4th ( seq -- obj ) 3 swap nth ;
+: 5th ( seq -- obj ) 4 swap nth ;
+: 6th ( seq -- obj ) 5 swap nth ;
+: 7th ( seq -- obj ) 6 swap nth ;
+: 8th ( seq -- obj ) 7 swap nth ;
+: 9th ( seq -- obj ) 8 swap nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A note about the 'mutate' qualifier. Other words also technically mutate
+! their primary object. However, the 'mutate' qualifier is supposed to
+! indicate that this is the main objective of the word, as a side effect.
+
+: adjoin ( seq elt -- seq ) over sets:adjoin ;
+: adjoin-on ( elt seq -- seq ) tuck sets:adjoin ;
+: adjoined ( set elt -- ) swap sets:adjoin ;
+: adjoined-on ( elt set -- ) sets:adjoin ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: start ( seq subseq -- i ) swap sequences:start ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pluck ( seq i -- seq ) cut-slice rest-slice append ;
+: pluck-from ( i seq -- seq ) swap pluck ;
+: pluck! ( seq i -- seq ) over delete-nth ;
+: pluck-from! ( i seq -- seq ) tuck delete-nth ;
+: plucked! ( seq i -- ) swap delete-nth ;
+: plucked-from! ( i seq -- ) delete-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: snip ( seq a b -- seq ) [ over ] dip [ head ] [ tail ] 2bi* append ;
+: snip-this ( a b seq -- seq ) -rot snip ;
+: snip! ( seq a b -- seq ) pick delete-slice ;
+: snip-this! ( a b seq -- seq ) -rot pick delete-slice ;
+: snipped! ( seq a b -- ) rot delete-slice ;
+: snipped-from! ( a b seq -- ) delete-slice ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: invert-index ( seq i -- seq i ) [ dup length 1 - ] dip - ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: append! ( a b -- ab ) over sequences:push-all ;
+: append-to! ( b a -- ab ) swap over sequences:push-all ;
+: appended! ( a b -- ) swap sequences:push-all ;
+: appended-to! ( b a -- ) sequences:push-all ;
+
+: prepend! ( a b -- ba ) over append 0 pick copy ;
+: prepended! ( a b -- ) over append 0 rot copy ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: insert ( seq i obj -- seq ) [ cut ] dip prefix append ;
+
+: splice ( seq i seq -- seq ) [ cut ] dip prepend append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: purge ( seq quot -- seq ) [ not ] compose filter ; inline
+
+: purge! ( seq quot -- seq )
+ dupd '[ swap @ [ pluck! ] [ drop ] if ] each-index ; inline
+++ /dev/null
-Chris Double
+++ /dev/null
-Chris Double
+++ /dev/null
-USING: namespaces system ;
-IN: openal.backend
-
-HOOK: load-wav-file os ( filename -- format data size frequency )
+++ /dev/null
-Chris Double
+++ /dev/null
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-IN: openal.example\r
-USING: openal kernel alien threads sequences calendar ;\r
-\r
-: play-hello ( -- )\r
- init-openal\r
- 1 gen-sources\r
- first dup AL_BUFFER alutCreateBufferHelloWorld set-source-param\r
- source-play\r
- 1000 milliseconds sleep ;\r
- \r
-: (play-file) ( source -- )\r
- 100 milliseconds sleep\r
- dup source-playing? [ (play-file) ] [ drop ] if ;\r
-\r
-: play-file ( filename -- )\r
- init-openal\r
- create-buffer-from-file \r
- 1 gen-sources\r
- first dup >r AL_BUFFER rot set-source-param r>\r
- dup source-play\r
- check-error\r
- (play-file) ;\r
-\r
-: play-wav ( filename -- )\r
- init-openal\r
- create-buffer-from-wav \r
- 1 gen-sources\r
- first dup >r AL_BUFFER rot set-source-param r>\r
- dup source-play\r
- check-error\r
- (play-file) ;
\ No newline at end of file
+++ /dev/null
-Chris Double
+++ /dev/null
-! 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 ;
-IN: openal.macosx
-
-LIBRARY: alut
-
-FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ;
-
-M: macosx load-wav-file ( path -- format data size frequency )
- 0 <int> f <void*> 0 <int> 0 <int>
- [ alutLoadWAVFile ] 4keep
- [ [ [ *int ] dip *void* ] dip *int ] dip *int ;
+++ /dev/null
-unportable
+++ /dev/null
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays alien system combinators alien.syntax namespaces
- alien.c-types sequences vocabs.loader shuffle
- openal.backend specialized-arrays.uint ;
-IN: openal
-
-<< "alut" {
- { [ os windows? ] [ "alut.dll" ] }
- { [ os macosx? ] [
- "/System/Library/Frameworks/OpenAL.framework/OpenAL"
- ] }
- { [ os unix? ] [ "libalut.so" ] }
- } cond "cdecl" add-library >>
-
-<< "openal" {
- { [ os windows? ] [ "OpenAL32.dll" ] }
- { [ os macosx? ] [
- "/System/Library/Frameworks/OpenAL.framework/OpenAL"
- ] }
- { [ os unix? ] [ "libopenal.so" ] }
- } cond "cdecl" add-library >>
-
-LIBRARY: openal
-
-TYPEDEF: char ALboolean
-TYPEDEF: char ALchar
-TYPEDEF: char ALbyte
-TYPEDEF: uchar ALubyte
-TYPEDEF: short ALshort
-TYPEDEF: ushort ALushort
-TYPEDEF: int ALint
-TYPEDEF: uint ALuint
-TYPEDEF: int ALsizei
-TYPEDEF: int ALenum
-TYPEDEF: float ALfloat
-TYPEDEF: double ALdouble
-
-CONSTANT: AL_INVALID -1
-CONSTANT: AL_NONE 0
-CONSTANT: AL_FALSE 0
-CONSTANT: AL_TRUE 1
-CONSTANT: AL_SOURCE_RELATIVE HEX: 202
-CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001
-CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002
-CONSTANT: AL_PITCH HEX: 1003
-CONSTANT: AL_POSITION HEX: 1004
-CONSTANT: AL_DIRECTION HEX: 1005
-CONSTANT: AL_VELOCITY HEX: 1006
-CONSTANT: AL_LOOPING HEX: 1007
-CONSTANT: AL_BUFFER HEX: 1009
-CONSTANT: AL_GAIN HEX: 100A
-CONSTANT: AL_MIN_GAIN HEX: 100D
-CONSTANT: AL_MAX_GAIN HEX: 100E
-CONSTANT: AL_ORIENTATION HEX: 100F
-CONSTANT: AL_CHANNEL_MASK HEX: 3000
-CONSTANT: AL_SOURCE_STATE HEX: 1010
-CONSTANT: AL_INITIAL HEX: 1011
-CONSTANT: AL_PLAYING HEX: 1012
-CONSTANT: AL_PAUSED HEX: 1013
-CONSTANT: AL_STOPPED HEX: 1014
-CONSTANT: AL_BUFFERS_QUEUED HEX: 1015
-CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016
-CONSTANT: AL_SEC_OFFSET HEX: 1024
-CONSTANT: AL_SAMPLE_OFFSET HEX: 1025
-CONSTANT: AL_BYTE_OFFSET HEX: 1026
-CONSTANT: AL_SOURCE_TYPE HEX: 1027
-CONSTANT: AL_STATIC HEX: 1028
-CONSTANT: AL_STREAMING HEX: 1029
-CONSTANT: AL_UNDETERMINED HEX: 1030
-CONSTANT: AL_FORMAT_MONO8 HEX: 1100
-CONSTANT: AL_FORMAT_MONO16 HEX: 1101
-CONSTANT: AL_FORMAT_STEREO8 HEX: 1102
-CONSTANT: AL_FORMAT_STEREO16 HEX: 1103
-CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020
-CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021
-CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022
-CONSTANT: AL_MAX_DISTANCE HEX: 1023
-CONSTANT: AL_FREQUENCY HEX: 2001
-CONSTANT: AL_BITS HEX: 2002
-CONSTANT: AL_CHANNELS HEX: 2003
-CONSTANT: AL_SIZE HEX: 2004
-CONSTANT: AL_UNUSED HEX: 2010
-CONSTANT: AL_PENDING HEX: 2011
-CONSTANT: AL_PROCESSED HEX: 2012
-CONSTANT: AL_NO_ERROR AL_FALSE
-CONSTANT: AL_INVALID_NAME HEX: A001
-CONSTANT: AL_ILLEGAL_ENUM HEX: A002
-CONSTANT: AL_INVALID_ENUM HEX: A002
-CONSTANT: AL_INVALID_VALUE HEX: A003
-CONSTANT: AL_ILLEGAL_COMMAND HEX: A004
-CONSTANT: AL_INVALID_OPERATION HEX: A004
-CONSTANT: AL_OUT_OF_MEMORY HEX: A005
-CONSTANT: AL_VENDOR HEX: B001
-CONSTANT: AL_VERSION HEX: B002
-CONSTANT: AL_RENDERER HEX: B003
-CONSTANT: AL_EXTENSIONS HEX: B004
-CONSTANT: AL_DOPPLER_FACTOR HEX: C000
-CONSTANT: AL_DOPPLER_VELOCITY HEX: C001
-CONSTANT: AL_SPEED_OF_SOUND HEX: C003
-CONSTANT: AL_DISTANCE_MODEL HEX: D000
-CONSTANT: AL_INVERSE_DISTANCE HEX: D001
-CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002
-CONSTANT: AL_LINEAR_DISTANCE HEX: D003
-CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004
-CONSTANT: AL_EXPONENT_DISTANCE HEX: D005
-CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006
-
-FUNCTION: void alEnable ( ALenum capability ) ;
-FUNCTION: void alDisable ( ALenum capability ) ;
-FUNCTION: ALboolean alIsEnabled ( ALenum capability ) ;
-FUNCTION: ALchar* alGetString ( ALenum param ) ;
-FUNCTION: void alGetBooleanv ( ALenum param, ALboolean* data ) ;
-FUNCTION: void alGetIntegerv ( ALenum param, ALint* data ) ;
-FUNCTION: void alGetFloatv ( ALenum param, ALfloat* data ) ;
-FUNCTION: void alGetDoublev ( ALenum param, ALdouble* data ) ;
-FUNCTION: ALboolean alGetBoolean ( ALenum param ) ;
-FUNCTION: ALint alGetInteger ( ALenum param ) ;
-FUNCTION: ALfloat alGetFloat ( ALenum param ) ;
-FUNCTION: ALdouble alGetDouble ( ALenum param ) ;
-FUNCTION: ALenum alGetError ( ) ;
-FUNCTION: ALboolean alIsExtensionPresent ( ALchar* extname ) ;
-FUNCTION: void* alGetProcAddress ( ALchar* fname ) ;
-FUNCTION: ALenum alGetEnumValue ( ALchar* ename ) ;
-FUNCTION: void alListenerf ( ALenum param, ALfloat value ) ;
-FUNCTION: void alListener3f ( ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alListenerfv ( ALenum param, ALfloat* values ) ;
-FUNCTION: void alListeneri ( ALenum param, ALint value ) ;
-FUNCTION: void alListener3i ( ALenum param, ALint value1, ALint value2, ALint value3 ) ;
-FUNCTION: void alListeneriv ( ALenum param, ALint* values ) ;
-FUNCTION: void alGetListenerf ( ALenum param, ALfloat* value ) ;
-FUNCTION: void alGetListener3f ( ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3 ) ;
-FUNCTION: void alGetListenerfv ( ALenum param, ALfloat* values ) ;
-FUNCTION: void alGetListeneri ( ALenum param, ALint* value ) ;
-FUNCTION: void alGetListener3i ( ALenum param, ALint* value1, ALint* value2, ALint* value3 ) ;
-FUNCTION: void alGetListeneriv ( ALenum param, ALint* values ) ;
-FUNCTION: void alGenSources ( ALsizei n, ALuint* sources ) ;
-FUNCTION: void alDeleteSources ( ALsizei n, ALuint* sources ) ;
-FUNCTION: ALboolean alIsSource ( ALuint sid ) ;
-FUNCTION: void alSourcef ( ALuint sid, ALenum param, ALfloat value ) ;
-FUNCTION: void alSource3f ( ALuint sid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alSourcei ( ALuint sid, ALenum param, ALint value ) ;
-FUNCTION: void alSource3i ( ALuint sid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
-FUNCTION: void alSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
-FUNCTION: void alGetSourcef ( ALuint sid, ALenum param, ALfloat* value ) ;
-FUNCTION: void alGetSource3f ( ALuint sid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
-FUNCTION: void alGetSourcefv ( ALuint sid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alGetSourcei ( ALuint sid, ALenum param, ALint* value ) ;
-FUNCTION: void alGetSource3i ( ALuint sid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
-FUNCTION: void alGetSourceiv ( ALuint sid, ALenum param, ALint* values ) ;
-FUNCTION: void alSourcePlayv ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourceStopv ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourceRewindv ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourcePausev ( ALsizei ns, ALuint* sids ) ;
-FUNCTION: void alSourcePlay ( ALuint sid ) ;
-FUNCTION: void alSourceStop ( ALuint sid ) ;
-FUNCTION: void alSourceRewind ( ALuint sid ) ;
-FUNCTION: void alSourcePause ( ALuint sid ) ;
-FUNCTION: void alSourceQueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
-FUNCTION: void alSourceUnqueueBuffers ( ALuint sid, ALsizei numEntries, ALuint* bids ) ;
-FUNCTION: void alGenBuffers ( ALsizei n, ALuint* buffers ) ;
-FUNCTION: void alDeleteBuffers ( ALsizei n, ALuint* buffers ) ;
-FUNCTION: ALboolean alIsBuffer ( ALuint bid ) ;
-FUNCTION: void alBufferData ( ALuint bid, ALenum format, void* data, ALsizei size, ALsizei freq ) ;
-FUNCTION: void alBufferf ( ALuint bid, ALenum param, ALfloat value ) ;
-FUNCTION: void alBuffer3f ( ALuint bid, ALenum param, ALfloat value1, ALfloat value2, ALfloat value3 ) ;
-FUNCTION: void alBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alBufferi ( ALuint bid, ALenum param, ALint value ) ;
-FUNCTION: void alBuffer3i ( ALuint bid, ALenum param, ALint value1, ALint value2, ALint value3 ) ;
-FUNCTION: void alBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
-FUNCTION: void alGetBufferf ( ALuint bid, ALenum param, ALfloat* value ) ;
-FUNCTION: void alGetBuffer3f ( ALuint bid, ALenum param, ALfloat* value1, ALfloat* value2, ALfloat* value3) ;
-FUNCTION: void alGetBufferfv ( ALuint bid, ALenum param, ALfloat* values ) ;
-FUNCTION: void alGetBufferi ( ALuint bid, ALenum param, ALint* value ) ;
-FUNCTION: void alGetBuffer3i ( ALuint bid, ALenum param, ALint* value1, ALint* value2, ALint* value3) ;
-FUNCTION: void alGetBufferiv ( ALuint bid, ALenum param, ALint* values ) ;
-FUNCTION: void alDopplerFactor ( ALfloat value ) ;
-FUNCTION: void alDopplerVelocity ( ALfloat value ) ;
-FUNCTION: void alSpeedOfSound ( ALfloat value ) ;
-FUNCTION: void alDistanceModel ( ALenum distanceModel ) ;
-
-LIBRARY: alut
-
-CONSTANT: ALUT_API_MAJOR_VERSION 1
-CONSTANT: ALUT_API_MINOR_VERSION 1
-CONSTANT: ALUT_ERROR_NO_ERROR 0
-CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
-CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
-CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
-CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
-CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
-CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
-CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
-CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
-CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
-CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
-CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
-CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
-CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
-CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
-CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
-CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
-CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
-CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
-CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
-CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
-CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
-CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
-CONSTANT: ALUT_LOADER_BUFFER HEX: 300
-CONSTANT: ALUT_LOADER_MEMORY HEX: 301
-
-FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
-FUNCTION: ALboolean alutExit ( ) ;
-FUNCTION: ALenum alutGetError ( ) ;
-FUNCTION: char* alutGetErrorString ( ALenum error ) ;
-FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
-FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
-FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
-FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
-FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
-FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
-FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
-FUNCTION: ALint alutGetMajorVersion ( ) ;
-FUNCTION: ALint alutGetMinorVersion ( ) ;
-FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
-
-FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
-
-SYMBOL: init
-
-: init-openal ( -- )
- init get-global expired? [
- f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
- 1337 <alien> init set-global
- ] when ;
-
-: exit-openal ( -- )
- init get-global expired? [
- alutExit 0 = [ "Could not close OpenAL" throw ] when
- f init set-global
- ] unless ;
-
-: <uint-array> ( n -- byte-array ) "ALuint" <c-array> ;
-
-: gen-sources ( size -- seq )
- dup <uint-array> 2dup underlying>> alGenSources swap ;
-
-: gen-buffers ( size -- seq )
- dup <uint-array> 2dup underlying>> alGenBuffers swap ;
-
-: gen-buffer ( -- buffer ) 1 gen-buffers first ;
-
-: create-buffer-from-file ( filename -- buffer )
- alutCreateBufferFromFile dup AL_NONE = [
- "create-buffer-from-file failed" throw
- ] when ;
-
-os macosx? "openal.macosx" "openal.other" ? require
-
-: create-buffer-from-wav ( filename -- buffer )
- gen-buffer dup rot load-wav-file
- [ alBufferData ] 4keep alutUnloadWAV ;
-
-: queue-buffers ( source buffers -- )
- [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ;
-
-: queue-buffer ( source buffer -- )
- 1array queue-buffers ;
-
-: set-source-param ( source param value -- )
- alSourcei ;
-
-: get-source-param ( source param -- value )
- 0 <uint> dup [ alGetSourcei ] dip *uint ;
-
-: set-buffer-param ( source param value -- )
- alBufferi ;
-
-: get-buffer-param ( source param -- value )
- 0 <uint> dup [ alGetBufferi ] dip *uint ;
-
-: source-play ( source -- ) alSourcePlay ;
-
-: source-stop ( source -- ) alSourceStop ;
-
-: check-error ( -- )
- alGetError dup ALUT_ERROR_NO_ERROR = [
- drop
- ] [
- alGetString throw
- ] if ;
-
-: source-playing? ( source -- bool )
- AL_SOURCE_STATE get-source-param AL_PLAYING = ;
+++ /dev/null
-Chris Double
+++ /dev/null
-! 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 ;
-IN: openal.other
-
-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 ;
+++ /dev/null
-OpenAL 3D audio library binding
+++ /dev/null
-bindings
-audio
--- /dev/null
+
+USING: kernel arrays strings sequences sequences.deep accessors peg peg.ebnf
+ newfx ;
+
+IN: shell.parser
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+TUPLE: basic-expr command stdin stdout background ;
+TUPLE: pipeline-expr commands stdin stdout background ;
+TUPLE: single-quoted-expr expr ;
+TUPLE: double-quoted-expr expr ;
+TUPLE: back-quoted-expr expr ;
+TUPLE: glob-expr expr ;
+TUPLE: variable-expr expr ;
+TUPLE: factor-expr expr ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ast>basic-expr ( ast -- obj ) first4 basic-expr boa ;
+
+: ast>pipeline-expr ( ast -- obj )
+ pipeline-expr new
+ over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
+ over 2nd >>stdin
+ over 6th >>stdout
+ swap 7th >>background ;
+
+: ast>single-quoted-expr ( ast -- obj )
+ 2nd >string single-quoted-expr boa ;
+
+: ast>double-quoted-expr ( ast -- obj )
+ 2nd >string double-quoted-expr boa ;
+
+: ast>back-quoted-expr ( ast -- obj )
+ 2nd >string back-quoted-expr boa ;
+
+: ast>glob-expr ( ast -- obj ) flatten concat glob-expr boa ;
+
+: ast>variable-expr ( ast -- obj ) 2nd variable-expr boa ;
+
+: ast>factor-expr ( ast -- obj ) 2nd >string factor-expr boa ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+EBNF: expr
+
+space = " "
+
+tab = "\t"
+
+white = (space | tab)
+
+_ = (white)* => [[ drop ignore ]]
+
+sq = "'"
+dq = '"'
+bq = "`"
+
+single-quoted = sq (!(sq) .)* sq => [[ ast>single-quoted-expr ]]
+double-quoted = dq (!(dq) .)* dq => [[ ast>double-quoted-expr ]]
+back-quoted = bq (!(bq) .)* bq => [[ ast>back-quoted-expr ]]
+
+factor = "$(" (!(")") .)* ")" => [[ ast>factor-expr ]]
+
+variable = "$" other => [[ ast>variable-expr ]]
+
+glob-char = ("*" | "?")
+
+non-glob-char = !(glob-char | white) .
+
+glob-beginning-string = (non-glob-char)* => [[ >string ]]
+
+glob-rest-string = (non-glob-char)+ => [[ >string ]]
+
+glob = glob-beginning-string glob-char (glob-rest-string | glob-char)* => [[ ast>glob-expr ]]
+
+other = (!(white | "&" | ">" | ">>" | "<" | "|") .)+ => [[ >string ]]
+
+element = (single-quoted | double-quoted | back-quoted | factor | variable | glob | other)
+
+command = (element _)+
+
+to-file = ">" _ other => [[ second ]]
+in-file = "<" _ other => [[ second ]]
+ap-file = ">>" _ other => [[ second ]]
+
+basic = _ command _ (in-file)? _ (to-file | ap-file)? _ ("&")? => [[ ast>basic-expr ]]
+
+pipeline = _ command _ (in-file)? _ "|" _ (command _ "|" _)* command _ (to-file | ap-file)? _ ("&")? => [[ ast>pipeline-expr ]]
+
+submission = (pipeline | basic)
+
+;EBNF
\ No newline at end of file
--- /dev/null
+USING: kernel parser words continuations namespaces debugger
+sequences combinators splitting prettyprint system io io.files
+io.pathnames io.launcher io.directories io.encodings.utf8 io.pipes
+sequences.deep accessors multi-methods newfx shell.parser
+combinators.short-circuit eval environment ;
+IN: shell
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: cd ( args -- )
+ dup empty?
+ [ drop home set-current-directory ]
+ [ first set-current-directory ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pwd ( args -- )
+ drop
+ current-directory get
+ print ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: swords ( -- seq ) { "cd" "pwd" } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+GENERIC: expand ( expr -- expr )
+
+METHOD: expand { single-quoted-expr } expr>> ;
+
+METHOD: expand { double-quoted-expr } expr>> ;
+
+METHOD: expand { variable-expr } expr>> os-env ;
+
+METHOD: expand { glob-expr }
+ expr>>
+ dup "*" =
+ [ drop current-directory get directory-files ]
+ [ ]
+ if ;
+
+METHOD: expand { factor-expr } expr>> eval>string ;
+
+DEFER: expansion
+
+METHOD: expand { back-quoted-expr }
+ expr>>
+ expr
+ command>>
+ expansion
+ utf8 <process-stream>
+ contents
+ " \n" split
+ "" remove ;
+
+METHOD: expand { object } ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: expansion ( command -- command ) [ expand ] map flatten ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-sword ( basic-expr -- )
+ command>> expansion unclip "shell" lookup execute( arguments -- ) ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: run-foreground ( process -- )
+ [ try-process ] [ print-error drop ] recover ;
+
+: run-background ( process -- ) run-detached drop ;
+
+: run-basic-expr ( basic-expr -- )
+ <process>
+ over command>> expansion >>command
+ over stdin>> >>stdin
+ over stdout>> >>stdout
+ swap background>>
+ [ run-background ]
+ [ run-foreground ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: basic-chant ( basic-expr -- )
+ dup command>> first swords member-of?
+ [ run-sword ]
+ [ run-basic-expr ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: pipeline-chant ( pipeline-chant -- ) commands>> run-pipeline drop ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: chant ( obj -- )
+ dup basic-expr?
+ [ basic-chant ]
+ [ pipeline-chant ]
+ if ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: prompt ( -- )
+ current-directory get write
+ " $ " write
+ flush ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+DEFER: shell
+
+: handle ( input -- )
+ {
+ { [ dup f = ] [ drop ] }
+ { [ dup "exit" = ] [ drop ] }
+ { [ dup "" = ] [ drop shell ] }
+ { [ dup expr ] [ expr chant shell ] }
+ { [ t ] [ drop "ix: ignoring input" print shell ] }
+ }
+ cond ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: shell ( -- )
+ prompt
+ readln
+ handle ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: ix ( -- ) shell ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MAIN: ix
+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! 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 ;
-IN: synth.buffers
-
-TUPLE: buffer sample-freq 8bit? id ;
-
-: <buffer> ( sample-freq 8bit? -- buffer )
- f buffer boa ;
-
-TUPLE: mono-buffer < buffer data ;
-
-: <mono-buffer> ( sample-freq 8bit? -- buffer )
- f f mono-buffer boa ;
-
-: <8bit-mono-buffer> ( sample-freq -- buffer ) t <mono-buffer> ;
-: <16bit-mono-buffer> ( sample-freq -- buffer ) f <mono-buffer> ;
-
-TUPLE: stereo-buffer < buffer left-data right-data ;
-
-: <stereo-buffer> ( sample-freq 8bit? -- buffer )
- f f f stereo-buffer boa ;
-
-: <8bit-stereo-buffer> ( sample-freq -- buffer ) t <stereo-buffer> ;
-: <16bit-stereo-buffer> ( sample-freq -- buffer ) f <stereo-buffer> ;
-
-PREDICATE: 8bit-buffer < buffer 8bit?>> ;
-PREDICATE: 16bit-buffer < buffer 8bit?>> not ;
-INTERSECTION: 8bit-mono-buffer 8bit-buffer mono-buffer ;
-INTERSECTION: 16bit-mono-buffer 16bit-buffer mono-buffer ;
-INTERSECTION: 8bit-stereo-buffer 8bit-buffer stereo-buffer ;
-INTERSECTION: 16bit-stereo-buffer 16bit-buffer stereo-buffer ;
-
-GENERIC: buffer-format ( buffer -- format )
-M: 8bit-mono-buffer buffer-format drop AL_FORMAT_MONO8 ;
-M: 16bit-mono-buffer buffer-format drop AL_FORMAT_MONO16 ;
-M: 8bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO8 ;
-M: 16bit-stereo-buffer buffer-format drop AL_FORMAT_STEREO16 ;
-
-: 8bit-buffer-data ( seq -- data size )
- [ 128 * >integer 128 + ] uchar-array{ } map-as [ underlying>> ] [ length ] bi ;
-
-: 16bit-buffer-data ( seq -- data size )
- [ 32768 * >integer ] short-array{ } map-as [ underlying>> ] [ byte-length ] bi ;
-
-: stereo-data ( stereo-buffer -- left right )
- [ left-data>> ] [ right-data>> ] bi@ ;
-
-: interleaved-stereo-data ( stereo-buffer -- data )
- stereo-data <2merged> ;
-
-GENERIC: buffer-data ( buffer -- data size )
-M: 8bit-mono-buffer buffer-data data>> 8bit-buffer-data ;
-M: 16bit-mono-buffer buffer-data data>> 16bit-buffer-data ;
-M: 8bit-stereo-buffer buffer-data
- interleaved-stereo-data 8bit-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 ;
-
-: send-buffer ( buffer -- buffer )
- {
- [ gen-buffer dup [ >>id ] dip ]
- [ buffer-format ]
- [ buffer-data ]
- [ sample-freq>> alBufferData ]
- } cleave ;
-
-: ?send-buffer ( buffer -- buffer )
- dup id>> [ send-buffer ] unless ;
-
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel namespaces make openal sequences
-synth synth.buffers ;
-IN: synth.example
-
-: play-sine-wave ( freq seconds sample-freq -- )
- init-openal
- <16bit-mono-buffer> >sine-wave-buffer send-buffer id>>
- 1 gen-sources first
- [ AL_BUFFER rot set-source-param ] [ source-play ] bi
- check-error ;
-
-: test-instrument1 ( -- harmonics )
- [
- 1 0.5 <harmonic> ,
- 2 0.125 <harmonic> ,
- 3 0.0625 <harmonic> ,
- 4 0.03125 <harmonic> ,
- ] { } make ;
-
-: test-instrument2 ( -- harmonics )
- [
- 1 0.25 <harmonic> ,
- 2 0.25 <harmonic> ,
- 3 0.25 <harmonic> ,
- 4 0.25 <harmonic> ,
- ] { } make ;
-
-: sine-instrument ( -- harmonics )
- 1 1 <harmonic> 1array ;
-
-: test-note-buffer ( note -- )
- init-openal
- test-instrument2 swap cd-sample-freq <16bit-mono-buffer>
- >note send-buffer id>>
- 1 gen-sources first [ swap queue-buffer ] [ source-play ] bi
- check-error ;
+++ /dev/null
-Simple sound synthesis using OpenAL.
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
-IN: synth
-
-MEMO: single-sine-wave ( samples/wave -- seq )
- pi 2 * over / [ * sin ] curry map ;
-
-: (sine-wave) ( samples/wave n-samples -- seq )
- [ single-sine-wave ] dip <repeating> ;
-
-: sine-wave ( sample-freq freq seconds -- seq )
- pick * >integer [ /i ] dip (sine-wave) ;
-
-: >sine-wave-buffer ( freq seconds buffer -- buffer )
- [ sample-freq>> -rot sine-wave ] keep swap >>data ;
-
-: >silent-buffer ( seconds buffer -- buffer )
- tuck sample-freq>> * >integer 0 <repetition> >>data ;
-
-TUPLE: harmonic n amplitude ;
-C: <harmonic> harmonic
-
-TUPLE: note hz secs ;
-C: <note> note
-
-: harmonic-freq ( note harmonic -- freq )
- n>> swap hz>> * ;
-
-:: note-harmonic-data ( harmonic note buffer -- data )
- buffer sample-freq>> note harmonic harmonic-freq note secs>> sine-wave
- harmonic amplitude>> <scaled> ;
-
-: >note ( harmonics note buffer -- buffer )
- dup -roll [ note-harmonic-data ] 2curry map <summed> >>data ;
-
--- /dev/null
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations ui.gadgets
+images strings ui.gadgets.worlds ;
+IN: ui.offscreen
+
+HELP: <offscreen-world>
+{ $values
+ { "gadget" gadget } { "title" string } { "status" "a boolean" }
+ { "world" offscreen-world }
+}
+{ $description "Constructs an " { $link offscreen-world } " gadget with " { $snippet "gadget" } " as its only child. Generally you should use " { $link open-offscreen } " or " { $link do-offscreen } " instead of calling this word directly." } ;
+
+HELP: close-offscreen
+{ $values
+ { "world" offscreen-world }
+}
+{ $description "Releases the resources used by the rendering buffer for " { $snippet "world" } "." } ;
+
+HELP: do-offscreen
+{ $values
+ { "gadget" gadget } { "quot" quotation }
+}
+{ $description "Constructs an " { $link offscreen-world } " around " { $snippet "gadget" } " with " { $link open-offscreen } ", calls " { $snippet "quotation" } " with the world on the top of the stack, and cleans up the world with " { $link close-offscreen } " at the end of " { $snippet "quotation" } "." } ;
+
+HELP: gadget>bitmap
+{ $values
+ { "gadget" gadget }
+ { "image" image }
+}
+{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ;
+
+HELP: offscreen-world
+{ $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
+
+HELP: offscreen-world>bitmap
+{ $values
+ { "world" offscreen-world }
+ { "image" image }
+}
+{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ;
+
+HELP: open-offscreen
+{ $values
+ { "gadget" gadget }
+ { "world" offscreen-world }
+}
+{ $description "Creates and sets up an " { $link offscreen-world } " with " { $snippet "gadget" } " as its only child." } ;
+
+{ offscreen-world open-offscreen close-offscreen do-offscreen } related-words
+
+ARTICLE: "ui.offscreen" "Offscreen UI rendering"
+"The " { $vocab-link "ui.offscreen" } " provides words for rendering gadgets to an offscreen buffer so that bitmaps can be made from their contents."
+{ $subsection offscreen-world }
+"Opening gadgets offscreen:"
+{ $subsection open-offscreen }
+{ $subsection close-offscreen }
+{ $subsection do-offscreen }
+"Creating bitmaps from offscreen buffers:"
+{ $subsection offscreen-world>bitmap }
+{ $subsection gadget>bitmap } ;
+
+ABOUT: "ui.offscreen"
--- /dev/null
+! (c) 2008 Joe Groff, see license for details
+USING: accessors alien.c-types continuations images kernel math
+sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.private ui ui.backend destructors locals ;
+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 ;
+
+M: offscreen-world graft*
+ (open-offscreen-buffer) ;
+
+M: offscreen-world ungraft*
+ [ (ungraft-world) ]
+ [ handle>> (close-offscreen-buffer) ]
+ [ reset-world ] tri ;
+
+: open-offscreen ( gadget -- world )
+ "" f <offscreen-world>
+ [ open-world-window ] [ relayout-1 ] [ ] tri
+ notify-queued ;
+
+: close-offscreen ( world -- )
+ ungraft notify-queued ;
+
+:: bgrx>bitmap ( alien w h -- image )
+ <image>
+ { w h } >>dim
+ alien w h * 4 * memory>byte-array >>bitmap
+ BGRX >>component-order ;
+
+: offscreen-world>bitmap ( world -- image )
+ offscreen-pixels bgrx>bitmap ;
+
+: do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
+ [ open-offscreen ] dip
+ over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
+
+: gadget>bitmap ( gadget -- image )
+ [ offscreen-world>bitmap ] do-offscreen ;
--- /dev/null
+Offscreen world gadgets for rendering UI elements to bitmaps
--- /dev/null
+ui
+graphics
-PLAF_DLL_OBJS += vm/cpu-arm.o
+PLAF_DLL_OBJS += vmpp/cpu-arm.o
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 \
include vm/Config.unix
PLAF_DLL_OBJS += vm/os-genunix.o vm/os-openbsd.o
CC = egcc
+CPP = eg++
CFLAGS += -export-dynamic
LIBS = -L/usr/local/lib/ -lm $(X11_UI_LIBS) -lz -lssl -lcrypto -lpthread
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
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
+++ /dev/null
-#include "master.h"
-
-/* gets the address of an object representing a C pointer */
-void *alien_offset(CELL object)
-{
- 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)
-{
- F_ALIEN *alien;
-
- switch(type_of(object))
- {
- 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;
- case F_TYPE:
- return NULL;
- default:
- type_error(ALIEN_TYPE,object);
- 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)
-{
- REGISTER_ROOT(delegate);
- F_ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(F_ALIEN));
- UNREGISTER_ROOT(delegate);
-
- if(type_of(delegate) == ALIEN_TYPE)
- {
- F_ALIEN *delegate_alien = untag_object(delegate);
- displacement += delegate_alien->displacement;
- alien->alien = delegate_alien->alien;
- }
- else
- alien->alien = delegate;
-
- alien->displacement = displacement;
- alien->expired = F;
- return tag_object(alien);
-}
-
-/* make an alien and push */
-void box_alien(void *ptr)
-{
- if(ptr == NULL)
- dpush(F);
- else
- dpush(allot_alien(F,(CELL)ptr));
-}
-
-/* make an alien pointing at an offset of another alien */
-void primitive_displaced_alien(void)
-{
- CELL alien = dpop();
- CELL displacement = to_cell(dpop());
-
- if(alien == F && displacement == 0)
- dpush(F);
- else
- {
- switch(type_of(alien))
- {
- case BYTE_ARRAY_TYPE:
- case ALIEN_TYPE:
- case F_TYPE:
- dpush(allot_alien(alien,displacement));
- break;
- default:
- type_error(ALIEN_TYPE,alien);
- break;
- }
- }
-}
-
-/* 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)
-{
- box_unsigned_cell((CELL)pinned_alien_offset(dpop()));
-}
-
-/* pop ( alien n ) from datastack, return alien's address plus n */
-INLINE void *alien_pointer(void)
-{
- F_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) \
- { \
- boxer(*(type*)alien_pointer()); \
- } \
- void primitive_set_alien_##name(void) \
- { \
- type* ptr = 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_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)
-DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
-DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
-DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
-DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
-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)
-
-/* for FFI calls passing structs by value */
-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)
-{
- F_BYTE_ARRAY *array = allot_byte_array(size);
- memcpy(array + 1,src,size);
- dpush(tag_object(array));
-}
-
-/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
-void box_small_struct(CELL x, CELL y, CELL size)
-{
- 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)
-{
- CELL data[4];
- data[0] = x1;
- data[1] = x2;
- data[2] = x3;
- data[3] = x4;
- box_value_struct(data,size);
-}
-
-/* open a native library and push a handle */
-void primitive_dlopen(void)
-{
- 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);
- }
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* gets the address of an object representing a C pointer, with the
+intention of storing the pointer across code which may potentially GC. */
+char *pinned_alien_offset(cell obj)
+{
+ switch(tagged<object>(obj).type())
+ {
+ case ALIEN_TYPE:
+ {
+ 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,obj);
+ return NULL; /* can't happen */
+ }
+}
+
+/* make an alien */
+cell allot_alien(cell delegate_, cell displacement)
+{
+ gc_root<object> delegate(delegate_);
+ gc_root<alien> new_alien(allot<alien>(sizeof(alien)));
+
+ if(delegate.type_p(ALIEN_TYPE))
+ {
+ tagged<alien> delegate_alien = delegate.as<alien>();
+ displacement += delegate_alien->displacement;
+ new_alien->alien = delegate_alien->alien;
+ }
+ else
+ new_alien->alien = delegate.value();
+
+ new_alien->displacement = displacement;
+ new_alien->expired = F;
+
+ return new_alien.value();
+}
+
+/* make an alien pointing at an offset of another alien */
+PRIMITIVE(displaced_alien)
+{
+ cell alien = dpop();
+ cell displacement = to_cell(dpop());
+
+ if(alien == F && displacement == 0)
+ dpush(F);
+ else
+ {
+ switch(tagged<object>(alien).type())
+ {
+ case BYTE_ARRAY_TYPE:
+ case ALIEN_TYPE:
+ case F_TYPE:
+ dpush(allot_alien(alien,displacement));
+ break;
+ default:
+ type_error(ALIEN_TYPE,alien);
+ break;
+ }
+ }
+}
+
+/* address of an object representing a C pointer. Explicitly throw an error
+if the object is a byte array, as a sanity check. */
+PRIMITIVE(alien_address)
+{
+ box_unsigned_cell((cell)pinned_alien_offset(dpop()));
+}
+
+/* pop ( alien n ) from datastack, return alien's address plus n */
+static void *alien_pointer(void)
+{
+ 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) \
+ PRIMITIVE(alien_##name) \
+ { \
+ boxer(*(type*)alien_pointer()); \
+ } \
+ PRIMITIVE(set_alien_##name) \
+ { \
+ type *ptr = (type *)alien_pointer(); \
+ type value = to(dpop()); \
+ *ptr = value; \
+ }
+
+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)
+DEFINE_ALIEN_ACCESSOR(unsigned_4,u32,box_unsigned_4,to_cell)
+DEFINE_ALIEN_ACCESSOR(signed_2,s16,box_signed_2,to_fixnum)
+DEFINE_ALIEN_ACCESSOR(unsigned_2,u16,box_unsigned_2,to_cell)
+DEFINE_ALIEN_ACCESSOR(signed_1,s8,box_signed_1,to_fixnum)
+DEFINE_ALIEN_ACCESSOR(unsigned_1,u8,box_unsigned_1,to_cell)
+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 */
+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 */
+VM_C_API void box_value_struct(void *src, cell size)
+{
+ 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. */
+VM_C_API void box_small_struct(cell x, cell y, cell size)
+{
+ cell data[2];
+ data[0] = x;
+ data[1] = y;
+ box_value_struct(data,size);
+}
+
+/* On OS X/PPC, complex numbers are returned in registers. */
+VM_C_API void box_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
+{
+ cell data[4];
+ data[0] = x1;
+ data[1] = x2;
+ data[2] = x3;
+ data[3] = x4;
+ box_value_struct(data,size);
+}
+
+}
+++ /dev/null
-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);
--- /dev/null
+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);
+
+}
--- /dev/null
+#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);
+}
+
+}
--- /dev/null
+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();
+};
+
+}
+++ /dev/null
-/* :tabSize=2:indentSize=2:noTabs=true:
-
-Copyright (C) 1989-94 Massachusetts Institute of Technology
-Portions copyright (C) 2004-2008 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. */
-
-/* Changes for Scheme 48:
- * - Converted to ANSI.
- * - Added bitwise operations.
- * - Added s48 to the beginning of all externally visible names.
- * - Cached the bignum representations of -1, 0, and 1.
- */
-
-/* Changes for Factor:
- * - Adapt bignumint.h for Factor memory manager
- * - Add more bignum <-> C type conversions
- * - Remove unused functions
- * - Add local variable GC root recording
- * - Remove s48 prefix from function names
- * - Various fixes for Win64
- */
-
-#include "master.h"
-#include <limits.h>
-#include <stdio.h>
-#include <stdlib.h> /* abort */
-#include <math.h>
-
-/* Exports */
-
-int
-bignum_equal_p(bignum_type x, bignum_type y)
-{
- return
- ((BIGNUM_ZERO_P (x))
- ? (BIGNUM_ZERO_P (y))
- : ((! (BIGNUM_ZERO_P (y)))
- && ((BIGNUM_NEGATIVE_P (x))
- ? (BIGNUM_NEGATIVE_P (y))
- : (! (BIGNUM_NEGATIVE_P (y))))
- && (bignum_equal_p_unsigned (x, y))));
-}
-
-enum bignum_comparison
-bignum_compare(bignum_type x, bignum_type y)
-{
- return
- ((BIGNUM_ZERO_P (x))
- ? ((BIGNUM_ZERO_P (y))
- ? bignum_comparison_equal
- : (BIGNUM_NEGATIVE_P (y))
- ? bignum_comparison_greater
- : bignum_comparison_less)
- : (BIGNUM_ZERO_P (y))
- ? ((BIGNUM_NEGATIVE_P (x))
- ? bignum_comparison_less
- : bignum_comparison_greater)
- : (BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_compare_unsigned (y, x))
- : (bignum_comparison_less))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_comparison_greater)
- : (bignum_compare_unsigned (x, y))));
-}
-
-/* allocates memory */
-bignum_type
-bignum_add(bignum_type x, bignum_type y)
-{
- return
- ((BIGNUM_ZERO_P (x))
- ? (y)
- : (BIGNUM_ZERO_P (y))
- ? (x)
- : ((BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_add_unsigned (x, y, 1))
- : (bignum_subtract_unsigned (y, x)))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_subtract_unsigned (x, y))
- : (bignum_add_unsigned (x, y, 0)))));
-}
-
-/* allocates memory */
-bignum_type
-bignum_subtract(bignum_type x, bignum_type y)
-{
- return
- ((BIGNUM_ZERO_P (x))
- ? ((BIGNUM_ZERO_P (y))
- ? (y)
- : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
- : ((BIGNUM_ZERO_P (y))
- ? (x)
- : ((BIGNUM_NEGATIVE_P (x))
- ? ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_subtract_unsigned (y, x))
- : (bignum_add_unsigned (x, y, 1)))
- : ((BIGNUM_NEGATIVE_P (y))
- ? (bignum_add_unsigned (x, y, 0))
- : (bignum_subtract_unsigned (x, y))))));
-}
-
-/* allocates memory */
-bignum_type
-bignum_multiply(bignum_type x, bignum_type y)
-{
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
- int negative_p =
- ((BIGNUM_NEGATIVE_P (x))
- ? (! (BIGNUM_NEGATIVE_P (y)))
- : (BIGNUM_NEGATIVE_P (y)));
- if (BIGNUM_ZERO_P (x))
- return (x);
- if (BIGNUM_ZERO_P (y))
- return (y);
- if (x_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (x, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (y, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
- }
- if (y_length == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (y, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (x, negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
- }
- return (bignum_multiply_unsigned (x, y, negative_p));
-}
-
-/* allocates memory */
-void
-bignum_divide(bignum_type numerator, bignum_type denominator,
- bignum_type * quotient, bignum_type * remainder)
-{
- if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error(NULL);
- return;
- }
- if (BIGNUM_ZERO_P (numerator))
- {
- (*quotient) = numerator;
- (*remainder) = numerator;
- }
- else
- {
- int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- {
- (*quotient) = (BIGNUM_ONE (q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- case bignum_comparison_less:
- {
- (*quotient) = (BIGNUM_ZERO ());
- (*remainder) = numerator;
- break;
- }
- case bignum_comparison_greater:
- {
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- {
- (*quotient) =
- (bignum_maybe_new_sign (numerator, q_negative_p));
- (*remainder) = (BIGNUM_ZERO ());
- break;
- }
- else if (digit < BIGNUM_RADIX_ROOT)
- {
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- else
- {
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- quotient, remainder,
- q_negative_p, r_negative_p);
- break;
- }
- }
- }
-}
-
-/* allocates memory */
-bignum_type
-bignum_quotient(bignum_type numerator, bignum_type denominator)
-{
- if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error(NULL);
- return (BIGNUM_OUT_OF_BAND);
- }
- if (BIGNUM_ZERO_P (numerator))
- return numerator;
- {
- int q_negative_p =
- ((BIGNUM_NEGATIVE_P (denominator))
- ? (! (BIGNUM_NEGATIVE_P (numerator)))
- : (BIGNUM_NEGATIVE_P (numerator)));
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ONE (q_negative_p));
- case bignum_comparison_less:
- return (BIGNUM_ZERO ());
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
- {
- bignum_type quotient;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (bignum_maybe_new_sign (numerator, q_negative_p));
- if (digit < BIGNUM_RADIX_ROOT)
- bignum_divide_unsigned_small_denominator
- (numerator, digit,
- ("ient), ((bignum_type *) 0),
- q_negative_p, 0);
- else
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ("ient), ((bignum_type *) 0),
- q_negative_p, 0);
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ("ient), ((bignum_type *) 0),
- q_negative_p, 0);
- return (quotient);
- }
- }
- }
-}
-
-/* allocates memory */
-bignum_type
-bignum_remainder(bignum_type numerator, bignum_type denominator)
-{
- if (BIGNUM_ZERO_P (denominator))
- {
- divide_by_zero_error(NULL);
- return (BIGNUM_OUT_OF_BAND);
- }
- if (BIGNUM_ZERO_P (numerator))
- return numerator;
- switch (bignum_compare_unsigned (numerator, denominator))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- return numerator;
- case bignum_comparison_greater:
- default: /* to appease gcc -Wall */
- {
- bignum_type remainder;
- if ((BIGNUM_LENGTH (denominator)) == 1)
- {
- bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
- if (digit == 1)
- return (BIGNUM_ZERO ());
- if (digit < BIGNUM_RADIX_ROOT)
- return
- (bignum_remainder_unsigned_small_denominator
- (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
- bignum_divide_unsigned_medium_denominator
- (numerator, digit,
- ((bignum_type *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- }
- else
- bignum_divide_unsigned_large_denominator
- (numerator, denominator,
- ((bignum_type *) 0), (&remainder),
- 0, (BIGNUM_NEGATIVE_P (numerator)));
- return (remainder);
- }
- }
-}
-
-#define FOO_TO_BIGNUM(name,type,utype) \
- bignum_type name##_to_bignum(type n) \
- { \
- int negative_p; \
- bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
- bignum_digit_type * end_digits = result_digits; \
- /* 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)); \
- { \
- utype accumulator = ((negative_p = (n < 0)) ? (-n) : n); \
- do \
- { \
- (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
- accumulator >>= BIGNUM_DIGIT_LENGTH; \
- } \
- while (accumulator != 0); \
- } \
- { \
- bignum_type 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)); \
- while (scan_digits < end_digits) \
- (*scan_result++) = (*scan_digits++); \
- return (result); \
- } \
- }
-
-/* all below allocate memory */
-FOO_TO_BIGNUM(cell,CELL,CELL)
-FOO_TO_BIGNUM(fixnum,F_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) \
- { \
- if (BIGNUM_ZERO_P (bignum)) \
- return (0); \
- { \
- utype accumulator = 0; \
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
- while (start < scan) \
- accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
- } \
- }
-
-/* all of the below allocate memory */
-BIGNUM_TO_FOO(cell,CELL,CELL);
-BIGNUM_TO_FOO(fixnum,F_FIXNUM,CELL);
-BIGNUM_TO_FOO(long_long,s64,u64)
-BIGNUM_TO_FOO(ulong_long,u64,u64)
-
-double
-bignum_to_double(bignum_type bignum)
-{
- if (BIGNUM_ZERO_P (bignum))
- return (0);
- {
- double accumulator = 0;
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- while (start < scan)
- accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
- return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
- }
-}
-
-#define DTB_WRITE_DIGIT(factor) \
-{ \
- significand *= (factor); \
- digit = ((bignum_digit_type) significand); \
- (*--scan) = digit; \
- significand -= ((double) digit); \
-}
-
-/* allocates memory */
-bignum_type
-double_to_bignum(double x)
-{
- if (x == 1.0/0.0 || x == -1.0/0.0 || x != x) return (BIGNUM_ZERO ());
- int exponent;
- double significand = (frexp (x, (&exponent)));
- if (exponent <= 0) return (BIGNUM_ZERO ());
- if (exponent == 1) return (BIGNUM_ONE (x < 0));
- if (significand < 0) significand = (-significand);
- {
- bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
- bignum_type 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);
- while (start < scan)
- {
- if (significand == 0)
- {
- while (start < scan)
- (*--scan) = 0;
- break;
- }
- DTB_WRITE_DIGIT (BIGNUM_RADIX);
- }
- return (result);
- }
-}
-
-#undef DTB_WRITE_DIGIT
-
-/* Comparisons */
-
-int
-bignum_equal_p_unsigned(bignum_type x, bignum_type y)
-{
- bignum_length_type length = (BIGNUM_LENGTH (x));
- if (length != (BIGNUM_LENGTH (y)))
- return (0);
- else
- {
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_x = (scan_x + length);
- while (scan_x < end_x)
- if ((*scan_x++) != (*scan_y++))
- return (0);
- return (1);
- }
-}
-
-enum bignum_comparison
-bignum_compare_unsigned(bignum_type x, bignum_type y)
-{
- bignum_length_type x_length = (BIGNUM_LENGTH (x));
- bignum_length_type y_length = (BIGNUM_LENGTH (y));
- if (x_length < y_length)
- return (bignum_comparison_less);
- if (x_length > y_length)
- return (bignum_comparison_greater);
- {
- bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_x = (start_x + x_length);
- bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
- while (start_x < scan_x)
- {
- bignum_digit_type digit_x = (*--scan_x);
- bignum_digit_type digit_y = (*--scan_y);
- if (digit_x < digit_y)
- return (bignum_comparison_less);
- if (digit_x > digit_y)
- return (bignum_comparison_greater);
- }
- }
- return (bignum_comparison_equal);
-}
-
-/* Addition */
-
-/* allocates memory */
-bignum_type
-bignum_add_unsigned(bignum_type x, bignum_type y, int negative_p)
-{
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum_type 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_digit_type sum;
- bignum_digit_type carry = 0;
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
- {
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
- while (scan_y < end_y)
- {
- sum = ((*scan_x++) + (*scan_y++) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- }
- else
- {
- (*scan_r++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
- }
- }
- {
- bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
- if (carry != 0)
- while (scan_x < end_x)
- {
- sum = ((*scan_x++) + 1);
- if (sum < BIGNUM_RADIX)
- {
- (*scan_r++) = sum;
- carry = 0;
- break;
- }
- else
- (*scan_r++) = (sum - BIGNUM_RADIX);
- }
- while (scan_x < end_x)
- (*scan_r++) = (*scan_x++);
- }
- if (carry != 0)
- {
- (*scan_r) = 1;
- return (r);
- }
- return (bignum_shorten_length (r, x_length));
- }
-}
-
-/* Subtraction */
-
-/* allocates memory */
-bignum_type
-bignum_subtract_unsigned(bignum_type x, bignum_type y)
-{
- int negative_p = 0;
- switch (bignum_compare_unsigned (x, y))
- {
- case bignum_comparison_equal:
- return (BIGNUM_ZERO ());
- case bignum_comparison_less:
- {
- bignum_type z = x;
- x = y;
- y = z;
- }
- negative_p = 1;
- break;
- case bignum_comparison_greater:
- negative_p = 0;
- break;
- }
- {
- 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_digit_type difference;
- bignum_digit_type borrow = 0;
- bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
- bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
- {
- bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
- while (scan_y < end_y)
- {
- difference = (((*scan_x++) - (*scan_y++)) - borrow);
- if (difference < 0)
- {
- (*scan_r++) = (difference + BIGNUM_RADIX);
- borrow = 1;
- }
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- }
- }
- }
- {
- bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
- if (borrow != 0)
- while (scan_x < end_x)
- {
- difference = ((*scan_x++) - borrow);
- if (difference < 0)
- (*scan_r++) = (difference + BIGNUM_RADIX);
- else
- {
- (*scan_r++) = difference;
- borrow = 0;
- break;
- }
- }
- BIGNUM_ASSERT (borrow == 0);
- while (scan_x < end_x)
- (*scan_r++) = (*scan_x++);
- }
- return (bignum_trim (r));
- }
-}
-
-/* Multiplication
- Maximum value for product_low or product_high:
- ((R * R) + (R * (R - 2)) + (R - 1))
- Maximum value for carry: ((R * (R - 1)) + (R - 1))
- where R == BIGNUM_RADIX_ROOT */
-
-/* allocates memory */
-bignum_type
-bignum_multiply_unsigned(bignum_type x, bignum_type y, int negative_p)
-{
- if ((BIGNUM_LENGTH (y)) > (BIGNUM_LENGTH (x)))
- {
- bignum_type z = x;
- x = y;
- y = z;
- }
- {
- bignum_digit_type carry;
- bignum_digit_type y_digit_low;
- bignum_digit_type y_digit_high;
- bignum_digit_type x_digit_low;
- bignum_digit_type x_digit_high;
- bignum_digit_type product_low;
- bignum_digit_type * scan_r;
- bignum_digit_type * scan_y;
- 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 =
- (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);
- bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
- bignum_digit_type * end_y = (start_y + y_length);
- bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
-#define x_digit x_digit_high
-#define y_digit y_digit_high
-#define product_high carry
- while (scan_x < end_x)
- {
- x_digit = (*scan_x++);
- x_digit_low = (HD_LOW (x_digit));
- x_digit_high = (HD_HIGH (x_digit));
- carry = 0;
- scan_y = start_y;
- scan_r = (start_r++);
- while (scan_y < end_y)
- {
- y_digit = (*scan_y++);
- y_digit_low = (HD_LOW (y_digit));
- y_digit_high = (HD_HIGH (y_digit));
- product_low =
- ((*scan_r) +
- (x_digit_low * y_digit_low) +
- (HD_LOW (carry)));
- product_high =
- ((x_digit_high * y_digit_low) +
- (x_digit_low * y_digit_high) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan_r++) =
- (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry =
- ((x_digit_high * y_digit_high) +
- (HD_HIGH (product_high)));
- }
- (*scan_r) += carry;
- }
- return (bignum_trim (r));
-#undef x_digit
-#undef y_digit
-#undef product_high
- }
-}
-
-/* allocates memory */
-bignum_type
-bignum_multiply_unsigned_small_factor(bignum_type x, bignum_digit_type y,
- int negative_p)
-{
- 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_destructive_copy (x, p);
- (BIGNUM_REF (p, length_x)) = 0;
- bignum_destructive_scale_up (p, y);
- return (bignum_trim (p));
-}
-
-void
-bignum_destructive_add(bignum_type bignum, bignum_digit_type n)
-{
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- bignum_digit_type digit;
- digit = ((*scan) + n);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
- while (1)
- {
- digit = ((*scan) + 1);
- if (digit < BIGNUM_RADIX)
- {
- (*scan) = digit;
- return;
- }
- (*scan++) = (digit - BIGNUM_RADIX);
- }
-}
-
-void
-bignum_destructive_scale_up(bignum_type bignum, bignum_digit_type factor)
-{
- bignum_digit_type carry = 0;
- bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
- bignum_digit_type two_digits;
- bignum_digit_type product_low;
-#define product_high carry
- bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
- BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
- while (scan < end)
- {
- two_digits = (*scan);
- product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
- product_high =
- ((factor * (HD_HIGH (two_digits))) +
- (HD_HIGH (product_low)) +
- (HD_HIGH (carry)));
- (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
- carry = (HD_HIGH (product_high));
- }
- /* A carry here would be an overflow, i.e. it would not fit.
- Hopefully the callers allocate enough space that this will
- never happen.
- */
- BIGNUM_ASSERT (carry == 0);
- return;
-#undef product_high
-}
-
-/* Division */
-
-/* For help understanding this algorithm, see:
- Knuth, Donald E., "The Art of Computer Programming",
- volume 2, "Seminumerical Algorithms"
- section 4.3.1, "Multiple-Precision Arithmetic". */
-
-/* allocates memory */
-void
-bignum_divide_unsigned_large_denominator(bignum_type numerator,
- bignum_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
- int q_negative_p,
- int r_negative_p)
-{
- 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))
- ? (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);
-
- int shift = 0;
- BIGNUM_ASSERT (length_d > 1);
- {
- bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
- while (v1 < (BIGNUM_RADIX / 2))
- {
- v1 <<= 1;
- shift += 1;
- }
- }
- if (shift == 0)
- {
- bignum_destructive_copy (numerator, u);
- (BIGNUM_REF (u, (length_n - 1))) = 0;
- bignum_divide_unsigned_normalized (u, denominator, q);
- }
- 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_destructive_normalization (numerator, u, shift);
- bignum_destructive_normalization (denominator, v, shift);
- bignum_divide_unsigned_normalized (u, v, q);
- if (remainder != ((bignum_type *) 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))
- (*quotient) = q;
-
- if (remainder != ((bignum_type *) 0))
- (*remainder) = u;
-
- return;
-}
-
-void
-bignum_divide_unsigned_normalized(bignum_type u, bignum_type v, bignum_type q)
-{
- bignum_length_type u_length = (BIGNUM_LENGTH (u));
- bignum_length_type v_length = (BIGNUM_LENGTH (v));
- bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
- bignum_digit_type * u_scan = (u_start + u_length);
- bignum_digit_type * u_scan_limit = (u_start + v_length);
- bignum_digit_type * u_scan_start = (u_scan - v_length);
- bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
- bignum_digit_type * v_end = (v_start + v_length);
- bignum_digit_type * q_scan = NULL;
- bignum_digit_type v1 = (v_end[-1]);
- bignum_digit_type v2 = (v_end[-2]);
- bignum_digit_type ph; /* high half of double-digit product */
- bignum_digit_type pl; /* low half of double-digit product */
- bignum_digit_type guess;
- bignum_digit_type gh; /* high half-digit of guess */
- bignum_digit_type ch; /* high half of double-digit comparand */
- bignum_digit_type v2l = (HD_LOW (v2));
- bignum_digit_type v2h = (HD_HIGH (v2));
- bignum_digit_type cl; /* low half of double-digit comparand */
-#define gl ph /* low half-digit of guess */
-#define uj pl
-#define qj ph
- bignum_digit_type gm; /* memory loc for reference parameter */
- if (q != BIGNUM_OUT_OF_BAND)
- q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
- while (u_scan_limit < u_scan)
- {
- uj = (*--u_scan);
- if (uj != v1)
- {
- /* comparand =
- (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
- guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
- cl = (u_scan[-2]);
- ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
- guess = gm;
- }
- else
- {
- cl = (u_scan[-2]);
- ch = ((u_scan[-1]) + v1);
- guess = (BIGNUM_RADIX - 1);
- }
- while (1)
- {
- /* product = (guess * v2); */
- gl = (HD_LOW (guess));
- gh = (HD_HIGH (guess));
- pl = (v2l * gl);
- ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
- pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
- ph = ((v2h * gh) + (HD_HIGH (ph)));
- /* if (comparand >= product) */
- if ((ch > ph) || ((ch == ph) && (cl >= pl)))
- break;
- guess -= 1;
- /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
- ch += v1;
- /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
- if (ch >= BIGNUM_RADIX)
- break;
- }
- qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
- if (q != BIGNUM_OUT_OF_BAND)
- (*--q_scan) = qj;
- }
- return;
-#undef gl
-#undef uj
-#undef qj
-}
-
-bignum_digit_type
-bignum_divide_subtract(bignum_digit_type * v_start,
- bignum_digit_type * v_end,
- bignum_digit_type guess,
- bignum_digit_type * u_start)
-{
- bignum_digit_type * v_scan = v_start;
- bignum_digit_type * u_scan = u_start;
- bignum_digit_type carry = 0;
- if (guess == 0) return (0);
- {
- bignum_digit_type gl = (HD_LOW (guess));
- bignum_digit_type gh = (HD_HIGH (guess));
- bignum_digit_type v;
- bignum_digit_type pl;
- bignum_digit_type vl;
-#define vh v
-#define ph carry
-#define diff pl
- while (v_scan < v_end)
- {
- v = (*v_scan++);
- vl = (HD_LOW (v));
- vh = (HD_HIGH (v));
- pl = ((vl * gl) + (HD_LOW (carry)));
- ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
- diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
- if (diff < 0)
- {
- (*u_scan++) = (diff + BIGNUM_RADIX);
- carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
- }
- else
- {
- (*u_scan++) = diff;
- carry = ((vh * gh) + (HD_HIGH (ph)));
- }
- }
- if (carry == 0)
- return (guess);
- diff = ((*u_scan) - carry);
- if (diff < 0)
- (*u_scan) = (diff + BIGNUM_RADIX);
- else
- {
- (*u_scan) = diff;
- return (guess);
- }
-#undef vh
-#undef ph
-#undef diff
- }
- /* Subtraction generated carry, implying guess is one too large.
- Add v back in to bring it back down. */
- v_scan = v_start;
- u_scan = u_start;
- carry = 0;
- while (v_scan < v_end)
- {
- bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
- if (sum < BIGNUM_RADIX)
- {
- (*u_scan++) = sum;
- carry = 0;
- }
- else
- {
- (*u_scan++) = (sum - BIGNUM_RADIX);
- carry = 1;
- }
- }
- if (carry == 1)
- {
- bignum_digit_type sum = ((*u_scan) + carry);
- (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
- }
- return (guess - 1);
-}
-
-/* allocates memory */
-void
-bignum_divide_unsigned_medium_denominator(bignum_type numerator,
- bignum_digit_type denominator,
- bignum_type * quotient,
- bignum_type * remainder,
- int q_negative_p,
- int r_negative_p)
-{
- bignum_length_type length_n = (BIGNUM_LENGTH (numerator));
- bignum_length_type length_q;
- bignum_type q;
- int shift = 0;
- /* Because `bignum_digit_divide' requires a normalized denominator. */
- while (denominator < (BIGNUM_RADIX / 2))
- {
- denominator <<= 1;
- shift += 1;
- }
- if (shift == 0)
- {
- 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);
- }
- {
- bignum_digit_type r = 0;
- bignum_digit_type * start = (BIGNUM_START_PTR (q));
- bignum_digit_type * scan = (start + length_q);
- bignum_digit_type qj;
-
- while (start < scan)
- {
- r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
- (*scan) = qj;
- }
-
- q = bignum_trim (q);
-
- if (remainder != ((bignum_type *) 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))
- (*quotient) = q;
- }
- return;
-}
-
-void
-bignum_destructive_normalization(bignum_type source, bignum_type target,
- int shift_left)
-{
- bignum_digit_type digit;
- bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- bignum_digit_type carry = 0;
- bignum_digit_type * scan_target = (BIGNUM_START_PTR (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);
- while (scan_source < end_source)
- {
- digit = (*scan_source++);
- (*scan_target++) = (((digit & mask) << shift_left) | carry);
- carry = (digit >> shift_right);
- }
- if (scan_target < end_target)
- (*scan_target) = carry;
- else
- BIGNUM_ASSERT (carry == 0);
- return;
-}
-
-void
-bignum_destructive_unnormalization(bignum_type 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);
- while (start < scan)
- {
- digit = (*--scan);
- (*scan) = ((digit >> shift_right) | carry);
- carry = ((digit & mask) << shift_left);
- }
- BIGNUM_ASSERT (carry == 0);
- return;
-}
-
-/* This is a reduced version of the division algorithm, applied to the
- case of dividing two bignum digits by one bignum digit. It is
- assumed that the numerator, denominator are normalized. */
-
-#define BDD_STEP(qn, j) \
-{ \
- uj = (u[j]); \
- if (uj != v1) \
- { \
- uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
- guess = (uj_uj1 / v1); \
- comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
- } \
- else \
- { \
- guess = (BIGNUM_RADIX_ROOT - 1); \
- comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
- } \
- while ((guess * v2) > comparand) \
- { \
- guess -= 1; \
- comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
- if (comparand >= BIGNUM_RADIX) \
- break; \
- } \
- qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
-}
-
-bignum_digit_type
-bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
- bignum_digit_type v,
- bignum_digit_type * q) /* return value */
-{
- bignum_digit_type guess;
- bignum_digit_type comparand;
- bignum_digit_type v1 = (HD_HIGH (v));
- bignum_digit_type v2 = (HD_LOW (v));
- bignum_digit_type uj;
- bignum_digit_type uj_uj1;
- bignum_digit_type q1;
- bignum_digit_type q2;
- bignum_digit_type u [4];
- if (uh == 0)
- {
- if (ul < v)
- {
- (*q) = 0;
- return (ul);
- }
- else if (ul == v)
- {
- (*q) = 1;
- return (0);
- }
- }
- (u[0]) = (HD_HIGH (uh));
- (u[1]) = (HD_LOW (uh));
- (u[2]) = (HD_HIGH (ul));
- (u[3]) = (HD_LOW (ul));
- v1 = (HD_HIGH (v));
- v2 = (HD_LOW (v));
- BDD_STEP (q1, 0);
- BDD_STEP (q2, 1);
- (*q) = (HD_CONS (q1, q2));
- return (HD_CONS ((u[2]), (u[3])));
-}
-
-#undef BDD_STEP
-
-#define BDDS_MULSUB(vn, un, carry_in) \
-{ \
- product = ((vn * guess) + carry_in); \
- diff = (un - (HD_LOW (product))); \
- if (diff < 0) \
- { \
- un = (diff + BIGNUM_RADIX_ROOT); \
- carry = ((HD_HIGH (product)) + 1); \
- } \
- else \
- { \
- un = diff; \
- carry = (HD_HIGH (product)); \
- } \
-}
-
-#define BDDS_ADD(vn, un, carry_in) \
-{ \
- sum = (vn + un + carry_in); \
- if (sum < BIGNUM_RADIX_ROOT) \
- { \
- un = sum; \
- carry = 0; \
- } \
- else \
- { \
- un = (sum - BIGNUM_RADIX_ROOT); \
- carry = 1; \
- } \
-}
-
-bignum_digit_type
-bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
- bignum_digit_type guess, bignum_digit_type * u)
-{
- {
- bignum_digit_type product;
- bignum_digit_type diff;
- bignum_digit_type carry;
- BDDS_MULSUB (v2, (u[2]), 0);
- BDDS_MULSUB (v1, (u[1]), carry);
- if (carry == 0)
- return (guess);
- diff = ((u[0]) - carry);
- if (diff < 0)
- (u[0]) = (diff + BIGNUM_RADIX);
- else
- {
- (u[0]) = diff;
- return (guess);
- }
- }
- {
- bignum_digit_type sum;
- bignum_digit_type carry;
- BDDS_ADD(v2, (u[2]), 0);
- BDDS_ADD(v1, (u[1]), carry);
- if (carry == 1)
- (u[0]) += 1;
- }
- return (guess - 1);
-}
-
-#undef BDDS_MULSUB
-#undef BDDS_ADD
-
-/* allocates memory */
-void
-bignum_divide_unsigned_small_denominator(bignum_type numerator,
- bignum_digit_type denominator,
- bignum_type * quotient,
- bignum_type * 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);
-
- bignum_digit_type r = (bignum_destructive_scale_down (q, denominator));
-
- q = (bignum_trim (q));
-
- if (remainder != ((bignum_type *) 0))
- {
- REGISTER_BIGNUM(q);
- (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
- UNREGISTER_BIGNUM(q);
- }
-
- (*quotient) = q;
-
- return;
-}
-
-/* Given (denominator > 1), it is fairly easy to show that
- (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
- that all digits are < BIGNUM_RADIX. */
-
-bignum_digit_type
-bignum_destructive_scale_down(bignum_type bignum, bignum_digit_type denominator)
-{
- bignum_digit_type numerator;
- bignum_digit_type remainder = 0;
- bignum_digit_type two_digits;
-#define quotient_high remainder
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
- BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
- while (start < scan)
- {
- two_digits = (*--scan);
- numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
- quotient_high = (numerator / denominator);
- numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
- (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
- remainder = (numerator % denominator);
- }
- return (remainder);
-#undef quotient_high
-}
-
-/* allocates memory */
-bignum_type
-bignum_remainder_unsigned_small_denominator(
- bignum_type n, bignum_digit_type d, int negative_p)
-{
- bignum_digit_type two_digits;
- bignum_digit_type * start = (BIGNUM_START_PTR (n));
- bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
- bignum_digit_type r = 0;
- BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
- while (start < scan)
- {
- two_digits = (*--scan);
- r =
- ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
- (HD_LOW (two_digits))))
- % d);
- }
- return (bignum_digit_to_bignum (r, negative_p));
-}
-
-/* allocates memory */
-bignum_type
-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_REF (result, 0)) = digit;
- return (result);
- }
-}
-
-/* allocates memory */
-bignum_type
-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_SET_NEGATIVE_P (result, negative_p);
- return (result);
-}
-
-/* allocates memory */
-bignum_type
-allot_bignum_zeroed(bignum_length_type length, int negative_p)
-{
- bignum_type result = allot_bignum(length,negative_p);
- bignum_digit_type * scan = (BIGNUM_START_PTR (result));
- bignum_digit_type * end = (scan + length);
- while (scan < end)
- (*scan++) = 0;
- return (result);
-}
-
-#define BIGNUM_REDUCE_LENGTH(source, length) \
- source = reallot_array(source,length + 1)
-
-/* allocates memory */
-bignum_type
-bignum_shorten_length(bignum_type bignum, bignum_length_type length)
-{
- bignum_length_type current_length = (BIGNUM_LENGTH (bignum));
- BIGNUM_ASSERT ((length >= 0) || (length <= current_length));
- if (length < current_length)
- {
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
- return (bignum);
-}
-
-/* allocates memory */
-bignum_type
-bignum_trim(bignum_type bignum)
-{
- bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
- bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
- bignum_digit_type * scan = end;
- while ((start <= scan) && ((*--scan) == 0))
- ;
- scan += 1;
- if (scan < end)
- {
- bignum_length_type length = (scan - start);
- BIGNUM_REDUCE_LENGTH (bignum, length);
- BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
- }
- return (bignum);
-}
-
-/* Copying */
-
-/* allocates memory */
-bignum_type
-bignum_new_sign(bignum_type bignum, int negative_p)
-{
- REGISTER_BIGNUM(bignum);
- bignum_type result =
- (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
- UNREGISTER_BIGNUM(bignum);
-
- bignum_destructive_copy (bignum, result);
- return (result);
-}
-
-/* allocates memory */
-bignum_type
-bignum_maybe_new_sign(bignum_type bignum, int negative_p)
-{
- if ((BIGNUM_NEGATIVE_P (bignum)) ? negative_p : (! negative_p))
- return (bignum);
- else
- {
- bignum_type result =
- (allot_bignum ((BIGNUM_LENGTH (bignum)), negative_p));
- bignum_destructive_copy (bignum, result);
- return (result);
- }
-}
-
-void
-bignum_destructive_copy(bignum_type source, bignum_type target)
-{
- bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
- bignum_digit_type * end_source =
- (scan_source + (BIGNUM_LENGTH (source)));
- bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
- while (scan_source < end_source)
- (*scan_target++) = (*scan_source++);
- return;
-}
-
-/*
- * Added bitwise operations (and oddp).
- */
-
-/* allocates memory */
-bignum_type
-bignum_bitwise_not(bignum_type x)
-{
- return bignum_subtract(BIGNUM_ONE(1), x);
-}
-
-/* allocates memory */
-bignum_type
-bignum_arithmetic_shift(bignum_type arg1, F_FIXNUM n)
-{
- if (BIGNUM_NEGATIVE_P(arg1) && n < 0)
- return bignum_bitwise_not(bignum_magnitude_ash(bignum_bitwise_not(arg1), n));
- else
- return bignum_magnitude_ash(arg1, n);
-}
-
-#define AND_OP 0
-#define IOR_OP 1
-#define XOR_OP 2
-
-/* allocates memory */
-bignum_type
-bignum_bitwise_and(bignum_type arg1, bignum_type arg2)
-{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
- );
-}
-
-/* allocates memory */
-bignum_type
-bignum_bitwise_ior(bignum_type arg1, bignum_type arg2)
-{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
- );
-}
-
-/* allocates memory */
-bignum_type
-bignum_bitwise_xor(bignum_type arg1, bignum_type arg2)
-{
- return(
- (BIGNUM_NEGATIVE_P (arg1))
- ? (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
- : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
- : (BIGNUM_NEGATIVE_P (arg2))
- ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
- : bignum_pospos_bitwise_op(XOR_OP, arg1, 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_type result = NULL;
- bignum_digit_type *scan1;
- bignum_digit_type *scanr;
- bignum_digit_type *end;
-
- F_FIXNUM digit_offset,bit_offset;
-
- if (BIGNUM_ZERO_P (arg1)) return (arg1);
-
- if (n > 0) {
- 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);
-
- scanr = BIGNUM_START_PTR (result) + digit_offset;
- scan1 = BIGNUM_START_PTR (arg1);
- end = scan1 + BIGNUM_LENGTH (arg1);
-
- while (scan1 < end) {
- *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
- *scanr = *scanr & BIGNUM_DIGIT_MASK;
- scanr++;
- *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset);
- *scanr = *scanr & BIGNUM_DIGIT_MASK;
- }
- }
- else if (n < 0
- && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))
- result = BIGNUM_ZERO ();
-
- else if (n < 0) {
- 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);
-
- scanr = BIGNUM_START_PTR (result);
- scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
- end = scanr + BIGNUM_LENGTH (result) - 1;
-
- while (scanr < end) {
- *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
- *scanr = (*scanr |
- *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK;
- scanr++;
- }
- *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
- }
- else if (n == 0) result = arg1;
-
- return (bignum_trim (result));
-}
-
-/* allocates memory */
-bignum_type
-bignum_pospos_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
-{
- bignum_type result;
- bignum_length_type max_length;
-
- bignum_digit_type *scan1, *end1, digit1;
- bignum_digit_type *scan2, *end2, digit2;
- bignum_digit_type *scanr, *endr;
-
- 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);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
-
- while (scanr < endr) {
- digit1 = (scan1 < end1) ? *scan1++ : 0;
- digit2 = (scan2 < end2) ? *scan2++ : 0;
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
- return bignum_trim(result);
-}
-
-/* allocates memory */
-bignum_type
-bignum_posneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
-{
- bignum_type result;
- bignum_length_type max_length;
-
- bignum_digit_type *scan1, *end1, digit1;
- bignum_digit_type *scan2, *end2, digit2, carry2;
- bignum_digit_type *scanr, *endr;
-
- char neg_p = op == IOR_OP || op == XOR_OP;
-
- 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);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
-
- carry2 = 1;
-
- while (scanr < endr) {
- digit1 = (scan1 < end1) ? *scan1++ : 0;
- digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK)
- + carry2;
-
- if (digit2 < BIGNUM_RADIX)
- carry2 = 0;
- else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
-
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
-
- if (neg_p)
- bignum_negate_magnitude(result);
-
- return bignum_trim(result);
-}
-
-/* allocates memory */
-bignum_type
-bignum_negneg_bitwise_op(int op, bignum_type arg1, bignum_type arg2)
-{
- bignum_type result;
- bignum_length_type max_length;
-
- bignum_digit_type *scan1, *end1, digit1, carry1;
- bignum_digit_type *scan2, *end2, digit2, carry2;
- bignum_digit_type *scanr, *endr;
-
- char neg_p = op == AND_OP || op == IOR_OP;
-
- 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);
- scan2 = BIGNUM_START_PTR(arg2);
- endr = scanr + max_length;
- end1 = scan1 + BIGNUM_LENGTH(arg1);
- end2 = scan2 + BIGNUM_LENGTH(arg2);
-
- carry1 = 1;
- carry2 = 1;
-
- while (scanr < endr) {
- digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1;
- digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2;
-
- if (digit1 < BIGNUM_RADIX)
- carry1 = 0;
- else
- {
- digit1 = (digit1 - BIGNUM_RADIX);
- carry1 = 1;
- }
-
- if (digit2 < BIGNUM_RADIX)
- carry2 = 0;
- else
- {
- digit2 = (digit2 - BIGNUM_RADIX);
- carry2 = 1;
- }
-
- *scanr++ = (op == AND_OP) ? digit1 & digit2 :
- (op == IOR_OP) ? digit1 | digit2 :
- digit1 ^ digit2;
- }
-
- if (neg_p)
- bignum_negate_magnitude(result);
-
- return bignum_trim(result);
-}
-
-void
-bignum_negate_magnitude(bignum_type arg)
-{
- bignum_digit_type *scan;
- bignum_digit_type *end;
- bignum_digit_type digit;
- bignum_digit_type carry;
-
- scan = BIGNUM_START_PTR(arg);
- end = scan + BIGNUM_LENGTH(arg);
-
- carry = 1;
-
- while (scan < end) {
- digit = (~*scan & BIGNUM_DIGIT_MASK) + carry;
-
- if (digit < BIGNUM_RADIX)
- carry = 0;
- else
- {
- digit = (digit - BIGNUM_RADIX);
- carry = 1;
- }
-
- *scan++ = digit;
- }
-}
-
-/* Allocates memory */
-bignum_type
-bignum_integer_length(bignum_type bignum)
-{
- bignum_length_type index = ((BIGNUM_LENGTH (bignum)) - 1);
- bignum_digit_type digit = (BIGNUM_REF (bignum, index));
-
- REGISTER_BIGNUM(bignum);
- bignum_type result = (allot_bignum (2, 0));
- UNREGISTER_BIGNUM(bignum);
-
- (BIGNUM_REF (result, 0)) = index;
- (BIGNUM_REF (result, 1)) = 0;
- bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
- while (digit > 1)
- {
- bignum_destructive_add (result, ((bignum_digit_type) 1));
- digit >>= 1;
- }
- return (bignum_trim (result));
-}
-
-/* Allocates memory */
-int
-bignum_logbitp(int shift, bignum_type arg)
-{
- return((BIGNUM_NEGATIVE_P (arg))
- ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
- : bignum_unsigned_logbitp (shift,arg));
-}
-
-int
-bignum_unsigned_logbitp(int shift, bignum_type bignum)
-{
- bignum_length_type len = (BIGNUM_LENGTH (bignum));
- int index = shift / BIGNUM_DIGIT_LENGTH;
- if (index >= len)
- return 0;
- bignum_digit_type digit = (BIGNUM_REF (bignum, index));
- int p = shift % BIGNUM_DIGIT_LENGTH;
- bignum_digit_type mask = ((F_FIXNUM)1) << p;
- return (digit & mask) ? 1 : 0;
-}
-
-/* Allocates memory */
-bignum_type
-digit_stream_to_bignum(unsigned int n_digits,
- unsigned int (*producer)(unsigned int),
- unsigned int radix,
- int negative_p)
-{
- BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
- if (n_digits == 0)
- return (BIGNUM_ZERO ());
- if (n_digits == 1)
- {
- F_FIXNUM digit = ((F_FIXNUM) ((*producer) (0)));
- return (fixnum_to_bignum (negative_p ? (- digit) : digit));
- }
- {
- bignum_length_type length;
- {
- unsigned int radix_copy = radix;
- unsigned int log_radix = 0;
- while (radix_copy > 0)
- {
- radix_copy >>= 1;
- log_radix += 1;
- }
- /* This length will be at least as large as needed. */
- length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
- }
- {
- bignum_type result = (allot_bignum_zeroed (length, negative_p));
- while ((n_digits--) > 0)
- {
- bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
- bignum_destructive_add
- (result, ((bignum_digit_type) ((*producer) (n_digits))));
- }
- return (bignum_trim (result));
- }
- }
-}
--- /dev/null
+/* :tabSize=2:indentSize=2:noTabs=true:
+
+Copyright (C) 1989-94 Massachusetts Institute of Technology
+Portions copyright (C) 2004-2008 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. */
+
+/* Changes for Scheme 48:
+ * - Converted to ANSI.
+ * - Added bitwise operations.
+ * - Added s48 to the beginning of all externally visible names.
+ * - Cached the bignum representations of -1, 0, and 1.
+ */
+
+/* Changes for Factor:
+ * - Adapt bignumint.h for Factor memory manager
+ * - Add more bignum <-> C type conversions
+ * - Remove unused functions
+ * - Add local variable GC root recording
+ * - Remove s48 prefix from function names
+ * - Various fixes for Win64
+ * - Port to C++
+ */
+
+#include "master.hpp"
+
+#include <limits>
+
+#include <stdio.h>
+#include <math.h>
+
+namespace factor
+{
+
+/* Exports */
+
+int
+bignum_equal_p(bignum * x, bignum * y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (BIGNUM_ZERO_P (y))
+ : ((! (BIGNUM_ZERO_P (y)))
+ && ((BIGNUM_NEGATIVE_P (x))
+ ? (BIGNUM_NEGATIVE_P (y))
+ : (! (BIGNUM_NEGATIVE_P (y))))
+ && (bignum_equal_p_unsigned (x, y))));
+}
+
+enum bignum_comparison
+bignum_compare(bignum * x, bignum * y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? bignum_comparison_equal
+ : (BIGNUM_NEGATIVE_P (y))
+ ? bignum_comparison_greater
+ : bignum_comparison_less)
+ : (BIGNUM_ZERO_P (y))
+ ? ((BIGNUM_NEGATIVE_P (x))
+ ? bignum_comparison_less
+ : bignum_comparison_greater)
+ : (BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_compare_unsigned (y, x))
+ : (bignum_comparison_less))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_comparison_greater)
+ : (bignum_compare_unsigned (x, y))));
+}
+
+/* allocates memory */
+bignum *
+bignum_add(bignum * x, bignum * y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? (y)
+ : (BIGNUM_ZERO_P (y))
+ ? (x)
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 1))
+ : (bignum_subtract_unsigned (y, x)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (x, y))
+ : (bignum_add_unsigned (x, y, 0)))));
+}
+
+/* allocates memory */
+bignum *
+bignum_subtract(bignum * x, bignum * y)
+{
+ return
+ ((BIGNUM_ZERO_P (x))
+ ? ((BIGNUM_ZERO_P (y))
+ ? (y)
+ : (bignum_new_sign (y, (! (BIGNUM_NEGATIVE_P (y))))))
+ : ((BIGNUM_ZERO_P (y))
+ ? (x)
+ : ((BIGNUM_NEGATIVE_P (x))
+ ? ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_subtract_unsigned (y, x))
+ : (bignum_add_unsigned (x, y, 1)))
+ : ((BIGNUM_NEGATIVE_P (y))
+ ? (bignum_add_unsigned (x, y, 0))
+ : (bignum_subtract_unsigned (x, y))))));
+}
+
+/* allocates memory */
+bignum *
+bignum_multiply(bignum * x, bignum * y)
+{
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ int negative_p =
+ ((BIGNUM_NEGATIVE_P (x))
+ ? (! (BIGNUM_NEGATIVE_P (y)))
+ : (BIGNUM_NEGATIVE_P (y)));
+ if (BIGNUM_ZERO_P (x))
+ return (x);
+ if (BIGNUM_ZERO_P (y))
+ return (y);
+ if (x_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (x, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (y, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (y, digit, negative_p));
+ }
+ if (y_length == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (y, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (x, negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ return (bignum_multiply_unsigned_small_factor (x, digit, negative_p));
+ }
+ return (bignum_multiply_unsigned (x, y, negative_p));
+}
+
+/* allocates memory */
+void
+bignum_divide(bignum * numerator, bignum * denominator,
+ bignum * * quotient, bignum * * remainder)
+{
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return;
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ {
+ (*quotient) = numerator;
+ (*remainder) = numerator;
+ }
+ else
+ {
+ int r_negative_p = (BIGNUM_NEGATIVE_P (numerator));
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator)) ? (! r_negative_p) : r_negative_p);
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ {
+ (*quotient) = (BIGNUM_ONE (q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ case bignum_comparison_less:
+ {
+ (*quotient) = (BIGNUM_ZERO ());
+ (*remainder) = numerator;
+ break;
+ }
+ case bignum_comparison_greater:
+ {
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ {
+ (*quotient) =
+ (bignum_maybe_new_sign (numerator, q_negative_p));
+ (*remainder) = (BIGNUM_ZERO ());
+ break;
+ }
+ else if (digit < BIGNUM_RADIX_ROOT)
+ {
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ else
+ {
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ quotient, remainder,
+ q_negative_p, r_negative_p);
+ break;
+ }
+ }
+ }
+}
+
+/* allocates memory */
+bignum *
+bignum_quotient(bignum * numerator, bignum * denominator)
+{
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return numerator;
+ {
+ int q_negative_p =
+ ((BIGNUM_NEGATIVE_P (denominator))
+ ? (! (BIGNUM_NEGATIVE_P (numerator)))
+ : (BIGNUM_NEGATIVE_P (numerator)));
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ONE (q_negative_p));
+ case bignum_comparison_less:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum * quotient;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (bignum_maybe_new_sign (numerator, q_negative_p));
+ if (digit < BIGNUM_RADIX_ROOT)
+ bignum_divide_unsigned_small_denominator
+ (numerator, digit,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ else
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ("ient), ((bignum * *) 0),
+ q_negative_p, 0);
+ return (quotient);
+ }
+ }
+ }
+}
+
+/* allocates memory */
+bignum *
+bignum_remainder(bignum * numerator, bignum * denominator)
+{
+ if (BIGNUM_ZERO_P (denominator))
+ {
+ divide_by_zero_error();
+ return (BIGNUM_OUT_OF_BAND);
+ }
+ if (BIGNUM_ZERO_P (numerator))
+ return numerator;
+ switch (bignum_compare_unsigned (numerator, denominator))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ return numerator;
+ case bignum_comparison_greater:
+ default: /* to appease gcc -Wall */
+ {
+ bignum * remainder;
+ if ((BIGNUM_LENGTH (denominator)) == 1)
+ {
+ bignum_digit_type digit = (BIGNUM_REF (denominator, 0));
+ if (digit == 1)
+ return (BIGNUM_ZERO ());
+ if (digit < BIGNUM_RADIX_ROOT)
+ return
+ (bignum_remainder_unsigned_small_denominator
+ (numerator, digit, (BIGNUM_NEGATIVE_P (numerator))));
+ bignum_divide_unsigned_medium_denominator
+ (numerator, digit,
+ ((bignum * *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ }
+ else
+ bignum_divide_unsigned_large_denominator
+ (numerator, denominator,
+ ((bignum * *) 0), (&remainder),
+ 0, (BIGNUM_NEGATIVE_P (numerator)));
+ return (remainder);
+ }
+ }
+}
+
+#define FOO_TO_BIGNUM(name,type,utype) \
+ bignum * name##_to_bignum(type n) \
+ { \
+ int negative_p; \
+ bignum_digit_type result_digits [BIGNUM_DIGITS_FOR(type)]; \
+ bignum_digit_type * end_digits = result_digits; \
+ /* Special cases win when these small constants are cached. */ \
+ if (n == 0) return (BIGNUM_ZERO ()); \
+ if (n == 1) return (BIGNUM_ONE (0)); \
+ if (n < (type)0 && n == (type)-1) return (BIGNUM_ONE (1)); \
+ { \
+ utype accumulator = ((negative_p = (n < (type)0)) ? (-n) : n); \
+ do \
+ { \
+ (*end_digits++) = (accumulator & BIGNUM_DIGIT_MASK); \
+ accumulator >>= BIGNUM_DIGIT_LENGTH; \
+ } \
+ while (accumulator != 0); \
+ } \
+ { \
+ 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)); \
+ while (scan_digits < end_digits) \
+ (*scan_result++) = (*scan_digits++); \
+ return (result); \
+ } \
+ }
+
+/* all below allocate memory */
+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 * bignum) \
+ { \
+ if (BIGNUM_ZERO_P (bignum)) \
+ return (0); \
+ { \
+ utype accumulator = 0; \
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum)); \
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum))); \
+ while (start < scan) \
+ accumulator = ((accumulator << BIGNUM_DIGIT_LENGTH) + (*--scan)); \
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-((type)accumulator)) : accumulator); \
+ } \
+ }
+
+/* all of the below allocate memory */
+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 * bignum)
+{
+ if (BIGNUM_ZERO_P (bignum))
+ return (0);
+ {
+ double accumulator = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ while (start < scan)
+ accumulator = ((accumulator * BIGNUM_RADIX) + (*--scan));
+ return ((BIGNUM_NEGATIVE_P (bignum)) ? (-accumulator) : accumulator);
+ }
+}
+
+#define DTB_WRITE_DIGIT(factor) \
+{ \
+ significand *= (factor); \
+ digit = ((bignum_digit_type) significand); \
+ (*--scan) = digit; \
+ significand -= ((double) digit); \
+}
+
+/* allocates memory */
+#define inf std::numeric_limits<double>::infinity()
+
+bignum *
+double_to_bignum(double x)
+{
+ if (x == inf || x == -inf || x != x) return (BIGNUM_ZERO ());
+ int exponent;
+ double significand = (frexp (x, (&exponent)));
+ if (exponent <= 0) return (BIGNUM_ZERO ());
+ if (exponent == 1) return (BIGNUM_ONE (x < 0));
+ if (significand < 0) significand = (-significand);
+ {
+ bignum_length_type length = (BIGNUM_BITS_TO_DIGITS (exponent));
+ 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 ((fixnum)1 << odd_bits);
+ while (start < scan)
+ {
+ if (significand == 0)
+ {
+ while (start < scan)
+ (*--scan) = 0;
+ break;
+ }
+ DTB_WRITE_DIGIT (BIGNUM_RADIX);
+ }
+ return (result);
+ }
+}
+
+#undef DTB_WRITE_DIGIT
+
+/* Comparisons */
+
+int
+bignum_equal_p_unsigned(bignum * x, bignum * y)
+{
+ bignum_length_type length = (BIGNUM_LENGTH (x));
+ if (length != (BIGNUM_LENGTH (y)))
+ return (0);
+ else
+ {
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_x = (scan_x + length);
+ while (scan_x < end_x)
+ if ((*scan_x++) != (*scan_y++))
+ return (0);
+ return (1);
+ }
+}
+
+enum bignum_comparison
+bignum_compare_unsigned(bignum * x, bignum * y)
+{
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+ if (x_length < y_length)
+ return (bignum_comparison_less);
+ if (x_length > y_length)
+ return (bignum_comparison_greater);
+ {
+ bignum_digit_type * start_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_x = (start_x + x_length);
+ bignum_digit_type * scan_y = ((BIGNUM_START_PTR (y)) + y_length);
+ while (start_x < scan_x)
+ {
+ bignum_digit_type digit_x = (*--scan_x);
+ bignum_digit_type digit_y = (*--scan_y);
+ if (digit_x < digit_y)
+ return (bignum_comparison_less);
+ if (digit_x > digit_y)
+ return (bignum_comparison_greater);
+ }
+ }
+ return (bignum_comparison_equal);
+}
+
+/* Addition */
+
+/* allocates memory */
+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 * z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+
+ bignum * r = (allot_bignum ((x_length + 1), negative_p));
+
+ bignum_digit_type sum;
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ sum = ((*scan_x++) + (*scan_y++) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (carry != 0)
+ while (scan_x < end_x)
+ {
+ sum = ((*scan_x++) + 1);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*scan_r++) = sum;
+ carry = 0;
+ break;
+ }
+ else
+ (*scan_r++) = (sum - BIGNUM_RADIX);
+ }
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ if (carry != 0)
+ {
+ (*scan_r) = 1;
+ return (r);
+ }
+ return (bignum_shorten_length (r, x_length));
+ }
+}
+
+/* Subtraction */
+
+/* allocates memory */
+bignum *
+bignum_subtract_unsigned(bignum * x, bignum * y)
+{
+ GC_BIGNUM(x); GC_BIGNUM(y);
+
+ int negative_p = 0;
+ switch (bignum_compare_unsigned (x, y))
+ {
+ case bignum_comparison_equal:
+ return (BIGNUM_ZERO ());
+ case bignum_comparison_less:
+ {
+ bignum * z = x;
+ x = y;
+ y = z;
+ }
+ negative_p = 1;
+ break;
+ case bignum_comparison_greater:
+ negative_p = 0;
+ break;
+ }
+ {
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+
+ bignum * r = (allot_bignum (x_length, negative_p));
+
+ bignum_digit_type difference;
+ bignum_digit_type borrow = 0;
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * scan_r = (BIGNUM_START_PTR (r));
+ {
+ bignum_digit_type * scan_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (scan_y + (BIGNUM_LENGTH (y)));
+ while (scan_y < end_y)
+ {
+ difference = (((*scan_x++) - (*scan_y++)) - borrow);
+ if (difference < 0)
+ {
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ borrow = 1;
+ }
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ }
+ }
+ }
+ {
+ bignum_digit_type * end_x = ((BIGNUM_START_PTR (x)) + x_length);
+ if (borrow != 0)
+ while (scan_x < end_x)
+ {
+ difference = ((*scan_x++) - borrow);
+ if (difference < 0)
+ (*scan_r++) = (difference + BIGNUM_RADIX);
+ else
+ {
+ (*scan_r++) = difference;
+ borrow = 0;
+ break;
+ }
+ }
+ BIGNUM_ASSERT (borrow == 0);
+ while (scan_x < end_x)
+ (*scan_r++) = (*scan_x++);
+ }
+ return (bignum_trim (r));
+ }
+}
+
+/* Multiplication
+ Maximum value for product_low or product_high:
+ ((R * R) + (R * (R - 2)) + (R - 1))
+ Maximum value for carry: ((R * (R - 1)) + (R - 1))
+ where R == BIGNUM_RADIX_ROOT */
+
+/* allocates memory */
+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 * z = x;
+ x = y;
+ y = z;
+ }
+ {
+ bignum_digit_type carry;
+ bignum_digit_type y_digit_low;
+ bignum_digit_type y_digit_high;
+ bignum_digit_type x_digit_low;
+ bignum_digit_type x_digit_high;
+ bignum_digit_type product_low;
+ bignum_digit_type * scan_r;
+ bignum_digit_type * scan_y;
+ bignum_length_type x_length = (BIGNUM_LENGTH (x));
+ bignum_length_type y_length = (BIGNUM_LENGTH (y));
+
+ bignum * r =
+ (allot_bignum_zeroed ((x_length + y_length), negative_p));
+
+ bignum_digit_type * scan_x = (BIGNUM_START_PTR (x));
+ bignum_digit_type * end_x = (scan_x + x_length);
+ bignum_digit_type * start_y = (BIGNUM_START_PTR (y));
+ bignum_digit_type * end_y = (start_y + y_length);
+ bignum_digit_type * start_r = (BIGNUM_START_PTR (r));
+#define x_digit x_digit_high
+#define y_digit y_digit_high
+#define product_high carry
+ while (scan_x < end_x)
+ {
+ x_digit = (*scan_x++);
+ x_digit_low = (HD_LOW (x_digit));
+ x_digit_high = (HD_HIGH (x_digit));
+ carry = 0;
+ scan_y = start_y;
+ scan_r = (start_r++);
+ while (scan_y < end_y)
+ {
+ y_digit = (*scan_y++);
+ y_digit_low = (HD_LOW (y_digit));
+ y_digit_high = (HD_HIGH (y_digit));
+ product_low =
+ ((*scan_r) +
+ (x_digit_low * y_digit_low) +
+ (HD_LOW (carry)));
+ product_high =
+ ((x_digit_high * y_digit_low) +
+ (x_digit_low * y_digit_high) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan_r++) =
+ (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry =
+ ((x_digit_high * y_digit_high) +
+ (HD_HIGH (product_high)));
+ }
+ (*scan_r) += carry;
+ }
+ return (bignum_trim (r));
+#undef x_digit
+#undef y_digit
+#undef product_high
+ }
+}
+
+/* allocates memory */
+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));
+
+ bignum * p = (allot_bignum ((length_x + 1), negative_p));
+
+ bignum_destructive_copy (x, p);
+ (BIGNUM_REF (p, length_x)) = 0;
+ bignum_destructive_scale_up (p, y);
+ return (bignum_trim (p));
+}
+
+void
+bignum_destructive_add(bignum * bignum, bignum_digit_type n)
+{
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type digit;
+ digit = ((*scan) + n);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ while (1)
+ {
+ digit = ((*scan) + 1);
+ if (digit < BIGNUM_RADIX)
+ {
+ (*scan) = digit;
+ return;
+ }
+ (*scan++) = (digit - BIGNUM_RADIX);
+ }
+}
+
+void
+bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor)
+{
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type two_digits;
+ bignum_digit_type product_low;
+#define product_high carry
+ bignum_digit_type * end = (scan + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((factor > 1) && (factor < BIGNUM_RADIX_ROOT));
+ while (scan < end)
+ {
+ two_digits = (*scan);
+ product_low = ((factor * (HD_LOW (two_digits))) + (HD_LOW (carry)));
+ product_high =
+ ((factor * (HD_HIGH (two_digits))) +
+ (HD_HIGH (product_low)) +
+ (HD_HIGH (carry)));
+ (*scan++) = (HD_CONS ((HD_LOW (product_high)), (HD_LOW (product_low))));
+ carry = (HD_HIGH (product_high));
+ }
+ /* A carry here would be an overflow, i.e. it would not fit.
+ Hopefully the callers allocate enough space that this will
+ never happen.
+ */
+ BIGNUM_ASSERT (carry == 0);
+ return;
+#undef product_high
+}
+
+/* Division */
+
+/* For help understanding this algorithm, see:
+ Knuth, Donald E., "The Art of Computer Programming",
+ volume 2, "Seminumerical Algorithms"
+ section 4.3.1, "Multiple-Precision Arithmetic". */
+
+/* allocates memory */
+void
+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));
+
+ bignum * q =
+ ((quotient != ((bignum * *) 0))
+ ? (allot_bignum ((length_n - length_d), q_negative_p))
+ : BIGNUM_OUT_OF_BAND);
+ GC_BIGNUM(q);
+
+ bignum * u = (allot_bignum (length_n, r_negative_p));
+ GC_BIGNUM(u);
+
+ int shift = 0;
+ BIGNUM_ASSERT (length_d > 1);
+ {
+ bignum_digit_type v1 = (BIGNUM_REF ((denominator), (length_d - 1)));
+ while (v1 < (BIGNUM_RADIX / 2))
+ {
+ v1 <<= 1;
+ shift += 1;
+ }
+ }
+ if (shift == 0)
+ {
+ bignum_destructive_copy (numerator, u);
+ (BIGNUM_REF (u, (length_n - 1))) = 0;
+ bignum_divide_unsigned_normalized (u, denominator, q);
+ }
+ else
+ {
+ 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 * *) 0))
+ bignum_destructive_unnormalization (u, shift);
+ }
+
+ if(q)
+ q = bignum_trim (q);
+
+ u = bignum_trim (u);
+
+ if (quotient != ((bignum * *) 0))
+ (*quotient) = q;
+
+ if (remainder != ((bignum * *) 0))
+ (*remainder) = u;
+
+ return;
+}
+
+void
+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));
+ bignum_digit_type * u_start = (BIGNUM_START_PTR (u));
+ bignum_digit_type * u_scan = (u_start + u_length);
+ bignum_digit_type * u_scan_limit = (u_start + v_length);
+ bignum_digit_type * u_scan_start = (u_scan - v_length);
+ bignum_digit_type * v_start = (BIGNUM_START_PTR (v));
+ bignum_digit_type * v_end = (v_start + v_length);
+ bignum_digit_type * q_scan = NULL;
+ bignum_digit_type v1 = (v_end[-1]);
+ bignum_digit_type v2 = (v_end[-2]);
+ bignum_digit_type ph; /* high half of double-digit product */
+ bignum_digit_type pl; /* low half of double-digit product */
+ bignum_digit_type guess;
+ bignum_digit_type gh; /* high half-digit of guess */
+ bignum_digit_type ch; /* high half of double-digit comparand */
+ bignum_digit_type v2l = (HD_LOW (v2));
+ bignum_digit_type v2h = (HD_HIGH (v2));
+ bignum_digit_type cl; /* low half of double-digit comparand */
+#define gl ph /* low half-digit of guess */
+#define uj pl
+#define qj ph
+ bignum_digit_type gm; /* memory loc for reference parameter */
+ if (q != BIGNUM_OUT_OF_BAND)
+ q_scan = ((BIGNUM_START_PTR (q)) + (BIGNUM_LENGTH (q)));
+ while (u_scan_limit < u_scan)
+ {
+ uj = (*--u_scan);
+ if (uj != v1)
+ {
+ /* comparand =
+ (((((uj * BIGNUM_RADIX) + uj1) % v1) * BIGNUM_RADIX) + uj2);
+ guess = (((uj * BIGNUM_RADIX) + uj1) / v1); */
+ cl = (u_scan[-2]);
+ ch = (bignum_digit_divide (uj, (u_scan[-1]), v1, (&gm)));
+ guess = gm;
+ }
+ else
+ {
+ cl = (u_scan[-2]);
+ ch = ((u_scan[-1]) + v1);
+ guess = (BIGNUM_RADIX - 1);
+ }
+ while (1)
+ {
+ /* product = (guess * v2); */
+ gl = (HD_LOW (guess));
+ gh = (HD_HIGH (guess));
+ pl = (v2l * gl);
+ ph = ((v2l * gh) + (v2h * gl) + (HD_HIGH (pl)));
+ pl = (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl))));
+ ph = ((v2h * gh) + (HD_HIGH (ph)));
+ /* if (comparand >= product) */
+ if ((ch > ph) || ((ch == ph) && (cl >= pl)))
+ break;
+ guess -= 1;
+ /* comparand += (v1 << BIGNUM_DIGIT_LENGTH) */
+ ch += v1;
+ /* if (comparand >= (BIGNUM_RADIX * BIGNUM_RADIX)) */
+ if (ch >= BIGNUM_RADIX)
+ break;
+ }
+ qj = (bignum_divide_subtract (v_start, v_end, guess, (--u_scan_start)));
+ if (q != BIGNUM_OUT_OF_BAND)
+ (*--q_scan) = qj;
+ }
+ return;
+#undef gl
+#undef uj
+#undef qj
+}
+
+bignum_digit_type
+bignum_divide_subtract(bignum_digit_type * v_start,
+ bignum_digit_type * v_end,
+ bignum_digit_type guess,
+ bignum_digit_type * u_start)
+{
+ bignum_digit_type * v_scan = v_start;
+ bignum_digit_type * u_scan = u_start;
+ bignum_digit_type carry = 0;
+ if (guess == 0) return (0);
+ {
+ bignum_digit_type gl = (HD_LOW (guess));
+ bignum_digit_type gh = (HD_HIGH (guess));
+ bignum_digit_type v;
+ bignum_digit_type pl;
+ bignum_digit_type vl;
+#define vh v
+#define ph carry
+#define diff pl
+ while (v_scan < v_end)
+ {
+ v = (*v_scan++);
+ vl = (HD_LOW (v));
+ vh = (HD_HIGH (v));
+ pl = ((vl * gl) + (HD_LOW (carry)));
+ ph = ((vl * gh) + (vh * gl) + (HD_HIGH (pl)) + (HD_HIGH (carry)));
+ diff = ((*u_scan) - (HD_CONS ((HD_LOW (ph)), (HD_LOW (pl)))));
+ if (diff < 0)
+ {
+ (*u_scan++) = (diff + BIGNUM_RADIX);
+ carry = ((vh * gh) + (HD_HIGH (ph)) + 1);
+ }
+ else
+ {
+ (*u_scan++) = diff;
+ carry = ((vh * gh) + (HD_HIGH (ph)));
+ }
+ }
+ if (carry == 0)
+ return (guess);
+ diff = ((*u_scan) - carry);
+ if (diff < 0)
+ (*u_scan) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (*u_scan) = diff;
+ return (guess);
+ }
+#undef vh
+#undef ph
+#undef diff
+ }
+ /* Subtraction generated carry, implying guess is one too large.
+ Add v back in to bring it back down. */
+ v_scan = v_start;
+ u_scan = u_start;
+ carry = 0;
+ while (v_scan < v_end)
+ {
+ bignum_digit_type sum = ((*v_scan++) + (*u_scan) + carry);
+ if (sum < BIGNUM_RADIX)
+ {
+ (*u_scan++) = sum;
+ carry = 0;
+ }
+ else
+ {
+ (*u_scan++) = (sum - BIGNUM_RADIX);
+ carry = 1;
+ }
+ }
+ if (carry == 1)
+ {
+ bignum_digit_type sum = ((*u_scan) + carry);
+ (*u_scan) = ((sum < BIGNUM_RADIX) ? sum : (sum - BIGNUM_RADIX));
+ }
+ return (guess - 1);
+}
+
+/* allocates memory */
+void
+bignum_divide_unsigned_medium_denominator(bignum * numerator,
+ bignum_digit_type denominator,
+ 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 * q = NULL;
+ GC_BIGNUM(q);
+
+ int shift = 0;
+ /* Because `bignum_digit_divide' requires a normalized denominator. */
+ while (denominator < (BIGNUM_RADIX / 2))
+ {
+ denominator <<= 1;
+ shift += 1;
+ }
+ if (shift == 0)
+ {
+ length_q = length_n;
+
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_copy (numerator, q);
+ }
+ else
+ {
+ length_q = (length_n + 1);
+
+ q = (allot_bignum (length_q, q_negative_p));
+ bignum_destructive_normalization (numerator, q, shift);
+ }
+ {
+ bignum_digit_type r = 0;
+ bignum_digit_type * start = (BIGNUM_START_PTR (q));
+ bignum_digit_type * scan = (start + length_q);
+ bignum_digit_type qj;
+
+ while (start < scan)
+ {
+ r = (bignum_digit_divide (r, (*--scan), denominator, (&qj)));
+ (*scan) = qj;
+ }
+
+ q = bignum_trim (q);
+
+ if (remainder != ((bignum * *) 0))
+ {
+ if (shift != 0)
+ r >>= shift;
+
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+ }
+
+ if (quotient != ((bignum * *) 0))
+ (*quotient) = q;
+ }
+ return;
+}
+
+void
+bignum_destructive_normalization(bignum * source, bignum * target,
+ int shift_left)
+{
+ bignum_digit_type digit;
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type carry = 0;
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (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);
+ while (scan_source < end_source)
+ {
+ digit = (*scan_source++);
+ (*scan_target++) = (((digit & mask) << shift_left) | carry);
+ carry = (digit >> shift_right);
+ }
+ if (scan_target < end_target)
+ (*scan_target) = carry;
+ else
+ BIGNUM_ASSERT (carry == 0);
+ return;
+}
+
+void
+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 = (((fixnum)1 << shift_right) - 1);
+ while (start < scan)
+ {
+ digit = (*--scan);
+ (*scan) = ((digit >> shift_right) | carry);
+ carry = ((digit & mask) << shift_left);
+ }
+ BIGNUM_ASSERT (carry == 0);
+ return;
+}
+
+/* This is a reduced version of the division algorithm, applied to the
+ case of dividing two bignum digits by one bignum digit. It is
+ assumed that the numerator, denominator are normalized. */
+
+#define BDD_STEP(qn, j) \
+{ \
+ uj = (u[j]); \
+ if (uj != v1) \
+ { \
+ uj_uj1 = (HD_CONS (uj, (u[j + 1]))); \
+ guess = (uj_uj1 / v1); \
+ comparand = (HD_CONS ((uj_uj1 % v1), (u[j + 2]))); \
+ } \
+ else \
+ { \
+ guess = (BIGNUM_RADIX_ROOT - 1); \
+ comparand = (HD_CONS (((u[j + 1]) + v1), (u[j + 2]))); \
+ } \
+ while ((guess * v2) > comparand) \
+ { \
+ guess -= 1; \
+ comparand += (v1 << BIGNUM_HALF_DIGIT_LENGTH); \
+ if (comparand >= BIGNUM_RADIX) \
+ break; \
+ } \
+ qn = (bignum_digit_divide_subtract (v1, v2, guess, (&u[j]))); \
+}
+
+bignum_digit_type
+bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
+ bignum_digit_type v,
+ bignum_digit_type * q) /* return value */
+{
+ bignum_digit_type guess;
+ bignum_digit_type comparand;
+ bignum_digit_type v1 = (HD_HIGH (v));
+ bignum_digit_type v2 = (HD_LOW (v));
+ bignum_digit_type uj;
+ bignum_digit_type uj_uj1;
+ bignum_digit_type q1;
+ bignum_digit_type q2;
+ bignum_digit_type u [4];
+ if (uh == 0)
+ {
+ if (ul < v)
+ {
+ (*q) = 0;
+ return (ul);
+ }
+ else if (ul == v)
+ {
+ (*q) = 1;
+ return (0);
+ }
+ }
+ (u[0]) = (HD_HIGH (uh));
+ (u[1]) = (HD_LOW (uh));
+ (u[2]) = (HD_HIGH (ul));
+ (u[3]) = (HD_LOW (ul));
+ v1 = (HD_HIGH (v));
+ v2 = (HD_LOW (v));
+ BDD_STEP (q1, 0);
+ BDD_STEP (q2, 1);
+ (*q) = (HD_CONS (q1, q2));
+ return (HD_CONS ((u[2]), (u[3])));
+}
+
+#undef BDD_STEP
+
+#define BDDS_MULSUB(vn, un, carry_in) \
+{ \
+ product = ((vn * guess) + carry_in); \
+ diff = (un - (HD_LOW (product))); \
+ if (diff < 0) \
+ { \
+ un = (diff + BIGNUM_RADIX_ROOT); \
+ carry = ((HD_HIGH (product)) + 1); \
+ } \
+ else \
+ { \
+ un = diff; \
+ carry = (HD_HIGH (product)); \
+ } \
+}
+
+#define BDDS_ADD(vn, un, carry_in) \
+{ \
+ sum = (vn + un + carry_in); \
+ if (sum < BIGNUM_RADIX_ROOT) \
+ { \
+ un = sum; \
+ carry = 0; \
+ } \
+ else \
+ { \
+ un = (sum - BIGNUM_RADIX_ROOT); \
+ carry = 1; \
+ } \
+}
+
+bignum_digit_type
+bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
+ bignum_digit_type guess, bignum_digit_type * u)
+{
+ {
+ bignum_digit_type product;
+ bignum_digit_type diff;
+ bignum_digit_type carry;
+ BDDS_MULSUB (v2, (u[2]), 0);
+ BDDS_MULSUB (v1, (u[1]), carry);
+ if (carry == 0)
+ return (guess);
+ diff = ((u[0]) - carry);
+ if (diff < 0)
+ (u[0]) = (diff + BIGNUM_RADIX);
+ else
+ {
+ (u[0]) = diff;
+ return (guess);
+ }
+ }
+ {
+ bignum_digit_type sum;
+ bignum_digit_type carry;
+ BDDS_ADD(v2, (u[2]), 0);
+ BDDS_ADD(v1, (u[1]), carry);
+ if (carry == 1)
+ (u[0]) += 1;
+ }
+ return (guess - 1);
+}
+
+#undef BDDS_MULSUB
+#undef BDDS_ADD
+
+/* allocates memory */
+void
+bignum_divide_unsigned_small_denominator(bignum * numerator,
+ bignum_digit_type denominator,
+ bignum * * quotient,
+ bignum * * remainder,
+ int q_negative_p,
+ int r_negative_p)
+{
+ 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 * *) 0))
+ (*remainder) = (bignum_digit_to_bignum (r, r_negative_p));
+
+ (*quotient) = q;
+
+ return;
+}
+
+/* Given (denominator > 1), it is fairly easy to show that
+ (quotient_high < BIGNUM_RADIX_ROOT), after which it is easy to see
+ that all digits are < BIGNUM_RADIX. */
+
+bignum_digit_type
+bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator)
+{
+ bignum_digit_type numerator;
+ bignum_digit_type remainder = 0;
+ bignum_digit_type two_digits;
+#define quotient_high remainder
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (bignum)));
+ BIGNUM_ASSERT ((denominator > 1) && (denominator < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ numerator = (HD_CONS (remainder, (HD_HIGH (two_digits))));
+ quotient_high = (numerator / denominator);
+ numerator = (HD_CONS ((numerator % denominator), (HD_LOW (two_digits))));
+ (*scan) = (HD_CONS (quotient_high, (numerator / denominator)));
+ remainder = (numerator % denominator);
+ }
+ return (remainder);
+#undef quotient_high
+}
+
+/* allocates memory */
+bignum *
+bignum_remainder_unsigned_small_denominator(
+ bignum * n, bignum_digit_type d, int negative_p)
+{
+ bignum_digit_type two_digits;
+ bignum_digit_type * start = (BIGNUM_START_PTR (n));
+ bignum_digit_type * scan = (start + (BIGNUM_LENGTH (n)));
+ bignum_digit_type r = 0;
+ BIGNUM_ASSERT ((d > 1) && (d < BIGNUM_RADIX_ROOT));
+ while (start < scan)
+ {
+ two_digits = (*--scan);
+ r =
+ ((HD_CONS (((HD_CONS (r, (HD_HIGH (two_digits)))) % d),
+ (HD_LOW (two_digits))))
+ % d);
+ }
+ return (bignum_digit_to_bignum (r, negative_p));
+}
+
+/* allocates memory */
+bignum *
+bignum_digit_to_bignum(bignum_digit_type digit, int negative_p)
+{
+ if (digit == 0)
+ return (BIGNUM_ZERO ());
+ else
+ {
+ bignum * result = (allot_bignum (1, negative_p));
+ (BIGNUM_REF (result, 0)) = digit;
+ return (result);
+ }
+}
+
+/* allocates memory */
+bignum *
+allot_bignum(bignum_length_type length, int negative_p)
+{
+ BIGNUM_ASSERT ((length >= 0) || (length < BIGNUM_RADIX));
+ bignum * result = allot_array_internal<bignum>(length + 1);
+ BIGNUM_SET_NEGATIVE_P (result, negative_p);
+ return (result);
+}
+
+/* allocates memory */
+bignum *
+allot_bignum_zeroed(bignum_length_type length, int 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)
+ (*scan++) = 0;
+ return (result);
+}
+
+#define BIGNUM_REDUCE_LENGTH(source, length) \
+ source = reallot_array(source,length + 1)
+
+/* allocates memory */
+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));
+ if (length < current_length)
+ {
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
+}
+
+/* allocates memory */
+bignum *
+bignum_trim(bignum * bignum)
+{
+ bignum_digit_type * start = (BIGNUM_START_PTR (bignum));
+ bignum_digit_type * end = (start + (BIGNUM_LENGTH (bignum)));
+ bignum_digit_type * scan = end;
+ while ((start <= scan) && ((*--scan) == 0))
+ ;
+ scan += 1;
+ if (scan < end)
+ {
+ bignum_length_type length = (scan - start);
+ BIGNUM_REDUCE_LENGTH (bignum, length);
+ BIGNUM_SET_NEGATIVE_P (bignum, (length != 0) && (BIGNUM_NEGATIVE_P (bignum)));
+ }
+ return (bignum);
+}
+
+/* Copying */
+
+/* allocates memory */
+bignum *
+bignum_new_sign(bignum * x, int negative_p)
+{
+ GC_BIGNUM(x);
+ bignum * result = (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+
+ bignum_destructive_copy (x, result);
+ return (result);
+}
+
+/* allocates memory */
+bignum *
+bignum_maybe_new_sign(bignum * x, int negative_p)
+{
+ if ((BIGNUM_NEGATIVE_P (x)) ? negative_p : (! negative_p))
+ return (x);
+ else
+ {
+ bignum * result =
+ (allot_bignum ((BIGNUM_LENGTH (x)), negative_p));
+ bignum_destructive_copy (x, result);
+ return (result);
+ }
+}
+
+void
+bignum_destructive_copy(bignum * source, bignum * target)
+{
+ bignum_digit_type * scan_source = (BIGNUM_START_PTR (source));
+ bignum_digit_type * end_source =
+ (scan_source + (BIGNUM_LENGTH (source)));
+ bignum_digit_type * scan_target = (BIGNUM_START_PTR (target));
+ while (scan_source < end_source)
+ (*scan_target++) = (*scan_source++);
+ return;
+}
+
+/*
+ * Added bitwise operations (and oddp).
+ */
+
+/* allocates memory */
+bignum *
+bignum_bitwise_not(bignum * x)
+{
+ return bignum_subtract(BIGNUM_ONE(1), x);
+}
+
+/* allocates memory */
+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));
+ else
+ return bignum_magnitude_ash(arg1, n);
+}
+
+#define AND_OP 0
+#define IOR_OP 1
+#define XOR_OP 2
+
+/* allocates memory */
+bignum *
+bignum_bitwise_and(bignum * arg1, bignum * arg2)
+{
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_negneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(AND_OP, arg2, arg1)
+ : (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_posneg_bitwise_op(AND_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(AND_OP, arg1, arg2)
+ );
+}
+
+/* allocates memory */
+bignum *
+bignum_bitwise_ior(bignum * arg1, bignum * arg2)
+{
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_negneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(IOR_OP, arg2, arg1)
+ : (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_posneg_bitwise_op(IOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(IOR_OP, arg1, arg2)
+ );
+}
+
+/* allocates memory */
+bignum *
+bignum_bitwise_xor(bignum * arg1, bignum * arg2)
+{
+ return(
+ (BIGNUM_NEGATIVE_P (arg1))
+ ? (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_negneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_posneg_bitwise_op(XOR_OP, arg2, arg1)
+ : (BIGNUM_NEGATIVE_P (arg2))
+ ? bignum_posneg_bitwise_op(XOR_OP, arg1, arg2)
+ : bignum_pospos_bitwise_op(XOR_OP, arg1, arg2)
+ );
+}
+
+/* allocates memory */
+/* ash for the magnitude */
+/* assume arg1 is a big number, n is a long */
+bignum *
+bignum_magnitude_ash(bignum * arg1, fixnum n)
+{
+ GC_BIGNUM(arg1);
+
+ bignum * result = NULL;
+ bignum_digit_type *scan1;
+ bignum_digit_type *scanr;
+ bignum_digit_type *end;
+
+ fixnum digit_offset,bit_offset;
+
+ if (BIGNUM_ZERO_P (arg1)) return (arg1);
+
+ if (n > 0) {
+ digit_offset = n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = n % BIGNUM_DIGIT_LENGTH;
+
+ result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) + digit_offset + 1,
+ BIGNUM_NEGATIVE_P(arg1));
+
+ scanr = BIGNUM_START_PTR (result) + digit_offset;
+ scan1 = BIGNUM_START_PTR (arg1);
+ end = scan1 + BIGNUM_LENGTH (arg1);
+
+ while (scan1 < end) {
+ *scanr = *scanr | (*scan1 & BIGNUM_DIGIT_MASK) << bit_offset;
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ scanr++;
+ *scanr = *scan1++ >> (BIGNUM_DIGIT_LENGTH - bit_offset);
+ *scanr = *scanr & BIGNUM_DIGIT_MASK;
+ }
+ }
+ else if (n < 0
+ && (-n >= (BIGNUM_LENGTH (arg1) * (bignum_length_type) BIGNUM_DIGIT_LENGTH)))
+ result = BIGNUM_ZERO ();
+
+ else if (n < 0) {
+ digit_offset = -n / BIGNUM_DIGIT_LENGTH;
+ bit_offset = -n % BIGNUM_DIGIT_LENGTH;
+
+ result = allot_bignum_zeroed (BIGNUM_LENGTH (arg1) - digit_offset,
+ BIGNUM_NEGATIVE_P(arg1));
+
+ scanr = BIGNUM_START_PTR (result);
+ scan1 = BIGNUM_START_PTR (arg1) + digit_offset;
+ end = scanr + BIGNUM_LENGTH (result) - 1;
+
+ while (scanr < end) {
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ *scanr = (*scanr |
+ *scan1 << (BIGNUM_DIGIT_LENGTH - bit_offset)) & BIGNUM_DIGIT_MASK;
+ scanr++;
+ }
+ *scanr = (*scan1++ & BIGNUM_DIGIT_MASK) >> bit_offset ;
+ }
+ else if (n == 0) result = arg1;
+
+ return (bignum_trim (result));
+}
+
+/* allocates memory */
+bignum *
+bignum_pospos_bitwise_op(int op, bignum * arg1, bignum * arg2)
+{
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+
+ bignum * result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2;
+ bignum_digit_type *scanr, *endr;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2);
+
+ result = allot_bignum(max_length, 0);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (scan2 < end2) ? *scan2++ : 0;
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+ return bignum_trim(result);
+}
+
+/* allocates memory */
+bignum *
+bignum_posneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+{
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+
+ bignum * result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
+
+ char neg_p = op == IOR_OP || op == XOR_OP;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2) + 1)
+ ? BIGNUM_LENGTH(arg1) : BIGNUM_LENGTH(arg2) + 1;
+
+ result = allot_bignum(max_length, neg_p);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ carry2 = 1;
+
+ while (scanr < endr) {
+ digit1 = (scan1 < end1) ? *scan1++ : 0;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK)
+ + carry2;
+
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+
+ if (neg_p)
+ bignum_negate_magnitude(result);
+
+ return bignum_trim(result);
+}
+
+/* allocates memory */
+bignum *
+bignum_negneg_bitwise_op(int op, bignum * arg1, bignum * arg2)
+{
+ GC_BIGNUM(arg1); GC_BIGNUM(arg2);
+
+ bignum * result;
+ bignum_length_type max_length;
+
+ bignum_digit_type *scan1, *end1, digit1, carry1;
+ bignum_digit_type *scan2, *end2, digit2, carry2;
+ bignum_digit_type *scanr, *endr;
+
+ char neg_p = op == AND_OP || op == IOR_OP;
+
+ max_length = (BIGNUM_LENGTH(arg1) > BIGNUM_LENGTH(arg2))
+ ? BIGNUM_LENGTH(arg1) + 1 : BIGNUM_LENGTH(arg2) + 1;
+
+ result = allot_bignum(max_length, neg_p);
+
+ scanr = BIGNUM_START_PTR(result);
+ scan1 = BIGNUM_START_PTR(arg1);
+ scan2 = BIGNUM_START_PTR(arg2);
+ endr = scanr + max_length;
+ end1 = scan1 + BIGNUM_LENGTH(arg1);
+ end2 = scan2 + BIGNUM_LENGTH(arg2);
+
+ carry1 = 1;
+ carry2 = 1;
+
+ while (scanr < endr) {
+ digit1 = (~((scan1 < end1) ? *scan1++ : 0) & BIGNUM_DIGIT_MASK) + carry1;
+ digit2 = (~((scan2 < end2) ? *scan2++ : 0) & BIGNUM_DIGIT_MASK) + carry2;
+
+ if (digit1 < BIGNUM_RADIX)
+ carry1 = 0;
+ else
+ {
+ digit1 = (digit1 - BIGNUM_RADIX);
+ carry1 = 1;
+ }
+
+ if (digit2 < BIGNUM_RADIX)
+ carry2 = 0;
+ else
+ {
+ digit2 = (digit2 - BIGNUM_RADIX);
+ carry2 = 1;
+ }
+
+ *scanr++ = (op == AND_OP) ? digit1 & digit2 :
+ (op == IOR_OP) ? digit1 | digit2 :
+ digit1 ^ digit2;
+ }
+
+ if (neg_p)
+ bignum_negate_magnitude(result);
+
+ return bignum_trim(result);
+}
+
+void
+bignum_negate_magnitude(bignum * arg)
+{
+ bignum_digit_type *scan;
+ bignum_digit_type *end;
+ bignum_digit_type digit;
+ bignum_digit_type carry;
+
+ scan = BIGNUM_START_PTR(arg);
+ end = scan + BIGNUM_LENGTH(arg);
+
+ carry = 1;
+
+ while (scan < end) {
+ digit = (~*scan & BIGNUM_DIGIT_MASK) + carry;
+
+ if (digit < BIGNUM_RADIX)
+ carry = 0;
+ else
+ {
+ digit = (digit - BIGNUM_RADIX);
+ carry = 1;
+ }
+
+ *scan++ = digit;
+ }
+}
+
+/* Allocates memory */
+bignum *
+bignum_integer_length(bignum * x)
+{
+ GC_BIGNUM(x);
+
+ 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;
+ bignum_destructive_scale_up (result, BIGNUM_DIGIT_LENGTH);
+ while (digit > 1)
+ {
+ bignum_destructive_add (result, ((bignum_digit_type) 1));
+ digit >>= 1;
+ }
+ return (bignum_trim (result));
+}
+
+/* Allocates memory */
+int
+bignum_logbitp(int shift, bignum * arg)
+{
+ return((BIGNUM_NEGATIVE_P (arg))
+ ? !bignum_unsigned_logbitp (shift, bignum_bitwise_not (arg))
+ : bignum_unsigned_logbitp (shift,arg));
+}
+
+int
+bignum_unsigned_logbitp(int shift, bignum * bignum)
+{
+ bignum_length_type len = (BIGNUM_LENGTH (bignum));
+ int index = shift / BIGNUM_DIGIT_LENGTH;
+ if (index >= len)
+ return 0;
+ bignum_digit_type digit = (BIGNUM_REF (bignum, index));
+ int p = shift % BIGNUM_DIGIT_LENGTH;
+ bignum_digit_type mask = ((fixnum)1) << p;
+ return (digit & mask) ? 1 : 0;
+}
+
+/* Allocates memory */
+bignum *
+digit_stream_to_bignum(unsigned int n_digits,
+ unsigned int (*producer)(unsigned int),
+ unsigned int radix,
+ int negative_p)
+{
+ BIGNUM_ASSERT ((radix > 1) && (radix <= BIGNUM_RADIX_ROOT));
+ if (n_digits == 0)
+ return (BIGNUM_ZERO ());
+ if (n_digits == 1)
+ {
+ fixnum digit = ((fixnum) ((*producer) (0)));
+ return (fixnum_to_bignum (negative_p ? (- digit) : digit));
+ }
+ {
+ bignum_length_type length;
+ {
+ unsigned int radix_copy = radix;
+ unsigned int log_radix = 0;
+ while (radix_copy > 0)
+ {
+ radix_copy >>= 1;
+ log_radix += 1;
+ }
+ /* This length will be at least as large as needed. */
+ length = (BIGNUM_BITS_TO_DIGITS (n_digits * log_radix));
+ }
+ {
+ bignum * result = (allot_bignum_zeroed (length, negative_p));
+ while ((n_digits--) > 0)
+ {
+ bignum_destructive_scale_up (result, ((bignum_digit_type) radix));
+ bignum_destructive_add
+ (result, ((bignum_digit_type) ((*producer) (n_digits))));
+ }
+ return (bignum_trim (result));
+ }
+ }
+}
+
+}
+++ /dev/null
-/* :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);
--- /dev/null
+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);
+
+}
+++ /dev/null
-/* -*-C-*-
-
-$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
-
-Copyright (c) 1989-1992 Massachusetts Institute of Technology
-
-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. */
-
-/* Internal Interface to Bignum Code */
-#undef BIGNUM_ZERO_P
-#undef BIGNUM_NEGATIVE_P
-
-/* The memory model is based on the following definitions, and on the
- definition of the type `bignum_type'. The only other special
- 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;
-
-/* BIGNUM_TO_POINTER casts a bignum object to a digit array pointer. */
-#define BIGNUM_TO_POINTER(bignum) ((bignum_digit_type *)AREF(bignum,0))
-
-/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
-#define BIGNUM_EXCEPTION abort
-
-
-#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_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_NEGATIVE_P(bignum) (array_nth(bignum,0) != 0)
-#define BIGNUM_SET_NEGATIVE_P(bignum,neg) put(AREF(bignum,0),neg)
-
-#define BIGNUM_ZERO_P(bignum) \
- ((BIGNUM_LENGTH (bignum)) == 0)
-
-#define BIGNUM_REF(bignum, index) \
- (* ((BIGNUM_START_PTR (bignum)) + (index)))
-
-/* These definitions are here to facilitate caching of the constants
- 0, 1, and -1. */
-#define BIGNUM_ZERO() untag_object(bignum_zero)
-#define BIGNUM_ONE(neg_p) \
- untag_object(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)
-#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low))
-
-#define BIGNUM_BITS_TO_DIGITS(n) \
- (((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH)
-
-#define BIGNUM_DIGITS_FOR(type) \
- (BIGNUM_BITS_TO_DIGITS ((sizeof (type)) * CHAR_BIT))
-
-#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS
-
-#define BIGNUM_ASSERT(expression) \
-{ \
- if (! (expression)) \
- BIGNUM_EXCEPTION (); \
-}
-
-#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */
--- /dev/null
+/* -*-C-*-
+
+$Id: s48_bignumint.h,v 1.14 2005/12/21 02:36:52 spestov Exp $
+
+Copyright (c) 1989-1992 Massachusetts Institute of Technology
+
+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. */
+
+namespace factor
+{
+
+/* Internal Interface to Bignum Code */
+#undef BIGNUM_ZERO_P
+#undef BIGNUM_NEGATIVE_P
+
+/* The memory model is based on the following definitions, and on the
+ definition of the type `bignum_type'. The only other special
+ definition is `CHAR_BIT', which is defined in the Ansi C header
+ file "limits.h". */
+
+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 *)(bignum + 1))
+
+/* BIGNUM_EXCEPTION is invoked to handle assertion violations. */
+#define BIGNUM_EXCEPTION abort
+
+
+#define BIGNUM_DIGIT_LENGTH (((sizeof (bignum_digit_type)) * CHAR_BIT) - 2)
+#define BIGNUM_HALF_DIGIT_LENGTH (BIGNUM_DIGIT_LENGTH / 2)
+#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((bignum)->capacity) - 1)
+
+#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)
+
+#define BIGNUM_REF(bignum, index) \
+ (* ((BIGNUM_START_PTR (bignum)) + (index)))
+
+/* These definitions are here to facilitate caching of the constants
+ 0, 1, and -1. */
+#define BIGNUM_ZERO() untag<bignum>(bignum_zero)
+#define BIGNUM_ONE(neg_p) \
+ 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)
+#define HD_CONS(high, low) (((high) << BIGNUM_HALF_DIGIT_LENGTH) | (low))
+
+#define BIGNUM_BITS_TO_DIGITS(n) \
+ (((n) + (BIGNUM_DIGIT_LENGTH - 1)) / BIGNUM_DIGIT_LENGTH)
+
+#define BIGNUM_DIGITS_FOR(type) \
+ (BIGNUM_BITS_TO_DIGITS ((sizeof (type)) * CHAR_BIT))
+
+#ifndef BIGNUM_DISABLE_ASSERTION_CHECKS
+
+#define BIGNUM_ASSERT(expression) \
+{ \
+ if (! (expression)) \
+ BIGNUM_EXCEPTION (); \
+}
+
+#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */
+
+}
--- /dev/null
+#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;
+}
+
+}
--- /dev/null
+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);
+
+}
--- /dev/null
+#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);
+}
+
+}
--- /dev/null
+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();
+};
+
+}
+++ /dev/null
-#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;
-}
--- /dev/null
+#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;
+}
+
+}
+++ /dev/null
-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);
--- /dev/null
+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);
+
+}
+++ /dev/null
-#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;
-}
--- /dev/null
+#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)
+ 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;
+}
+
+}
+++ /dev/null
-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);
--- /dev/null
+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);
+
+}
+++ /dev/null
-#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;
- }
-}
--- /dev/null
+#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;
+ }
+}
+
+}
+++ /dev/null
-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;
-}
--- /dev/null
+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;
+}
+
+}
+++ /dev/null
-#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);
-}
--- /dev/null
+#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);
+}
+
+}
+++ /dev/null
-/* 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);
--- /dev/null
+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
+}
+
+}
--- /dev/null
+#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);
+ }
+}
+
+}
--- /dev/null
+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;
+++ /dev/null
-#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);
--- /dev/null
+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);
+
+}
/* 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 \
+++ /dev/null
-#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);
--- /dev/null
+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);
+
+}
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
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
+++ /dev/null
-#define FACTOR_CPU_STRING "x86.32"
-
-register CELL ds asm("esi");
-register CELL rs asm("edi");
-
-#define F_FASTCALL __attribute__ ((regparm (2)))
--- /dev/null
+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)))
+
+}
#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
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"
+++ /dev/null
-#define FACTOR_CPU_STRING "x86.64"
-
-register CELL ds asm("r14");
-register CELL rs asm("r15");
-
-#define F_FASTCALL
--- /dev/null
+namespace factor
+{
+
+#define FACTOR_CPU_STRING "x86.64"
+
+register cell ds asm("r14");
+register cell rs asm("r15");
+
+#define VM_ASM_API extern "C"
+
+}
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)
+++ /dev/null
-#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);
--- /dev/null
+#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));
+
+}
+++ /dev/null
-#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();
-}
--- /dev/null
+#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);
+}
+
+}
+++ /dev/null
-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);
--- /dev/null
+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);
+
+}
+++ /dev/null
-#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;
-}
--- /dev/null
+#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();
+}
+
+}
+++ /dev/null
-/* 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;
- }
-}
--- /dev/null
+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;
+++ /dev/null
-#include "master.h"
-
-static bool full_output;
-
-void print_chars(F_STRING* str)
-{
- CELL i;
- for(i = 0; i < string_capacity(str); i++)
- putchar(string_nth(str,i));
-}
-
-void print_word(F_WORD* word, CELL nesting)
-{
-
- if(type_of(word->vocabulary) == STRING_TYPE)
- {
- print_chars(untag_string(word->vocabulary));
- print_string(":");
- }
-
- if(type_of(word->name) == STRING_TYPE)
- print_chars(untag_string(word->name));
- else
- {
- print_string("#<not a string: ");
- print_nested_obj(word->name,nesting);
- print_string(">");
- }
-}
-
-void print_factor_string(F_STRING* str)
-{
- putchar('"');
- print_chars(str);
- putchar('"');
-}
-
-void print_array(F_ARRAY* array, CELL nesting)
-{
- CELL length = array_capacity(array);
- CELL i;
- bool trimmed;
-
- if(length > 10 && !full_output)
- {
- trimmed = true;
- length = 10;
- }
- else
- trimmed = false;
-
- for(i = 0; i < length; i++)
- {
- print_string(" ");
- print_nested_obj(array_nth(array,i),nesting);
- }
-
- if(trimmed)
- print_string("...");
-}
-
-void print_tuple(F_TUPLE* tuple, CELL nesting)
-{
- F_TUPLE_LAYOUT *layout = untag_object(tuple->layout);
- CELL length = to_fixnum(layout->size);
-
- print_string(" ");
- print_nested_obj(layout->class,nesting);
-
- CELL i;
- bool trimmed;
-
- if(length > 10 && !full_output)
- {
- trimmed = true;
- length = 10;
- }
- else
- trimmed = false;
-
- for(i = 0; i < length; i++)
- {
- print_string(" ");
- print_nested_obj(tuple_nth(tuple,i),nesting);
- }
-
- if(trimmed)
- print_string("...");
-}
-
-void print_nested_obj(CELL obj, F_FIXNUM nesting)
-{
- if(nesting <= 0 && !full_output)
- {
- print_string(" ... ");
- return;
- }
-
- F_QUOTATION *quot;
-
- switch(type_of(obj))
- {
- case FIXNUM_TYPE:
- print_fixnum(untag_fixnum_fast(obj));
- break;
- case WORD_TYPE:
- print_word(untag_word(obj),nesting - 1);
- break;
- case STRING_TYPE:
- 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_string(" }");
- break;
- case ARRAY_TYPE:
- print_string("{");
- print_array(untag_object(obj),nesting - 1);
- print_string(" }");
- break;
- case QUOTATION_TYPE:
- print_string("[");
- quot = untag_object(obj);
- print_array(untag_object(quot->array),nesting - 1);
- print_string(" ]");
- break;
- default:
- print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj); print_string(">");
- break;
- }
-}
-
-void print_obj(CELL obj)
-{
- print_nested_obj(obj,10);
-}
-
-void print_objects(CELL start, CELL end)
-{
- for(; start <= end; start += CELLS)
- {
- print_obj(get(start));
- nl();
- }
-}
-
-void print_datastack(void)
-{
- print_string("==== DATA STACK:\n");
- print_objects(ds_bot,ds);
-}
-
-void print_retainstack(void)
-{
- print_string("==== RETAIN STACK:\n");
- print_objects(rs_bot,rs);
-}
-
-void print_stack_frame(F_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_string(" ");
- 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;
- iterate_callstack(top,bottom,print_stack_frame);
-}
-
-void dump_cell(CELL cell)
-{
- 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;
- }
-
- nl();
-}
-
-void dump_memory(CELL from, CELL to)
-{
- from = UNTAG(from);
-
- for(; from <= to; from += CELLS)
- dump_cell(from);
-}
-
-void dump_zone(F_ZONE *z)
-{
- print_string("Start="); print_cell(z->start);
- print_string(", size="); print_cell(z->size);
- print_string(", here="); print_cell(z->here - z->start); nl();
-}
-
-void dump_generations(void)
-{
- CELL i;
-
- print_string("Nursery: ");
- dump_zone(&nursery);
-
- for(i = 1; i < data_heap->gen_count; i++)
- {
- print_string("Generation "); print_cell(i); print_string(": ");
- dump_zone(&data_heap->generations[i]);
- }
-
- for(i = 0; i < data_heap->gen_count; i++)
- {
- print_string("Semispace "); print_cell(i); print_string(": ");
- dump_zone(&data_heap->semispaces[i]);
- }
-
- print_string("Cards: base=");
- print_cell((CELL)data_heap->cards);
- print_string(", size=");
- print_cell((CELL)(data_heap->cards_end - data_heap->cards));
- nl();
-}
-
-void dump_objects(F_FIXNUM type)
-{
- gc();
- begin_scan();
-
- CELL obj;
- while((obj = next_object()) != F)
- {
- if(type == -1 || type_of(obj) == type)
- {
- print_cell_hex_pad(obj);
- print_string(" ");
- print_nested_obj(obj,2);
- nl();
- }
- }
-
- /* end scan */
- gc_off = false;
-}
-
-CELL look_for;
-CELL obj;
-
-void find_data_references_step(CELL *scan)
-{
- if(look_for == *scan)
- {
- print_cell_hex_pad(obj);
- print_string(" ");
- print_nested_obj(obj,2);
- nl();
- }
-}
-
-void find_data_references(CELL look_for_)
-{
- look_for = look_for_;
-
- begin_scan();
-
- while((obj = next_object()) != F)
- do_slots(UNTAG(obj),find_data_references_step);
-
- /* end scan */
- gc_off = false;
-}
-
-/* Dump all code blocks for debugging */
-void dump_code_heap(void)
-{
- CELL reloc_size = 0, literal_size = 0;
-
- F_BLOCK *scan = first_block(&code_heap);
-
- while(scan)
- {
- 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);
- status = "allocated";
- break;
- case B_MARKED:
- reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
- literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
- status = "marked";
- break;
- default:
- status = "invalid";
- break;
- }
-
- 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);
- }
-
- print_cell(reloc_size); print_string(" bytes of relocation data\n");
- print_cell(literal_size); print_string(" bytes of literal data\n");
-}
-
-void factorbug(void)
-{
- if(fep_disabled)
- {
- print_string("Low level debugger disabled\n");
- exit(1);
- }
-
- /* open_console(); */
-
- print_string("Starting low level debugger...\n");
- print_string(" Basic commands:\n");
- print_string("q -- continue executing Factor - NOT SAFE\n");
- print_string("im -- save image to fep.image\n");
- print_string("x -- exit Factor\n");
- print_string(" Advanced commands:\n");
- print_string("d <addr> <count> -- dump memory\n");
- print_string("u <addr> -- dump object at tagged <addr>\n");
- print_string(". <addr> -- print object at tagged <addr>\n");
- print_string("t -- toggle output trimming\n");
- print_string("s r -- dump data, retain stacks\n");
- print_string(".s .r .c -- print data, retain, call stacks\n");
- print_string("e -- dump environment\n");
- print_string("g -- dump generations\n");
- print_string("card <addr> -- print card containing address\n");
- print_string("addr <card> -- print address containing card\n");
- print_string("data -- data heap dump\n");
- print_string("words -- words dump\n");
- print_string("tuples -- tuples dump\n");
- print_string("refs <addr> -- find data heap references to object\n");
- print_string("push <addr> -- push object on data stack - NOT SAFE\n");
- print_string("code -- code heap dump\n");
-
- bool seen_command = false;
-
- for(;;)
- {
- char cmd[1024];
-
- print_string("READY\n");
- fflush(stdout);
-
- if(scanf("%1000s",cmd) <= 0)
- {
- if(!seen_command)
- {
- /* If we exit with an EOF immediately, then
- dump stacks. This is useful for builder and
- other cases where Factor is run with stdin
- redirected to /dev/null */
- fep_disabled = true;
-
- print_datastack();
- print_retainstack();
- print_callstack();
- }
-
- exit(1);
- }
-
- seen_command = true;
-
- if(strcmp(cmd,"d") == 0)
- {
- CELL addr = read_cell_hex();
- scanf(" ");
- 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);
- dump_memory(addr,addr+count);
- }
- else if(strcmp(cmd,".") == 0)
- {
- CELL addr = read_cell_hex();
- print_obj(addr);
- print_string("\n");
- }
- else if(strcmp(cmd,"t") == 0)
- full_output = !full_output;
- else if(strcmp(cmd,"s") == 0)
- dump_memory(ds_bot,ds);
- else if(strcmp(cmd,"r") == 0)
- dump_memory(rs_bot,rs);
- else if(strcmp(cmd,".s") == 0)
- print_datastack();
- else if(strcmp(cmd,".r") == 0)
- print_retainstack();
- else if(strcmp(cmd,".c") == 0)
- print_callstack();
- else if(strcmp(cmd,"e") == 0)
- {
- int i;
- for(i = 0; i < USER_ENV; 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));
- nl();
- }
- else if(strcmp(cmd,"addr") == 0)
- {
- CELL card = read_cell_hex();
- print_cell_hex((CELL)CARD_TO_ADDR(card));
- nl();
- }
- else if(strcmp(cmd,"q") == 0)
- return;
- else if(strcmp(cmd,"x") == 0)
- exit(1);
- else if(strcmp(cmd,"im") == 0)
- save_image(STRING_LITERAL("fep.image"));
- else if(strcmp(cmd,"data") == 0)
- dump_objects(-1);
- else if(strcmp(cmd,"refs") == 0)
- {
- CELL addr = read_cell_hex();
- print_string("Data heap references:\n");
- find_data_references(addr);
- nl();
- }
- else if(strcmp(cmd,"words") == 0)
- dump_objects(WORD_TYPE);
- else if(strcmp(cmd,"tuples") == 0)
- dump_objects(TUPLE_TYPE);
- else if(strcmp(cmd,"push") == 0)
- {
- CELL addr = read_cell_hex();
- dpush(addr);
- }
- else if(strcmp(cmd,"code") == 0)
- dump_code_heap();
- else
- print_string("unknown command\n");
- }
-}
-
-void primitive_die(void)
-{
- 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();
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+static bool fep_disabled;
+static bool full_output;
+
+void print_chars(string* str)
+{
+ cell i;
+ for(i = 0; i < string_capacity(str); i++)
+ putchar(string_nth(str,i));
+}
+
+void print_word(word* word, cell nesting)
+{
+ if(tagged<object>(word->vocabulary).type_p(STRING_TYPE))
+ {
+ print_chars(untag<string>(word->vocabulary));
+ print_string(":");
+ }
+
+ if(tagged<object>(word->name).type_p(STRING_TYPE))
+ print_chars(untag<string>(word->name));
+ else
+ {
+ print_string("#<not a string: ");
+ print_nested_obj(word->name,nesting);
+ print_string(">");
+ }
+}
+
+void print_factor_string(string* str)
+{
+ putchar('"');
+ print_chars(str);
+ putchar('"');
+}
+
+void print_array(array* array, cell nesting)
+{
+ cell length = array_capacity(array);
+ cell i;
+ bool trimmed;
+
+ if(length > 10 && !full_output)
+ {
+ trimmed = true;
+ length = 10;
+ }
+ else
+ trimmed = false;
+
+ for(i = 0; i < length; i++)
+ {
+ print_string(" ");
+ print_nested_obj(array_nth(array,i),nesting);
+ }
+
+ if(trimmed)
+ print_string("...");
+}
+
+void print_tuple(tuple *tuple, cell nesting)
+{
+ tuple_layout *layout = untag<tuple_layout>(tuple->layout);
+ cell length = to_fixnum(layout->size);
+
+ print_string(" ");
+ print_nested_obj(layout->klass,nesting);
+
+ cell i;
+ bool trimmed;
+
+ if(length > 10 && !full_output)
+ {
+ trimmed = true;
+ length = 10;
+ }
+ else
+ trimmed = false;
+
+ for(i = 0; i < length; i++)
+ {
+ print_string(" ");
+ print_nested_obj(tuple->data()[i],nesting);
+ }
+
+ if(trimmed)
+ print_string("...");
+}
+
+void print_nested_obj(cell obj, fixnum nesting)
+{
+ if(nesting <= 0 && !full_output)
+ {
+ print_string(" ... ");
+ return;
+ }
+
+ quotation *quot;
+
+ switch(tagged<object>(obj).type())
+ {
+ case FIXNUM_TYPE:
+ print_fixnum(untag_fixnum(obj));
+ break;
+ case WORD_TYPE:
+ print_word(untag<word>(obj),nesting - 1);
+ break;
+ case STRING_TYPE:
+ print_factor_string(untag<string>(obj));
+ break;
+ case F_TYPE:
+ print_string("f");
+ break;
+ case TUPLE_TYPE:
+ print_string("T{");
+ print_tuple(untag<tuple>(obj),nesting - 1);
+ print_string(" }");
+ break;
+ case ARRAY_TYPE:
+ print_string("{");
+ print_array(untag<array>(obj),nesting - 1);
+ print_string(" }");
+ break;
+ case QUOTATION_TYPE:
+ print_string("[");
+ quot = untag<quotation>(obj);
+ print_array(untag<array>(quot->array),nesting - 1);
+ print_string(" ]");
+ break;
+ default:
+ print_string("#<type ");
+ print_cell(tagged<object>(obj).type());
+ print_string(" @ ");
+ print_cell_hex(obj);
+ print_string(">");
+ break;
+ }
+}
+
+void print_obj(cell obj)
+{
+ print_nested_obj(obj,10);
+}
+
+void print_objects(cell *start, cell *end)
+{
+ for(; start <= end; start++)
+ {
+ print_obj(*start);
+ nl();
+ }
+}
+
+void print_datastack(void)
+{
+ print_string("==== DATA STACK:\n");
+ print_objects((cell *)ds_bot,(cell *)ds);
+}
+
+void print_retainstack(void)
+{
+ print_string("==== RETAIN STACK:\n");
+ print_objects((cell *)rs_bot,(cell *)rs);
+}
+
+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_string(" ");
+ 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;
+ iterate_callstack(top,bottom,print_stack_frame);
+}
+
+void dump_cell(cell x)
+{
+ 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)
+{
+ from = UNTAG(from);
+
+ for(; from <= to; from += sizeof(cell))
+ dump_cell(from);
+}
+
+void dump_zone(zone *z)
+{
+ print_string("Start="); print_cell(z->start);
+ print_string(", size="); print_cell(z->size);
+ print_string(", here="); print_cell(z->here - z->start); nl();
+}
+
+void dump_generations(void)
+{
+ cell i;
+
+ print_string("Nursery: ");
+ dump_zone(&nursery);
+
+ for(i = 1; i < data->gen_count; i++)
+ {
+ print_string("Generation "); print_cell(i); print_string(": ");
+ dump_zone(&data->generations[i]);
+ }
+
+ for(i = 0; i < data->gen_count; i++)
+ {
+ print_string("Semispace "); print_cell(i); print_string(": ");
+ dump_zone(&data->semispaces[i]);
+ }
+
+ print_string("Cards: base=");
+ print_cell((cell)data->cards);
+ print_string(", size=");
+ print_cell((cell)(data->cards_end - data->cards));
+ nl();
+}
+
+void dump_objects(cell type)
+{
+ gc();
+ begin_scan();
+
+ cell obj;
+ while((obj = next_object()) != F)
+ {
+ if(type == TYPE_COUNT || tagged<object>(obj).type_p(type))
+ {
+ print_cell_hex_pad(obj);
+ print_string(" ");
+ print_nested_obj(obj,2);
+ nl();
+ }
+ }
+
+ /* end scan */
+ gc_off = false;
+}
+
+cell look_for;
+cell obj;
+
+void find_data_references_step(cell *scan)
+{
+ if(look_for == *scan)
+ {
+ print_cell_hex_pad(obj);
+ print_string(" ");
+ print_nested_obj(obj,2);
+ nl();
+ }
+}
+
+void find_data_references(cell look_for_)
+{
+ look_for = look_for_;
+
+ begin_scan();
+
+ while((obj = next_object()) != F)
+ do_slots(UNTAG(obj),find_data_references_step);
+
+ /* end scan */
+ gc_off = false;
+}
+
+/* Dump all code blocks for debugging */
+void dump_code_heap(void)
+{
+ cell reloc_size = 0, literal_size = 0;
+
+ heap_block *scan = first_block(&code);
+
+ while(scan)
+ {
+ const char *status;
+ switch(scan->status)
+ {
+ case B_FREE:
+ status = "free";
+ break;
+ case B_ALLOCATED:
+ 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(((code_block *)scan)->relocation);
+ literal_size += object_size(((code_block *)scan)->literals);
+ status = "marked";
+ break;
+ default:
+ status = "invalid";
+ break;
+ }
+
+ print_cell_hex((cell)scan); print_string(" ");
+ print_cell_hex(scan->size); print_string(" ");
+ print_string(status); print_string("\n");
+
+ scan = next_block(&code,scan);
+ }
+
+ print_cell(reloc_size); print_string(" bytes of relocation data\n");
+ print_cell(literal_size); print_string(" bytes of literal data\n");
+}
+
+void factorbug(void)
+{
+ if(fep_disabled)
+ {
+ print_string("Low level debugger disabled\n");
+ exit(1);
+ }
+
+ /* open_console(); */
+
+ print_string("Starting low level debugger...\n");
+ print_string(" Basic commands:\n");
+ print_string("q -- continue executing Factor - NOT SAFE\n");
+ print_string("im -- save image to fep.image\n");
+ print_string("x -- exit Factor\n");
+ print_string(" Advanced commands:\n");
+ print_string("d <addr> <count> -- dump memory\n");
+ print_string("u <addr> -- dump object at tagged <addr>\n");
+ print_string(". <addr> -- print object at tagged <addr>\n");
+ print_string("t -- toggle output trimming\n");
+ print_string("s r -- dump data, retain stacks\n");
+ print_string(".s .r .c -- print data, retain, call stacks\n");
+ print_string("e -- dump environment\n");
+ print_string("g -- dump generations\n");
+ print_string("card <addr> -- print card containing address\n");
+ print_string("addr <card> -- print address containing card\n");
+ print_string("data -- data heap dump\n");
+ print_string("words -- words dump\n");
+ print_string("tuples -- tuples dump\n");
+ print_string("refs <addr> -- find data heap references to object\n");
+ print_string("push <addr> -- push object on data stack - NOT SAFE\n");
+ print_string("code -- code heap dump\n");
+
+ bool seen_command = false;
+
+ for(;;)
+ {
+ char cmd[1024];
+
+ print_string("READY\n");
+ fflush(stdout);
+
+ if(scanf("%1000s",cmd) <= 0)
+ {
+ if(!seen_command)
+ {
+ /* If we exit with an EOF immediately, then
+ dump stacks. This is useful for builder and
+ other cases where Factor is run with stdin
+ redirected to /dev/null */
+ fep_disabled = true;
+
+ print_datastack();
+ print_retainstack();
+ print_callstack();
+ }
+
+ exit(1);
+ }
+
+ seen_command = true;
+
+ if(strcmp(cmd,"d") == 0)
+ {
+ 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);
+ dump_memory(addr,addr+count);
+ }
+ else if(strcmp(cmd,".") == 0)
+ {
+ cell addr = read_cell_hex();
+ print_obj(addr);
+ print_string("\n");
+ }
+ else if(strcmp(cmd,"t") == 0)
+ full_output = !full_output;
+ else if(strcmp(cmd,"s") == 0)
+ dump_memory(ds_bot,ds);
+ else if(strcmp(cmd,"r") == 0)
+ dump_memory(rs_bot,rs);
+ else if(strcmp(cmd,".s") == 0)
+ print_datastack();
+ else if(strcmp(cmd,".r") == 0)
+ print_retainstack();
+ else if(strcmp(cmd,".c") == 0)
+ print_callstack();
+ else if(strcmp(cmd,"e") == 0)
+ {
+ int i;
+ for(i = 0; i < USER_ENV; 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));
+ nl();
+ }
+ else if(strcmp(cmd,"addr") == 0)
+ {
+ card *ptr = (card *)read_cell_hex();
+ print_cell_hex(card_to_addr(ptr));
+ nl();
+ }
+ else if(strcmp(cmd,"q") == 0)
+ return;
+ else if(strcmp(cmd,"x") == 0)
+ exit(1);
+ else if(strcmp(cmd,"im") == 0)
+ save_image(STRING_LITERAL("fep.image"));
+ else if(strcmp(cmd,"data") == 0)
+ dump_objects(TYPE_COUNT);
+ else if(strcmp(cmd,"refs") == 0)
+ {
+ cell addr = read_cell_hex();
+ print_string("Data heap references:\n");
+ find_data_references(addr);
+ nl();
+ }
+ else if(strcmp(cmd,"words") == 0)
+ dump_objects(WORD_TYPE);
+ else if(strcmp(cmd,"tuples") == 0)
+ dump_objects(TUPLE_TYPE);
+ else if(strcmp(cmd,"push") == 0)
+ {
+ cell addr = read_cell_hex();
+ dpush(addr);
+ }
+ else if(strcmp(cmd,"code") == 0)
+ dump_code_heap();
+ else
+ print_string("unknown command\n");
+ }
+}
+
+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();
+}
+
+}
+++ /dev/null
-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);
--- /dev/null
+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);
+
+}
--- /dev/null
+#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]);
+}
+
+}
--- /dev/null
+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);
+
+}
+++ /dev/null
-#include "master.h"
-
-void out_of_memory(void)
-{
- print_string("Out of memory\n\n");
- dump_generations();
- exit(1);
-}
-
-void fatal_error(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)
-{
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("critical_error: "); print_string(msg);
- print_string(": "); print_cell_hex(tagged); nl();
- factorbug();
-}
-
-void throw_error(CELL error, F_STACK_FRAME *callstack_top)
-{
- /* If the error handler is set, we rewind any C stack frames and
- pass the error to user-space. */
- if(userenv[BREAK_ENV] != F)
- {
- /* If error was thrown during heap scan, we re-enable the GC */
- gc_off = false;
-
- /* Reset local roots */
- gc_locals = gc_locals_region->start - CELLS;
- extra_roots = extra_roots_region->start - CELLS;
-
- /* If we had an underflow or overflow, stack pointers might be
- out of bounds */
- fix_stacks();
-
- dpush(error);
-
- /* Errors thrown from C code pass NULL for this parameter.
- Errors thrown from Factor code, or signal handlers, pass the
- actual stack pointer at the time, since the saved pointer is
- not necessarily up to date at that point. */
- if(callstack_top)
- {
- callstack_top = fix_callstack_top(callstack_top,
- stack_chain->callstack_bottom);
- }
- else
- callstack_top = stack_chain->callstack_top;
-
- throw_impl(userenv[BREAK_ENV],callstack_top);
- }
- /* Error was thrown in early startup before error handler is set, just
- crash. */
- else
- {
- print_string("You have triggered a bug in Factor. Please report.\n");
- print_string("early_error: ");
- print_obj(error);
- nl();
- factorbug();
- }
-}
-
-void general_error(F_ERRORTYPE error, CELL arg1, CELL arg2,
- F_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)
-{
- general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
-}
-
-void not_implemented_error(void)
-{
- general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
-}
-
-/* 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)
-{
- int pagesize = getpagesize();
- area += area_size;
- area += offset * pagesize;
-
- return fault >= area && fault <= area + pagesize;
-}
-
-void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
-{
- if(in_page(addr, ds_bot, 0, -1))
- general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
- else if(in_page(addr, ds_bot, ds_size, 0))
- general_error(ERROR_DS_OVERFLOW,F,F,native_stack);
- else if(in_page(addr, rs_bot, 0, -1))
- general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
- else if(in_page(addr, rs_bot, rs_size, 0))
- 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)
-{
- general_error(ERROR_SIGNAL,tag_fixnum(signal),F,native_stack);
-}
-
-void divide_by_zero_error(F_STACK_FRAME *native_stack)
-{
- general_error(ERROR_DIVIDE_BY_ZERO,F,F,native_stack);
-}
-
-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();
-}
--- /dev/null
+#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)
+{
+ print_string("Out of memory\n\n");
+ dump_generations();
+ exit(1);
+}
+
+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(const char* msg, cell tagged)
+{
+ print_string("You have triggered a bug in Factor. Please report.\n");
+ print_string("critical_error: "); print_string(msg);
+ print_string(": "); print_cell_hex(tagged); nl();
+ factorbug();
+}
+
+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. */
+ if(userenv[BREAK_ENV] != F)
+ {
+ /* If error was thrown during heap scan, we re-enable the GC */
+ gc_off = false;
+
+ /* Reset local roots */
+ 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 */
+ fix_stacks();
+
+ dpush(error);
+
+ /* Errors thrown from C code pass NULL for this parameter.
+ Errors thrown from Factor code, or signal handlers, pass the
+ actual stack pointer at the time, since the saved pointer is
+ not necessarily up to date at that point. */
+ if(callstack_top)
+ {
+ callstack_top = fix_callstack_top(callstack_top,
+ stack_chain->callstack_bottom);
+ }
+ else
+ callstack_top = stack_chain->callstack_top;
+
+ throw_impl(userenv[BREAK_ENV],callstack_top);
+ }
+ /* Error was thrown in early startup before error handler is set, just
+ crash. */
+ else
+ {
+ print_string("You have triggered a bug in Factor. Please report.\n");
+ print_string("early_error: ");
+ print_obj(error);
+ nl();
+ factorbug();
+ }
+}
+
+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)
+{
+ general_error(ERROR_TYPE,tag_fixnum(type),tagged,NULL);
+}
+
+void not_implemented_error(void)
+{
+ general_error(ERROR_NOT_IMPLEMENTED,F,F,NULL);
+}
+
+/* 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)
+{
+ int pagesize = getpagesize();
+ area += area_size;
+ area += offset * pagesize;
+
+ return fault >= area && fault <= area + pagesize;
+}
+
+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);
+ else if(in_page(addr, ds_bot, ds_size, 0))
+ general_error(ERROR_DS_OVERFLOW,F,F,native_stack);
+ else if(in_page(addr, rs_bot, 0, -1))
+ general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
+ else if(in_page(addr, rs_bot, rs_size, 0))
+ 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
+ general_error(ERROR_MEMORY,allot_cell(addr),F,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(void)
+{
+ 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)
+{
+ memory_protection_error(signal_fault_addr,signal_callstack_top);
+}
+
+void misc_signal_handler_impl(void)
+{
+ signal_error(signal_number,signal_callstack_top);
+}
+
+}
+++ /dev/null
-/* 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);
--- /dev/null
+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);
+
+}
+++ /dev/null
-#include "master.h"
-
-void default_parameters(F_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->gen_count = 2;
- p->code_size = 4;
- p->young_size = 1;
- p->aging_size = 1;
- p->tenured_size = 6;
-#else
- p->ds_size = 32 * CELLS;
- p->rs_size = 32 * CELLS;
-
- p->gen_count = 3;
- p->code_size = 8 * CELLS;
- p->young_size = CELLS / 4;
- p->aging_size = CELLS / 2;
- p->tenured_size = 4 * CELLS;
-#endif
-
- p->secure_gc = false;
- p->fep = false;
-
-#ifdef WINDOWS
- p->console = false;
-#else
- p->console = true;
-#endif
-
- p->stack_traces = true;
-}
-
-INLINE bool factor_arg(const F_CHAR* str, const F_CHAR* arg, CELL* value)
-{
- int val;
- if(SSCANF(str,arg,&val) > 0)
- {
- *value = val;
- return true;
- }
- else
- return false;
-}
-
-void init_parameters_from_args(F_PARAMETERS *p, int argc, F_CHAR **argv)
-{
- default_parameters(p);
- p->executable_path = argv[0];
-
- int i = 0;
-
- for(i = 1; i < argc; i++)
- {
- if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size));
- else if(factor_arg(argv[i],STRING_LITERAL("-generations=%d"),&p->gen_count));
- else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size));
- 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(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;
- else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true;
- else if(STRCMP(argv[i],STRING_LITERAL("-no-stack-traces")) == 0) p->stack_traces = false;
- }
-}
-
-/* Do some initialization that we do once only */
-void do_stage1_init(void)
-{
- print_string("*** Stage 2 early init... ");
- fflush(stdout);
-
- compile_all_words();
- userenv[STAGE2_ENV] = T;
-
- print_string("done\n");
- fflush(stdout);
-}
-
-void init_factor(F_PARAMETERS *p)
-{
- /* Kilobytes */
- p->ds_size = align_page(p->ds_size << 10);
- p->rs_size = align_page(p->rs_size << 10);
-
- /* Megabytes */
- p->young_size <<= 20;
- p->aging_size <<= 20;
- p->tenured_size <<= 20;
- p->code_size <<= 20;
-
- /* Disable GC during init as a sanity check */
- gc_off = true;
-
- /* OS-specific initialization */
- early_init();
-
- const F_CHAR *executable_path = vm_executable_path();
-
- if(executable_path)
- p->executable_path = executable_path;
-
- if(p->image_path == NULL)
- p->image_path = default_image_path();
-
- srand(current_micros());
- init_ffi();
- init_stacks(p->ds_size,p->rs_size);
- load_image(p);
- init_c_io();
- 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;
-
- 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[ARGS_ENV] = F;
- userenv[EMBEDDED_ENV] = F;
-
- /* We can GC now */
- gc_off = false;
-
- if(!stage2)
- {
- userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
- do_stage1_init();
- }
-}
-
-/* May allocate memory */
-void pass_args_to_factor(int argc, F_CHAR **argv)
-{
- F_ARRAY *args = allot_array(ARRAY_TYPE,argc,F);
- 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);
- }
-
- userenv[ARGS_ENV] = tag_object(args);
-}
-
-void start_factor(F_PARAMETERS *p)
-{
- if(p->fep) factorbug();
-
- nest_stacks();
- c_to_factor_toplevel(userenv[BOOT_ENV]);
- unnest_stacks();
-}
-
-void start_embedded_factor(F_PARAMETERS *p)
-{
- userenv[EMBEDDED_ENV] = T;
- start_factor(p);
-}
-
-void start_standalone_factor(int argc, F_CHAR **argv)
-{
- F_PARAMETERS p;
- default_parameters(&p);
- init_parameters_from_args(&p,argc,argv);
- init_factor(&p);
- pass_args_to_factor(argc,argv);
- start_factor(&p);
-}
-
-char *factor_eval_string(char *string)
-{
- char* (*callback)(char*) = alien_offset(userenv[EVAL_CALLBACK_ENV]);
- return callback(string);
-}
-
-void factor_eval_free(char *result)
-{
- free(result);
-}
-
-void factor_yield(void)
-{
- void (*callback)() = alien_offset(userenv[YIELD_CALLBACK_ENV]);
- callback();
-}
-
-void factor_sleep(long us)
-{
- void (*callback)() = alien_offset(userenv[SLEEP_CALLBACK_ENV]);
- callback(us);
-}
--- /dev/null
+#include "master.hpp"
+
+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 * sizeof(cell);
+ p->rs_size = 8 * sizeof(cell);
+
+ p->gen_count = 2;
+ p->code_size = 4;
+ p->young_size = 1;
+ p->aging_size = 1;
+ p->tenured_size = 6;
+#else
+ p->ds_size = 32 * sizeof(cell);
+ p->rs_size = 32 * sizeof(cell);
+
+ p->gen_count = 3;
+ 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;
+
+#ifdef WINDOWS
+ p->console = false;
+#else
+ p->console = true;
+#endif
+
+ p->stack_traces = true;
+}
+
+static bool factor_arg(const vm_char* str, const vm_char* arg, cell* value)
+{
+ int val;
+ if(SSCANF(str,arg,&val) > 0)
+ {
+ *value = val;
+ return true;
+ }
+ else
+ return false;
+}
+
+VM_C_API void init_parameters_from_args(vm_parameters *p, int argc, vm_char **argv)
+{
+ default_parameters(p);
+ p->executable_path = argv[0];
+
+ int i = 0;
+
+ for(i = 1; i < argc; i++)
+ {
+ if(factor_arg(argv[i],STRING_LITERAL("-datastack=%d"),&p->ds_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-retainstack=%d"),&p->rs_size));
+ else if(factor_arg(argv[i],STRING_LITERAL("-generations=%d"),&p->gen_count));
+ else if(factor_arg(argv[i],STRING_LITERAL("-young=%d"),&p->young_size));
+ 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;
+ else if(STRCMP(argv[i],STRING_LITERAL("-console")) == 0) p->console = true;
+ else if(STRCMP(argv[i],STRING_LITERAL("-no-stack-traces")) == 0) p->stack_traces = false;
+ }
+}
+
+/* Do some initialization that we do once only */
+static void do_stage1_init(void)
+{
+ print_string("*** Stage 2 early init... ");
+ fflush(stdout);
+
+ compile_all_words();
+ userenv[STAGE2_ENV] = T;
+
+ print_string("done\n");
+ fflush(stdout);
+}
+
+VM_C_API void init_factor(vm_parameters *p)
+{
+ /* Kilobytes */
+ p->ds_size = align_page(p->ds_size << 10);
+ p->rs_size = align_page(p->rs_size << 10);
+
+ /* Megabytes */
+ p->young_size <<= 20;
+ p->aging_size <<= 20;
+ p->tenured_size <<= 20;
+ p->code_size <<= 20;
+
+ /* Disable GC during init as a sanity check */
+ gc_off = true;
+
+ /* OS-specific initialization */
+ early_init();
+
+ const vm_char *executable_path = vm_executable_path();
+
+ if(executable_path)
+ p->executable_path = executable_path;
+
+ if(p->image_path == NULL)
+ p->image_path = default_image_path();
+
+ srand(current_micros());
+ init_ffi();
+ 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();
+
+ init_profiler();
+
+ 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(userenv[STAGE2_ENV] == F)
+ {
+ userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
+ do_stage1_init();
+ }
+}
+
+/* May allocate memory */
+VM_C_API void pass_args_to_factor(int argc, vm_char **argv)
+{
+ growable_array args;
+ int i;
+
+ for(i = 1; i < argc; i++)
+ args.add(allot_alien(F,(cell)argv[i]));
+
+ args.trim();
+ userenv[ARGS_ENV] = args.elements.value();
+}
+
+static void start_factor(vm_parameters *p)
+{
+ if(p->fep) factorbug();
+
+ nest_stacks();
+ c_to_factor_toplevel(userenv[BOOT_ENV]);
+ unnest_stacks();
+}
+
+VM_C_API void start_embedded_factor(vm_parameters *p)
+{
+ userenv[EMBEDDED_ENV] = T;
+ start_factor(p);
+}
+
+VM_C_API void start_standalone_factor(int argc, vm_char **argv)
+{
+ vm_parameters p;
+ default_parameters(&p);
+ init_parameters_from_args(&p,argc,argv);
+ init_factor(&p);
+ pass_args_to_factor(argc,argv);
+ start_factor(&p);
+}
+
+VM_C_API char *factor_eval_string(char *string)
+{
+ char *(*callback)(char *) = (char *(*)(char *))alien_offset(userenv[EVAL_CALLBACK_ENV]);
+ return callback(string);
+}
+
+VM_C_API void factor_eval_free(char *result)
+{
+ free(result);
+}
+
+VM_C_API void factor_yield(void)
+{
+ void (*callback)(void) = (void (*)(void))alien_offset(userenv[YIELD_CALLBACK_ENV]);
+ callback();
+}
+
+VM_C_API void factor_sleep(long us)
+{
+ void (*callback)(long) = (void (*)(long))alien_offset(userenv[SLEEP_CALLBACK_ENV]);
+ callback(us);
+}
+
+}
+++ /dev/null
-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);
--- /dev/null
+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);
+
+}
/* 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)
{
}
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;
}
-#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);
+++ /dev/null
-/* 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;
-}
--- /dev/null
+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;
+}
+
+}
--- /dev/null
+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;
+ }
+}
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Certain special objects in the image are known to the runtime */
-void init_objects(F_HEADER *h)
-{
- memcpy(userenv,h->userenv,sizeof(userenv));
-
- T = h->t;
- 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 good_size = h->data_size + (1 << 20);
-
- if(good_size > p->tenured_size)
- p->tenured_size = good_size;
-
- init_data_heap(p->gen_count,
- p->young_size,
- p->aging_size,
- p->tenured_size,
- p->secure_gc);
-
- clear_gc_stats();
-
- F_ZONE *tenured = &data_heap->generations[TENURED];
-
- F_FIXNUM bytes_read = fread((void*)tenured->start,1,h->data_size,file);
-
- if(bytes_read != h->data_size)
- {
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->data_size);
- print_string(" bytes expected\n");
- fatal_error("load_data_heap failed",0);
- }
-
- tenured->here = tenured->start + h->data_size;
- data_relocation_base = h->data_relocation_base;
-}
-
-INLINE void load_code_heap(FILE *file, F_HEADER *h, F_PARAMETERS *p)
-{
- CELL good_size = h->code_size + (1 << 19);
-
- if(good_size > p->code_size)
- p->code_size = good_size;
-
- init_code_heap(p->code_size);
-
- if(h->code_size != 0)
- {
- F_FIXNUM bytes_read = fread(first_block(&code_heap),1,h->code_size,file);
- if(bytes_read != h->code_size)
- {
- print_string("truncated image: ");
- print_fixnum(bytes_read);
- print_string(" bytes read, ");
- print_cell(h->code_size);
- print_string(" bytes expected\n");
- fatal_error("load_code_heap failed",0);
- }
- }
-
- code_relocation_base = h->code_relocation_base;
- build_free_list(&code_heap,h->code_size);
-}
-
-/* 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)
-{
- FILE *file = OPEN_READ(p->image_path);
- if(file == NULL)
- {
- print_string("Cannot open image file: "); print_native_string(p->image_path); nl();
- print_string(strerror(errno)); nl();
- exit(1);
- }
-
- F_HEADER h;
- fread(&h,sizeof(F_HEADER),1,file);
-
- if(h.magic != IMAGE_MAGIC)
- fatal_error("Bad image: magic number check failed",h.magic);
-
- if(h.version != IMAGE_VERSION)
- fatal_error("Bad image: version number check failed",h.version);
-
- load_data_heap(file,&h,p);
- load_code_heap(file,&h,p);
-
- fclose(file);
-
- init_objects(&h);
-
- relocate_data();
- relocate_code();
-
- /* Store image path name */
- userenv[IMAGE_ENV] = tag_object(from_native_string(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);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Certain special objects in the image are known to the runtime */
+static void init_objects(image_header *h)
+{
+ memcpy(userenv,h->userenv,sizeof(userenv));
+
+ T = h->t;
+ bignum_zero = h->bignum_zero;
+ bignum_pos_one = h->bignum_pos_one;
+ bignum_neg_one = h->bignum_neg_one;
+}
+
+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);
+
+ if(good_size > p->tenured_size)
+ p->tenured_size = good_size;
+
+ init_data_heap(p->gen_count,
+ p->young_size,
+ p->aging_size,
+ p->tenured_size,
+ p->secure_gc);
+
+ clear_gc_stats();
+
+ zone *tenured = &data->generations[TENURED];
+
+ fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file);
+
+ if((cell)bytes_read != h->data_size)
+ {
+ print_string("truncated image: ");
+ print_fixnum(bytes_read);
+ print_string(" bytes read, ");
+ print_cell(h->data_size);
+ print_string(" bytes expected\n");
+ fatal_error("load_data_heap failed",0);
+ }
+
+ tenured->here = tenured->start + h->data_size;
+ data_relocation_base = h->data_relocation_base;
+}
+
+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);
+
+ if(good_size > p->code_size)
+ p->code_size = good_size;
+
+ init_code_heap(p->code_size);
+
+ if(h->code_size != 0)
+ {
+ size_t bytes_read = fread(first_block(&code),1,h->code_size,file);
+ if(bytes_read != h->code_size)
+ {
+ print_string("truncated image: ");
+ print_fixnum(bytes_read);
+ print_string(" bytes read, ");
+ print_cell(h->code_size);
+ print_string(" bytes expected\n");
+ fatal_error("load_code_heap failed",0);
+ }
+ }
+
+ code_relocation_base = h->code_relocation_base;
+ 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(vm_parameters *p)
+{
+ FILE *file = OPEN_READ(p->image_path);
+ if(file == NULL)
+ {
+ print_string("Cannot open image file: "); print_native_string(p->image_path); nl();
+ print_string(strerror(errno)); nl();
+ exit(1);
+ }
+
+ 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);
+
+ if(h.version != IMAGE_VERSION)
+ fatal_error("Bad image: version number check failed",h.version);
+
+ load_data_heap(file,&h,p);
+ load_code_heap(file,&h,p);
+
+ fclose(file);
+
+ init_objects(&h);
+
+ relocate_data();
+ relocate_code();
+
+ /* Store image path name */
+ userenv[IMAGE_ENV] = allot_alien(F,(cell)p->image_path);
+}
+
+}
+++ /dev/null
-#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();
--- /dev/null
+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);
+
+}
--- /dev/null
+#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());
+}
+
+}
--- /dev/null
+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);
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Simple wrappers for ANSI C I/O functions, used for bootstrapping.
-
-Note the ugly loop logic in almost every function; we have to handle EINTR
-and restart the operation if the system call was interrupted. Naive
-applications don't do this, but then they quickly fail if one enables
-itimer()s or other signals.
-
-The Factor library provides platform-specific code for Unix and Windows
-with many more capabilities so these words are not usually used in
-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);
-}
-
-void io_error(void)
-{
-#ifndef WINCE
- if(errno == EINTR)
- return;
-#endif
-
- CELL error = tag_object(from_char_string(strerror(errno)));
- general_error(ERROR_IO,error,F,NULL);
-}
-
-void primitive_fopen(void)
-{
- char *mode = unbox_char_string();
- REGISTER_C_STRING(mode);
- char *path = unbox_char_string();
- UNREGISTER_C_STRING(mode);
-
- for(;;)
- {
- FILE *file = fopen(path,mode);
- if(file == NULL)
- io_error();
- else
- {
- box_alien(file);
- break;
- }
- }
-}
-
-void primitive_fgetc(void)
-{
- FILE* file = unbox_alien();
-
- for(;;)
- {
- int c = fgetc(file);
- if(c == EOF)
- {
- if(feof(file))
- {
- dpush(F);
- break;
- }
- else
- io_error();
- }
- else
- {
- dpush(tag_fixnum(c));
- break;
- }
- }
-}
-
-void primitive_fread(void)
-{
- FILE* file = unbox_alien();
- CELL size = unbox_array_size();
-
- if(size == 0)
- {
- dpush(tag_object(allot_string(0,0)));
- return;
- }
-
- F_BYTE_ARRAY *buf = allot_byte_array(size);
-
- for(;;)
- {
- int c = fread(buf + 1,1,size,file);
- if(c <= 0)
- {
- if(feof(file))
- {
- dpush(F);
- break;
- }
- else
- io_error();
- }
- else
- {
- 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);
- buf = new_buf;
- }
- dpush(tag_object(buf));
- break;
- }
- }
-}
-
-void primitive_fputc(void)
-{
- FILE *file = unbox_alien();
- F_FIXNUM ch = to_fixnum(dpop());
-
- for(;;)
- {
- if(fputc(ch,file) == EOF)
- {
- io_error();
-
- /* Still here? EINTR */
- }
- else
- break;
- }
-}
-
-void primitive_fwrite(void)
-{
- FILE *file = unbox_alien();
- F_BYTE_ARRAY *text = untag_byte_array(dpop());
- F_FIXNUM length = array_capacity(text);
- char *string = (char *)(text + 1);
-
- if(length == 0)
- return;
-
- for(;;)
- {
- size_t written = fwrite(string,1,length,file);
- if(written == length)
- break;
- else
- {
- if(feof(file))
- break;
- else
- io_error();
-
- /* Still here? EINTR */
- length -= written;
- string += written;
- }
- }
-}
-
-void primitive_fseek(void)
-{
- int whence = to_fixnum(dpop());
- FILE *file = unbox_alien();
- off_t offset = to_signed_8(dpop());
-
- switch(whence)
- {
- case 0: whence = SEEK_SET; break;
- case 1: whence = SEEK_CUR; break;
- case 2: whence = SEEK_END; break;
- default:
- critical_error("Bad value for whence",whence);
- break;
- }
-
- if(FSEEK(file,offset,whence) == -1)
- {
- io_error();
-
- /* Still here? EINTR */
- critical_error("Don't know what to do; EINTR from fseek()?",0);
- }
-}
-
-void primitive_fflush(void)
-{
- FILE *file = unbox_alien();
- for(;;)
- {
- if(fflush(file) == EOF)
- io_error();
- else
- break;
- }
-}
-
-void primitive_fclose(void)
-{
- FILE *file = unbox_alien();
- for(;;)
- {
- if(fclose(file) == EOF)
- io_error();
- else
- break;
- }
-}
-
-/* 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)
-{
- return errno;
-}
-
-void clear_err_no(void)
-{
- errno = 0;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Simple wrappers for ANSI C I/O functions, used for bootstrapping.
+
+Note the ugly loop logic in almost every function; we have to handle EINTR
+and restart the operation if the system call was interrupted. Naive
+applications don't do this, but then they quickly fail if one enables
+itimer()s or other signals.
+
+The Factor library provides platform-specific code for Unix and Windows
+with many more capabilities so these words are not usually used in
+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);
+}
+
+void io_error(void)
+{
+#ifndef WINCE
+ if(errno == EINTR)
+ return;
+#endif
+
+ general_error(ERROR_IO,tag_fixnum(errno),F,NULL);
+}
+
+PRIMITIVE(fopen)
+{
+ gc_root<byte_array> mode(dpop());
+ gc_root<byte_array> path(dpop());
+ mode.untag_check();
+ path.untag_check();
+
+ for(;;)
+ {
+ FILE *file = fopen((char *)(path.untagged() + 1),
+ (char *)(mode.untagged() + 1));
+ if(file == NULL)
+ io_error();
+ else
+ {
+ box_alien(file);
+ break;
+ }
+ }
+}
+
+PRIMITIVE(fgetc)
+{
+ FILE *file = (FILE *)unbox_alien();
+
+ for(;;)
+ {
+ int c = fgetc(file);
+ if(c == EOF)
+ {
+ if(feof(file))
+ {
+ dpush(F);
+ break;
+ }
+ else
+ io_error();
+ }
+ else
+ {
+ dpush(tag_fixnum(c));
+ break;
+ }
+ }
+}
+
+PRIMITIVE(fread)
+{
+ FILE *file = (FILE *)unbox_alien();
+ fixnum size = unbox_array_size();
+
+ if(size == 0)
+ {
+ dpush(tag<string>(allot_string(0,0)));
+ return;
+ }
+
+ gc_root<byte_array> buf(allot_array_internal<byte_array>(size));
+
+ for(;;)
+ {
+ int c = fread(buf.untagged() + 1,1,size,file);
+ if(c <= 0)
+ {
+ if(feof(file))
+ {
+ dpush(F);
+ break;
+ }
+ else
+ io_error();
+ }
+ else
+ {
+ if(c != size)
+ {
+ byte_array *new_buf = allot_byte_array(c);
+ memcpy(new_buf + 1, buf.untagged() + 1,c);
+ buf = new_buf;
+ }
+ dpush(buf.value());
+ break;
+ }
+ }
+}
+
+PRIMITIVE(fputc)
+{
+ FILE *file = (FILE *)unbox_alien();
+ fixnum ch = to_fixnum(dpop());
+
+ for(;;)
+ {
+ if(fputc(ch,file) == EOF)
+ {
+ io_error();
+
+ /* Still here? EINTR */
+ }
+ else
+ break;
+ }
+}
+
+PRIMITIVE(fwrite)
+{
+ 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)
+ return;
+
+ for(;;)
+ {
+ size_t written = fwrite(string,1,length,file);
+ if(written == length)
+ break;
+ else
+ {
+ if(feof(file))
+ break;
+ else
+ io_error();
+
+ /* Still here? EINTR */
+ length -= written;
+ string += written;
+ }
+ }
+}
+
+PRIMITIVE(fseek)
+{
+ int whence = to_fixnum(dpop());
+ FILE *file = (FILE *)unbox_alien();
+ off_t offset = to_signed_8(dpop());
+
+ switch(whence)
+ {
+ case 0: whence = SEEK_SET; break;
+ case 1: whence = SEEK_CUR; break;
+ case 2: whence = SEEK_END; break;
+ default:
+ critical_error("Bad value for whence",whence);
+ break;
+ }
+
+ if(FSEEK(file,offset,whence) == -1)
+ {
+ io_error();
+
+ /* Still here? EINTR */
+ critical_error("Don't know what to do; EINTR from fseek()?",0);
+ }
+}
+
+PRIMITIVE(fflush)
+{
+ FILE *file = (FILE *)unbox_alien();
+ for(;;)
+ {
+ if(fflush(file) == EOF)
+ io_error();
+ else
+ break;
+ }
+}
+
+PRIMITIVE(fclose)
+{
+ FILE *file = (FILE *)unbox_alien();
+ for(;;)
+ {
+ if(fclose(file) == EOF)
+ io_error();
+ else
+ break;
+ }
+}
+
+/* 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. */
+VM_C_API int err_no(void)
+{
+ return errno;
+}
+
+VM_C_API void clear_err_no(void)
+{
+ errno = 0;
+}
+
+}
+++ /dev/null
-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);
--- /dev/null
+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);
+
+}
--- /dev/null
+#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());
+}
+
+}
--- /dev/null
+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();
+};
+
+}
+++ /dev/null
-#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;
--- /dev/null
+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); }
+};
+
+}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+segment *gc_locals_region;
+cell gc_locals;
+
+segment *gc_bignums_region;
+cell gc_bignums;
+
+}
+++ /dev/null
-/* 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()))
--- /dev/null
+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)
+
+}
+++ /dev/null
-/* 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,
-2005-03-10:
-
-http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
-
-Modified for Factor by Slava Pestov */
-
-#include "master.h"
-
-/* The following sources were used as a *reference* for this exception handling
-code:
-1. Apple's mach/xnu documentation
-2. Timothy J. Wood's "Mach Exception Handlers 101" post to the
-omnigroup's macosx-dev list.
-http://www.wodeveloper.com/omniLists/macosx-dev/2000/June/msg00137.html */
-
-/* Modify a suspended thread's thread_state so that when the thread resumes
-executing, the call frame of the current C primitive (if any) is rewound, and
-the appropriate Factor error is thrown from the top-most Factor frame. */
-static void call_fault_handler(exception_type_t exception,
- MACH_EXC_STATE_TYPE *exc_state,
- MACH_THREAD_STATE_TYPE *thread_state)
-{
- /* There is a race condition here, but in practice an exception
- delivered during stack frame setup/teardown or while transitioning
- from Factor to C is a sign of things seriously gone wrong, not just
- a divide by zero or stack underflow in the listener */
-
- /* 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);
- /* Are we in C? Then use the saved callstack top */
- else
- signal_callstack_top = NULL;
-
- MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state));
-
- /* Now we point the program counter at the right handler function. */
- if(exception == EXC_BAD_ACCESS)
- {
- signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
- MACH_PROGRAM_COUNTER(thread_state) = (CELL)memory_signal_handler_impl;
- }
- else
- {
- if(exception == EXC_ARITHMETIC)
- signal_number = SIGFPE;
- else
- signal_number = SIGABRT;
- 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. */
-kern_return_t
-catch_exception_raise (mach_port_t exception_port,
- mach_port_t thread,
- mach_port_t task,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t code_count)
-{
- MACH_EXC_STATE_TYPE exc_state;
- MACH_THREAD_STATE_TYPE thread_state;
- mach_msg_type_number_t state_count;
-
- /* Get fault information and the faulting thread's register contents..
-
- 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)
- != KERN_SUCCESS)
- {
- /* The thread is supposed to be suspended while the exception
- handler is called. This shouldn't fail. */
- return KERN_FAILURE;
- }
-
- state_count = MACH_THREAD_STATE_COUNT;
- if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
- (void *) &thread_state, &state_count)
- != KERN_SUCCESS)
- {
- /* The thread is supposed to be suspended while the exception
- handler is called. This shouldn't fail. */
- return KERN_FAILURE;
- }
-
- /* Modify registers so to have the thread resume executing the
- fault handler */
- call_fault_handler(exception,&exc_state,&thread_state);
-
- /* Set the faulting thread's register contents..
-
- 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)
- != KERN_SUCCESS)
- {
- return KERN_FAILURE;
- }
-
- return KERN_SUCCESS;
-}
-
-
-/* The main function of the thread listening for exceptions. */
-static void *
-mach_exception_thread (void *arg)
-{
- for (;;)
- {
- /* These two structures contain some private kernel data. We don't need
- to access any of it so we don't bother defining a proper struct. The
- correct definitions are in the xnu source code. */
- /* Buffer for a message to be received. */
- struct
- {
- mach_msg_header_t head;
- mach_msg_body_t msgh_body;
- char data[1024];
- }
- msg;
- /* Buffer for a reply message. */
- struct
- {
- mach_msg_header_t head;
- char data[1024];
- }
- reply;
-
- mach_msg_return_t retval;
-
- /* Wait for a message on the exception port. */
- retval = mach_msg (&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE, 0,
- sizeof (msg), our_exception_port,
- MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL);
- if (retval != MACH_MSG_SUCCESS)
- {
- abort ();
- }
-
- /* Handle the message: Call exc_server, which will call
- catch_exception_raise and produce a reply message. */
- exc_server (&msg.head, &reply.head);
-
- /* Send the reply. */
- if (mach_msg (&reply.head, MACH_SEND_MSG, reply.head.msgh_size,
- 0, MACH_PORT_NULL, MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL)
- != MACH_MSG_SUCCESS)
- {
- abort ();
- }
- }
-}
-
-
-/* Initialize the Mach exception handler thread. */
-void mach_initialize (void)
-{
- mach_port_t self;
- exception_mask_t mask;
-
- self = mach_task_self ();
-
- /* Allocate a port on which the thread shall listen for exceptions. */
- if (mach_port_allocate (self, MACH_PORT_RIGHT_RECEIVE, &our_exception_port)
- != KERN_SUCCESS)
- fatal_error("mach_port_allocate() failed",0);
-
- /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/mach_port_insert_right.html. */
- if (mach_port_insert_right (self, our_exception_port, our_exception_port,
- MACH_MSG_TYPE_MAKE_SEND)
- != KERN_SUCCESS)
- fatal_error("mach_port_insert_right() failed",0);
-
- /* The exceptions we want to catch. */
- mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
-
- /* Create the thread listening on the exception port. */
- start_thread(mach_exception_thread);
-
- /* Replace the exception port info for these exceptions with our own.
- Note that we replace the exception port for the entire task, not only
- for a particular thread. This has the effect that when our exception
- port gets the message, the thread specific exception port has already
- been asked, and we don't need to bother about it.
- See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/task_set_exception_ports.html. */
- if (task_set_exception_ports (self, mask, our_exception_port,
- EXCEPTION_DEFAULT, MACHINE_THREAD_STATE)
- != KERN_SUCCESS)
- fatal_error("task_set_exception_ports() failed",0);
-}
--- /dev/null
+/* 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,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+
+#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:
+1. Apple's mach/xnu documentation
+2. Timothy J. Wood's "Mach Exception Handlers 101" post to the
+omnigroup's macosx-dev list.
+http://www.wodeveloper.com/omniLists/macosx-dev/2000/June/msg00137.html */
+
+/* Modify a suspended thread's thread_state so that when the thread resumes
+executing, the call frame of the current C primitive (if any) is rewound, and
+the appropriate Factor error is thrown from the top-most Factor frame. */
+static void call_fault_handler(exception_type_t exception,
+ MACH_EXC_STATE_TYPE *exc_state,
+ MACH_THREAD_STATE_TYPE *thread_state)
+{
+ /* There is a race condition here, but in practice an exception
+ delivered during stack frame setup/teardown or while transitioning
+ from Factor to C is a sign of things seriously gone wrong, not just
+ a divide by zero or stack underflow in the listener */
+
+ /* 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 = (stack_frame *)MACH_STACK_POINTER(thread_state);
+ /* Are we in C? Then use the saved callstack top */
+ else
+ signal_callstack_top = NULL;
+
+ MACH_STACK_POINTER(thread_state) = fix_stack_pointer(MACH_STACK_POINTER(thread_state));
+
+ /* Now we point the program counter at the right handler function. */
+ if(exception == EXC_BAD_ACCESS)
+ {
+ signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
+ }
+ else
+ {
+ if(exception == EXC_ARITHMETIC)
+ signal_number = SIGFPE;
+ else
+ signal_number = SIGABRT;
+ 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,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t code_count)
+{
+ MACH_EXC_STATE_TYPE exc_state;
+ MACH_THREAD_STATE_TYPE thread_state;
+ mach_msg_type_number_t state_count;
+
+ /* Get fault information and the faulting thread's register contents..
+
+ 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,
+ (natural_t *)&exc_state, &state_count)
+ != KERN_SUCCESS)
+ {
+ /* The thread is supposed to be suspended while the exception
+ handler is called. This shouldn't fail. */
+ return KERN_FAILURE;
+ }
+
+ state_count = MACH_THREAD_STATE_COUNT;
+ if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
+ (natural_t *)&thread_state, &state_count)
+ != KERN_SUCCESS)
+ {
+ /* The thread is supposed to be suspended while the exception
+ handler is called. This shouldn't fail. */
+ return KERN_FAILURE;
+ }
+
+ /* Modify registers so to have the thread resume executing the
+ fault handler */
+ call_fault_handler(exception,&exc_state,&thread_state);
+
+ /* Set the faulting thread's register contents..
+
+ See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */
+ if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR,
+ (natural_t *)&thread_state, state_count)
+ != KERN_SUCCESS)
+ {
+ return KERN_FAILURE;
+ }
+
+ return KERN_SUCCESS;
+}
+
+
+/* The main function of the thread listening for exceptions. */
+static void *
+mach_exception_thread (void *arg)
+{
+ for (;;)
+ {
+ /* These two structures contain some private kernel data. We don't need
+ to access any of it so we don't bother defining a proper struct. The
+ correct definitions are in the xnu source code. */
+ /* Buffer for a message to be received. */
+ struct
+ {
+ mach_msg_header_t head;
+ mach_msg_body_t msgh_body;
+ char data[1024];
+ }
+ msg;
+ /* Buffer for a reply message. */
+ struct
+ {
+ mach_msg_header_t head;
+ char data[1024];
+ }
+ reply;
+
+ mach_msg_return_t retval;
+
+ /* Wait for a message on the exception port. */
+ retval = mach_msg (&msg.head, MACH_RCV_MSG | MACH_RCV_LARGE, 0,
+ sizeof (msg), our_exception_port,
+ MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL);
+ if (retval != MACH_MSG_SUCCESS)
+ {
+ abort ();
+ }
+
+ /* Handle the message: Call exc_server, which will call
+ catch_exception_raise and produce a reply message. */
+ exc_server (&msg.head, &reply.head);
+
+ /* Send the reply. */
+ if (mach_msg (&reply.head, MACH_SEND_MSG, reply.head.msgh_size,
+ 0, MACH_PORT_NULL, MACH_MSG_TIMEOUT_NONE, MACH_PORT_NULL)
+ != MACH_MSG_SUCCESS)
+ {
+ abort ();
+ }
+ }
+}
+
+/* Initialize the Mach exception handler thread. */
+void mach_initialize (void)
+{
+ mach_port_t self;
+ exception_mask_t mask;
+
+ self = mach_task_self ();
+
+ /* Allocate a port on which the thread shall listen for exceptions. */
+ if (mach_port_allocate (self, MACH_PORT_RIGHT_RECEIVE, &our_exception_port)
+ != KERN_SUCCESS)
+ fatal_error("mach_port_allocate() failed",0);
+
+ /* See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/mach_port_insert_right.html. */
+ if (mach_port_insert_right (self, our_exception_port, our_exception_port,
+ MACH_MSG_TYPE_MAKE_SEND)
+ != KERN_SUCCESS)
+ fatal_error("mach_port_insert_right() failed",0);
+
+ /* The exceptions we want to catch. */
+ mask = EXC_MASK_BAD_ACCESS | EXC_MASK_ARITHMETIC;
+
+ /* Create the thread listening on the exception port. */
+ start_thread(mach_exception_thread);
+
+ /* Replace the exception port info for these exceptions with our own.
+ Note that we replace the exception port for the entire task, not only
+ for a particular thread. This has the effect that when our exception
+ port gets the message, the thread specific exception port has already
+ been asked, and we don't need to bother about it.
+ See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/task_set_exception_ports.html. */
+ if (task_set_exception_ports (self, mask, our_exception_port,
+ EXCEPTION_DEFAULT, MACHINE_THREAD_STATE)
+ != KERN_SUCCESS)
+ fatal_error("task_set_exception_ports() failed",0);
+}
+
+}
+++ /dev/null
-/* 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,
-2005-03-10:
-
-http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
-
-Modified for Factor by Slava Pestov */
-#include <stdio.h>
-#include <stdlib.h>
-#include <errno.h>
-#include <signal.h>
-
-#include <mach/mach.h>
-#include <mach/mach_error.h>
-#include <mach/thread_status.h>
-#include <mach/exception.h>
-#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:
- The exc_server function is the MIG generated server handling function
- to handle messages from the kernel relating to the occurrence of an
- exception in a thread. Such messages are delivered to the exception port
- set via thread_set_exception_ports or task_set_exception_ports. When an
- exception occurs in a thread, the thread sends an exception message to its
- exception port, blocking in the kernel waiting for the receipt of a reply.
- The exc_server function performs all necessary argument handling for this
- kernel message and calls catch_exception_raise, catch_exception_raise_state
- or catch_exception_raise_state_identity, which should handle the exception.
- If the called routine returns KERN_SUCCESS, a reply message will be sent,
- 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);
-
-
-/* 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? */
-kern_return_t
-catch_exception_raise (mach_port_t exception_port,
- mach_port_t thread,
- mach_port_t task,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t code_count);
-kern_return_t
-catch_exception_raise_state (mach_port_t exception_port,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t code_count,
- thread_state_flavor_t *flavor,
- thread_state_t in_state,
- mach_msg_type_number_t in_state_count,
- thread_state_t out_state,
- mach_msg_type_number_t *out_state_count);
-kern_return_t
-catch_exception_raise_state_identity (mach_port_t exception_port,
- mach_port_t thread,
- mach_port_t task,
- exception_type_t exception,
- exception_data_t code,
- mach_msg_type_number_t codeCnt,
- thread_state_flavor_t *flavor,
- thread_state_t in_state,
- mach_msg_type_number_t in_state_count,
- thread_state_t out_state,
- mach_msg_type_number_t *out_state_count);
-
-void mach_initialize (void);
--- /dev/null
+/* 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,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+#include <stdio.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <signal.h>
+
+#include <mach/mach.h>
+#include <mach/mach_error.h>
+#include <mach/thread_status.h>
+#include <mach/exception.h>
+#include <mach/task.h>
+#include <pthread.h>
+
+/* This is not defined in any header, although documented. */
+
+/* http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/exc_server.html says:
+ The exc_server function is the MIG generated server handling function
+ to handle messages from the kernel relating to the occurrence of an
+ exception in a thread. Such messages are delivered to the exception port
+ set via thread_set_exception_ports or task_set_exception_ports. When an
+ exception occurs in a thread, the thread sends an exception message to its
+ exception port, blocking in the kernel waiting for the receipt of a reply.
+ The exc_server function performs all necessary argument handling for this
+ kernel message and calls catch_exception_raise, catch_exception_raise_state
+ or catch_exception_raise_state_identity, which should handle the exception.
+ If the called routine returns KERN_SUCCESS, a reply message will be sent,
+ 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 "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,
+ mach_port_t task,
+ 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,
+ exception_data_t code,
+ mach_msg_type_number_t code_count,
+ thread_state_flavor_t *flavor,
+ thread_state_t in_state,
+ 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,
+ mach_port_t task,
+ exception_type_t exception,
+ exception_data_t code,
+ mach_msg_type_number_t codeCnt,
+ thread_state_flavor_t *flavor,
+ thread_state_t in_state,
+ mach_msg_type_number_t in_state_count,
+ thread_state_t out_state,
+ mach_msg_type_number_t *out_state_count);
+
+namespace factor
+{
+
+void mach_initialize (void);
+
+}
+++ /dev/null
-#include "master.h"
-
-int main(int argc, char **argv)
-{
- start_standalone_factor(argc,argv);
- return 0;
-}
--- /dev/null
+#include "master.hpp"
+
+int main(int argc, char **argv)
+{
+ factor::start_standalone_factor(argc,argv);
+ return 0;
+}
+++ /dev/null
-#include "master.h"
-
-/*
- Windows CE argument parsing ported to work on
- int main(int argc, wchar_t **argv).
-
- This would not be necessary if Windows CE had CommandLineToArgvW.
-
- Based on MinGW's public domain char** version.
-
-*/
-
-int __argc;
-wchar_t **__argv;
-
-static int
-parse_tokens(wchar_t* string, wchar_t*** tokens, int length)
-{
- /* Extract whitespace- and quotes- delimited tokens from the given string
- and put them into the tokens array. Returns number of tokens
- extracted. Length specifies the current size of tokens[].
- THIS METHOD MODIFIES string. */
-
- const wchar_t* whitespace = L" \t\r\n";
- wchar_t* tokenEnd = 0;
- const wchar_t* quoteCharacters = L"\"\'";
- wchar_t *end = string + wcslen(string);
-
- if (string == NULL)
- return length;
-
- while (1)
- {
- const wchar_t* q;
- /* Skip over initial whitespace. */
- string += wcsspn(string, whitespace);
- if (*string == '\0')
- break;
-
- for (q = quoteCharacters; *q; ++q)
- {
- if (*string == *q)
- break;
- }
- if (*q)
- {
- /* Token is quoted. */
- wchar_t quote = *string++;
- tokenEnd = wcschr(string, quote);
- /* If there is no endquote, the token is the rest of the string. */
- if (!tokenEnd)
- tokenEnd = end;
- }
- else
- {
- tokenEnd = string + wcscspn(string, whitespace);
- }
-
- *tokenEnd = '\0';
-
- {
- wchar_t** new_tokens;
- int newlen = length + 1;
- new_tokens = realloc (*tokens, sizeof (wchar_t**) * newlen);
- if (!new_tokens)
- {
- /* Out of memory. */
- return -1;
- }
-
- *tokens = new_tokens;
- (*tokens)[length] = string;
- length = newlen;
- }
- if (tokenEnd == end)
- break;
- string = tokenEnd + 1;
- }
- return length;
-}
-
-static void
-parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
-{
- wchar_t cmdnameBufW[MAX_UNICODE_PATH];
- int cmdlineLen = 0;
- int modlen;
-
- /* argv[0] is the path of invoked program - get this from CE. */
- cmdnameBufW[0] = 0;
- modlen = GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
-
- if (!cmdlinePtrW)
- cmdlineLen = 0;
- else
- cmdlineLen = wcslen(cmdlinePtrW);
-
- /* gets realloc()'d later */
- *argv = malloc (sizeof (wchar_t**) * 1);
- if (!*argv)
- ExitProcess(-1);
-
- (*argv)[0] = wcsdup(cmdnameBufW);
- if(!(*argv[0]))
- ExitProcess(-1);
- /* Add one to account for argv[0] */
- (*argc)++;
-
- if (cmdlineLen > 0)
- {
- wchar_t* argv1 = (*argv)[0] + wcslen((*argv)[0]) + 1;
- argv1 = wcsdup(cmdlinePtrW);
- if(!argv1)
- ExitProcess(-1);
- *argc = parse_tokens(argv1, argv, 1);
- if (*argc < 0)
- ExitProcess(-1);
- }
- (*argv)[*argc] = 0;
- return;
-}
-
-int WINAPI
-WinMain(
- HINSTANCE hInstance,
- HINSTANCE hPrevInstance,
- LPWSTR lpCmdLine,
- int nCmdShow)
-{
- parse_args(&__argc, &__argv, lpCmdLine);
- start_standalone_factor(__argc,(LPWSTR*)__argv);
- // memory leak from malloc, wcsdup
- return 0;
-}
--- /dev/null
+#include "master.hpp"
+
+/*
+ Windows CE argument parsing ported to work on
+ int main(int argc, wchar_t **argv).
+
+ This would not be necessary if Windows CE had CommandLineToArgvW.
+
+ Based on MinGW's public domain char** version.
+
+*/
+
+int __argc;
+wchar_t **__argv;
+
+static int
+parse_tokens(wchar_t* string, wchar_t*** tokens, int length)
+{
+ /* Extract whitespace- and quotes- delimited tokens from the given string
+ and put them into the tokens array. Returns number of tokens
+ extracted. Length specifies the current size of tokens[].
+ THIS METHOD MODIFIES string. */
+
+ const wchar_t* whitespace = L" \t\r\n";
+ wchar_t* tokenEnd = 0;
+ const wchar_t* quoteCharacters = L"\"\'";
+ wchar_t *end = string + wcslen(string);
+
+ if (string == NULL)
+ return length;
+
+ while (1)
+ {
+ const wchar_t* q;
+ /* Skip over initial whitespace. */
+ string += wcsspn(string, whitespace);
+ if (*string == '\0')
+ break;
+
+ for (q = quoteCharacters; *q; ++q)
+ {
+ if (*string == *q)
+ break;
+ }
+ if (*q)
+ {
+ /* Token is quoted. */
+ wchar_t quote = *string++;
+ tokenEnd = wcschr(string, quote);
+ /* If there is no endquote, the token is the rest of the string. */
+ if (!tokenEnd)
+ tokenEnd = end;
+ }
+ else
+ {
+ tokenEnd = string + wcscspn(string, whitespace);
+ }
+
+ *tokenEnd = '\0';
+
+ {
+ wchar_t** new_tokens;
+ int newlen = length + 1;
+ new_tokens = realloc (*tokens, sizeof (wchar_t**) * newlen);
+ if (!new_tokens)
+ {
+ /* Out of memory. */
+ return -1;
+ }
+
+ *tokens = new_tokens;
+ (*tokens)[length] = string;
+ length = newlen;
+ }
+ if (tokenEnd == end)
+ break;
+ string = tokenEnd + 1;
+ }
+ return length;
+}
+
+static void
+parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
+{
+ wchar_t cmdnameBufW[MAX_UNICODE_PATH];
+ int cmdlineLen = 0;
+ int modlen;
+
+ /* argv[0] is the path of invoked program - get this from CE. */
+ cmdnameBufW[0] = 0;
+ modlen = GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
+
+ if (!cmdlinePtrW)
+ cmdlineLen = 0;
+ else
+ cmdlineLen = wcslen(cmdlinePtrW);
+
+ /* gets realloc()'d later */
+ *argv = malloc (sizeof (wchar_t**) * 1);
+ if (!*argv)
+ ExitProcess(-1);
+
+ (*argv)[0] = wcsdup(cmdnameBufW);
+ if(!(*argv[0]))
+ ExitProcess(-1);
+ /* Add one to account for argv[0] */
+ (*argc)++;
+
+ if (cmdlineLen > 0)
+ {
+ wchar_t* argv1 = (*argv)[0] + wcslen((*argv)[0]) + 1;
+ argv1 = wcsdup(cmdlinePtrW);
+ if(!argv1)
+ ExitProcess(-1);
+ *argc = parse_tokens(argv1, argv, 1);
+ if (*argc < 0)
+ ExitProcess(-1);
+ }
+ (*argv)[*argc] = 0;
+ return;
+}
+
+int WINAPI
+WinMain(
+ HINSTANCE hInstance,
+ HINSTANCE hPrevInstance,
+ LPWSTR lpCmdLine,
+ int nCmdShow)
+{
+ parse_args(&__argc, &__argv, lpCmdLine);
+ factor::start_standalone_factor(__argc,(LPWSTR*)__argv);
+ // memory leak from malloc, wcsdup
+ return 0;
+}
+++ /dev/null
-#include <windows.h>
-#include <stdio.h>
-#include <shellapi.h>
-#include "master.h"
-
-int WINAPI WinMain(
- HINSTANCE hInstance,
- HINSTANCE hPrevInstance,
- LPSTR lpCmdLine,
- int nCmdShow)
-{
- LPWSTR *szArglist;
- int nArgs;
-
- szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs);
- if(NULL == szArglist)
- {
- puts("CommandLineToArgvW failed");
- return 1;
- }
-
- start_standalone_factor(nArgs,szArglist);
-
- LocalFree(szArglist);
-
- return 0;
-}
--- /dev/null
+#include "master.hpp"
+
+int WINAPI WinMain(
+ HINSTANCE hInstance,
+ HINSTANCE hPrevInstance,
+ LPSTR lpCmdLine,
+ int nCmdShow)
+{
+ LPWSTR *szArglist;
+ int nArgs;
+
+ szArglist = CommandLineToArgvW(GetCommandLineW(), &nArgs);
+ if(NULL == szArglist)
+ {
+ puts("CommandLineToArgvW failed");
+ return 1;
+ }
+
+ factor::start_standalone_factor(nArgs,szArglist);
+
+ LocalFree(szArglist);
+
+ return 0;
+}
+++ /dev/null
-#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__ */
--- /dev/null
+#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__ */
+++ /dev/null
-#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));
-}
--- /dev/null
+#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)));
+}
+
+}
+++ /dev/null
-#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);
--- /dev/null
+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);
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE 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)
--- /dev/null
+#include <ucontext.h>
+
+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)
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE 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)
--- /dev/null
+#include <ucontext.h>
+
+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)
+
+}
+++ /dev/null
-#include "master.h"
-
-/* From SBCL */
-const char *vm_executable_path(void)
-{
- char path[PATH_MAX + 1];
-
- if (getosreldate() >= 600024)
- {
- /* KERN_PROC_PATHNAME is available */
- size_t len = PATH_MAX + 1;
- int mib[4];
-
- mib[0] = CTL_KERN;
- mib[1] = KERN_PROC;
- mib[2] = KERN_PROC_PATHNAME;
- mib[3] = -1;
- if (sysctl(mib, 4, &path, &len, NULL, 0) != 0)
- return NULL;
- }
- else
- {
- int size;
- size = readlink("/proc/curproc/file", path, sizeof(path) - 1);
- if (size < 0)
- return NULL;
- path[size] = '\0';
- }
-
- if(strcmp(path, "unknown") == 0)
- return NULL;
-
- return safe_strdup(path);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* From SBCL */
+const char *vm_executable_path(void)
+{
+ char path[PATH_MAX + 1];
+
+ if (getosreldate() >= 600024)
+ {
+ /* KERN_PROC_PATHNAME is available */
+ size_t len = PATH_MAX + 1;
+ int mib[4];
+
+ mib[0] = CTL_KERN;
+ mib[1] = KERN_PROC;
+ mib[2] = KERN_PROC_PATHNAME;
+ mib[3] = -1;
+ if (sysctl(mib, 4, &path, &len, NULL, 0) != 0)
+ return NULL;
+ }
+ else
+ {
+ int size;
+ size = readlink("/proc/curproc/file", path, sizeof(path) - 1);
+ if (size < 0)
+ return NULL;
+ path[size] = '\0';
+ }
+
+ if(strcmp(path, "unknown") == 0)
+ return NULL;
+
+ return safe_strdup(path);
+}
+
+}
+++ /dev/null
-#include <osreldate.h>
-
-extern int getosreldate(void);
-
-#include <sys/sysctl.h>
-
-#ifndef KERN_PROC_PATHNAME
-#define KERN_PROC_PATHNAME 12
-#endif
--- /dev/null
+#include <osreldate.h>
+#include <sys/sysctl.h>
+
+extern "C" int getosreldate(void);
+
+#ifndef KERN_PROC_PATHNAME
+#define KERN_PROC_PATHNAME 12
+#endif
+++ /dev/null
-#include "master.h"
-
-void c_to_factor_toplevel(CELL quot)
-{
- c_to_factor(quot);
-}
-
-void init_signals(void)
-{
- unix_init_signals();
-}
-
-void early_init(void) { }
-
-#define SUFFIX ".image"
-#define SUFFIX_LEN 6
-
-const char *default_image_path(void)
-{
- const char *path = vm_executable_path();
-
- if(!path)
- return "factor.image";
-
- /* We can't call strlen() here because with gcc 4.1.2 this
- causes an internal compiler error. */
- int len = 0;
- const char *iter = path;
- while(*iter) { len++; iter++; }
-
- char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
- memcpy(new_path,path,len + 1);
- memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
- return new_path;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void c_to_factor_toplevel(cell quot)
+{
+ c_to_factor(quot);
+}
+
+void init_signals(void)
+{
+ unix_init_signals();
+}
+
+void early_init(void) { }
+
+#define SUFFIX ".image"
+#define SUFFIX_LEN 6
+
+const char *default_image_path(void)
+{
+ const char *path = vm_executable_path();
+
+ if(!path)
+ return "factor.image";
+
+ /* We can't call strlen() here because with gcc 4.1.2 this
+ causes an internal compiler error. */
+ int len = 0;
+ const char *iter = path;
+ while(*iter) { len++; iter++; }
+
+ 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;
+}
+
+}
+++ /dev/null
-#define DLLEXPORT
-#define NULL_DLL NULL
-
-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);
--- /dev/null
+namespace factor
+{
+
+#define VM_C_API extern "C"
+#define NULL_DLL NULL
+
+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);
+
+}
+++ /dev/null
-#include "master.h"
-
-void flush_icache(CELL start, CELL len)
-{
- int result;
-
- /* XXX: why doesn't this work on Nokia n800? It should behave
- identically to the below assembly. */
- /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */
-
- /* Assembly swiped from
- http://lists.arm.linux.org.uk/pipermail/linux-arm/2002-July/003931.html
- */
- __asm__ __volatile__ (
- "mov r0, %1\n"
- "sub r1, %2, #1\n"
- "mov r2, #0\n"
- "swi " __sys1(__ARM_NR_cacheflush) "\n"
- "mov %0, r0\n"
- : "=r" (result)
- : "r" (start), "r" (start + len)
- : "r0","r1","r2");
-
- if(result < 0)
- critical_error("flush_icache() failed",result);
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void flush_icache(cell start, cell len)
+{
+ int result;
+
+ /* XXX: why doesn't this work on Nokia n800? It should behave
+ identically to the below assembly. */
+ /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */
+
+ /* Assembly swiped from
+ http://lists.arm.linux.org.uk/pipermail/linux-arm/2002-July/003931.html
+ */
+ __asm__ __volatile__ (
+ "mov r0, %1\n"
+ "sub r1, %2, #1\n"
+ "mov r2, #0\n"
+ "swi " __sys1(__ARM_NR_cacheflush) "\n"
+ "mov %0, r0\n"
+ : "=r" (result)
+ : "r" (start), "r" (start + len)
+ : "r0","r1","r2");
+
+ if(result < 0)
+ critical_error("flush_icache() failed",result);
+}
+
+}
+++ /dev/null
-#include <ucontext.h>
-#include <asm/unistd.h>
-#include <sys/syscall.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.arm_sp;
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
-
-void flush_icache(CELL start, CELL len);
--- /dev/null
+#include <ucontext.h>
+#include <asm/unistd.h>
+#include <sys/syscall.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.arm_sp;
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc)
+
+void flush_icache(cell start, cell len);
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+#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];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[7];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[7];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14])
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[15];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[15];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
+
+}
+++ /dev/null
-#include "master.h"
-
-/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
-const char *vm_executable_path(void)
-{
- char *path = safe_malloc(PATH_MAX + 1);
-
- int size = readlink("/proc/self/exe", path, PATH_MAX);
- if (size < 0)
- {
- fatal_error("Cannot read /proc/self/exe",0);
- return NULL;
- }
- else
- {
- path[size] = '\0';
- return safe_strdup(path);
- }
-}
-
-#ifdef SYS_inotify_init
-
-int inotify_init(void)
-{
- return syscall(SYS_inotify_init);
-}
-
-int inotify_add_watch(int fd, const char *name, u32 mask)
-{
- return syscall(SYS_inotify_add_watch, fd, name, mask);
-}
-
-int inotify_rm_watch(int fd, u32 wd)
-{
- return syscall(SYS_inotify_rm_watch, fd, wd);
-}
-
-#else
-
-int inotify_init(void)
-{
- not_implemented_error();
- return -1;
-}
-
-int inotify_add_watch(int fd, const char *name, u32 mask)
-{
- not_implemented_error();
- return -1;
-}
-
-int inotify_rm_watch(int fd, u32 wd)
-{
- not_implemented_error();
- return -1;
-}
-
-#endif
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
+const char *vm_executable_path(void)
+{
+ char *path = (char *)safe_malloc(PATH_MAX + 1);
+
+ int size = readlink("/proc/self/exe", path, PATH_MAX);
+ if (size < 0)
+ {
+ fatal_error("Cannot read /proc/self/exe",0);
+ return NULL;
+ }
+ else
+ {
+ path[size] = '\0';
+ return safe_strdup(path);
+ }
+}
+
+#ifdef SYS_inotify_init
+
+int inotify_init(void)
+{
+ return syscall(SYS_inotify_init);
+}
+
+int inotify_add_watch(int fd, const char *name, u32 mask)
+{
+ return syscall(SYS_inotify_add_watch, fd, name, mask);
+}
+
+int inotify_rm_watch(int fd, u32 wd)
+{
+ return syscall(SYS_inotify_rm_watch, fd, wd);
+}
+
+#else
+
+int inotify_init(void)
+{
+ not_implemented_error();
+ return -1;
+}
+
+int inotify_add_watch(int fd, const char *name, u32 mask)
+{
+ not_implemented_error();
+ return -1;
+}
+
+int inotify_rm_watch(int fd, u32 wd)
+{
+ not_implemented_error();
+ return -1;
+}
+
+#endif
+
+}
+++ /dev/null
-#include <sys/syscall.h>
-
-int inotify_init(void);
-int inotify_add_watch(int fd, const char *name, u32 mask);
-int inotify_rm_watch(int fd, u32 wd);
--- /dev/null
+#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);
+
+}
+++ /dev/null
-/* 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,
-2005-03-10:
-
-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 MACH_EXC_STATE_TYPE ppc_exception_state_t
-#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
-#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
-#define MACH_THREAD_STATE_TYPE ppc_thread_state_t
-#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE
-#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
-
-#if __DARWIN_UNIX03
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
- #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
-#else
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
- #define MACH_STACK_POINTER(thr_state) (thr_state)->r1
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
-#endif
-
-INLINE CELL fix_stack_pointer(CELL sp)
-{
- return sp;
-}
--- /dev/null
+#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>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+#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
+#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
+#define MACH_THREAD_STATE_TYPE ppc_thread_state_t
+#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE
+#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
+
+#if __DARWIN_UNIX03
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+#else
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->r1
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+#endif
+
+inline static cell fix_stack_pointer(cell sp)
+{
+ return sp;
+}
+
+}
+++ /dev/null
-/* 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,
-2005-03-10:
-
-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
-#define MACH_THREAD_STATE_TYPE i386_thread_state_t
-#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE
-#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
-
-#if __DARWIN_UNIX03
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
- #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
-#else
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
- #define MACH_STACK_POINTER(thr_state) (thr_state)->esp
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
-#endif
-
-INLINE CELL fix_stack_pointer(CELL sp)
-{
- return ((sp + 4) & ~15) - 4;
-}
--- /dev/null
+#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>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov */
+#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
+#define MACH_THREAD_STATE_TYPE i386_thread_state_t
+#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE
+#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
+
+#if __DARWIN_UNIX03
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+#else
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->esp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+#endif
+
+inline static cell fix_stack_pointer(cell sp)
+{
+ return ((sp + 4) & ~15) - 4;
+}
+
+}
+++ /dev/null
-/* 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,
-2005-03-10:
-
-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
-#define MACH_THREAD_STATE_TYPE x86_thread_state64_t
-#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64
-#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT
-
-#if __DARWIN_UNIX03
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
- #define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
-#else
- #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
- #define MACH_STACK_POINTER(thr_state) (thr_state)->rsp
- #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip
- #define UAP_PROGRAM_COUNTER(ucontext) \
- MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
-#endif
-
-INLINE CELL fix_stack_pointer(CELL sp)
-{
- return ((sp + 8) & ~15) - 8;
-}
--- /dev/null
+#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>
+
+Used under BSD license with permission from Paolo Bonzini and Bruno Haible,
+2005-03-10:
+
+http://sourceforge.net/mailarchive/message.php?msg_name=200503102200.32002.bruno%40clisp.org
+
+Modified for Factor by Slava Pestov and Daniel Ehrenberg */
+#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
+#define MACH_THREAD_STATE_TYPE x86_thread_state64_t
+#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64
+#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT
+
+#if __DARWIN_UNIX03
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+#else
+ #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
+ #define MACH_STACK_POINTER(thr_state) (thr_state)->rsp
+ #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip
+ #define UAP_PROGRAM_COUNTER(ucontext) \
+ MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+#endif
+
+inline static cell fix_stack_pointer(cell sp)
+{
+ return ((sp + 8) & ~15) - 8;
+}
+
+}
+++ /dev/null
-#define DLLEXPORT __attribute__((visibility("default")))
-#define FACTOR_OS_STRING "macosx"
-#define NULL_DLL "libfactor.dylib"
-
-void init_signals(void);
-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)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return ucontext->uc_stack.ss_sp;
-}
--- /dev/null
+namespace factor
+{
+
+#define VM_C_API extern "C" __attribute__((visibility("default")))
+#define FACTOR_OS_STRING "macosx"
+#define NULL_DLL "libfactor.dylib"
+
+void init_signals(void);
+void early_init(void);
+
+const char *vm_executable_path(void);
+const char *default_image_path(void);
+
+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);
+
+}
+++ /dev/null
-#import <Cocoa/Cocoa.h>
-
-#include "master.h"
-
-void c_to_factor_toplevel(CELL quot)
-{
- for(;;)
- {
-NS_DURING
- c_to_factor(quot);
- NS_VOIDRETURN;
-NS_HANDLER
- dpush(allot_alien(F,(CELL)localException));
- quot = userenv[COCOA_EXCEPTION_ENV];
- if(type_of(quot) != QUOTATION_TYPE)
- {
- /* No Cocoa exception handler was registered, so
- extra/cocoa/ is not loaded. So we pass the exception
- along. */
- [localException raise];
- }
-NS_ENDHANDLER
- }
-}
-
-void early_init(void)
-{
- SInt32 version;
- Gestalt(gestaltSystemVersion,&version);
- if(version <= 0x1050)
- {
- printf("Factor requires Mac OS X 10.5 or later.\n");
- exit(1);
- }
-
- [[NSAutoreleasePool alloc] init];
-}
-
-const char *vm_executable_path(void)
-{
- return [[[NSBundle mainBundle] executablePath] UTF8String];
-}
-
-const char *default_image_path(void)
-{
- NSBundle *bundle = [NSBundle mainBundle];
- NSString *path = [bundle bundlePath];
- NSString *executable = [[bundle executablePath] lastPathComponent];
- NSString *image = [executable stringByAppendingString:@".image"];
-
- NSString *returnVal;
-
- if([path hasSuffix:@".app"] || [path hasSuffix:@".app/"])
- {
- NSFileManager *mgr = [NSFileManager defaultManager];
-
- NSString *imageInBundle = [[path stringByAppendingPathComponent:@"Contents/Resources"] stringByAppendingPathComponent:image];
- NSString *imageAlongBundle = [[path stringByDeletingLastPathComponent] stringByAppendingPathComponent:image];
-
- returnVal = ([mgr fileExistsAtPath:imageInBundle]
- ? imageInBundle : imageAlongBundle);
- }
- else
- returnVal = [path stringByAppendingPathComponent:image];
-
- return [returnVal UTF8String];
-}
-
-void init_signals(void)
-{
- unix_init_signals();
- mach_initialize();
-}
-
-/* Amateurs at Apple: implement this function, properly! */
-Protocol *objc_getProtocol(char *name)
-{
- if(strcmp(name,"NSTextInput") == 0)
- return @protocol(NSTextInput);
- else
- return nil;
-}
--- /dev/null
+#import <Cocoa/Cocoa.h>
+
+#include "master.hpp"
+
+namespace factor
+{
+
+void c_to_factor_toplevel(cell quot)
+{
+ for(;;)
+ {
+NS_DURING
+ c_to_factor(quot);
+ NS_VOIDRETURN;
+NS_HANDLER
+ dpush(allot_alien(F,(cell)localException));
+ quot = userenv[COCOA_EXCEPTION_ENV];
+ 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
+ along. */
+ [localException raise];
+ }
+NS_ENDHANDLER
+ }
+}
+
+void early_init(void)
+{
+ SInt32 version;
+ Gestalt(gestaltSystemVersion,&version);
+ if(version <= 0x1050)
+ {
+ printf("Factor requires Mac OS X 10.5 or later.\n");
+ exit(1);
+ }
+
+ [[NSAutoreleasePool alloc] init];
+}
+
+const char *vm_executable_path(void)
+{
+ return [[[NSBundle mainBundle] executablePath] UTF8String];
+}
+
+const char *default_image_path(void)
+{
+ NSBundle *bundle = [NSBundle mainBundle];
+ NSString *path = [bundle bundlePath];
+ NSString *executable = [[bundle executablePath] lastPathComponent];
+ NSString *image = [executable stringByAppendingString:@".image"];
+
+ NSString *returnVal;
+
+ if([path hasSuffix:@".app"] || [path hasSuffix:@".app/"])
+ {
+ NSFileManager *mgr = [NSFileManager defaultManager];
+
+ NSString *imageInBundle = [[path stringByAppendingPathComponent:@"Contents/Resources"] stringByAppendingPathComponent:image];
+ NSString *imageAlongBundle = [[path stringByDeletingLastPathComponent] stringByAppendingPathComponent:image];
+
+ returnVal = ([mgr fileExistsAtPath:imageInBundle]
+ ? imageInBundle : imageAlongBundle);
+ }
+ else
+ returnVal = [path stringByAppendingPathComponent:image];
+
+ return [returnVal UTF8String];
+}
+
+void init_signals(void)
+{
+ unix_init_signals();
+ mach_initialize();
+}
+
+/* Amateurs at Apple: implement this function, properly! */
+Protocol *objc_getProtocol(char *name)
+{
+ if(strcmp(name,"NSTextInput") == 0)
+ return @protocol(NSTextInput);
+ else
+ return nil;
+}
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-#define ucontext_stack_pointer(uap) \
- ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+#define ucontext_stack_pointer(uap) \
+ ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
+
+}
+++ /dev/null
-#include "master.h"
-
-extern int main();
-
-const char *vm_executable_path(void)
-{
- static Dl_info info = {0};
- if (!info.dli_fname)
- dladdr(main, &info);
- return info.dli_fname;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+extern "C" int main();
+
+const char *vm_executable_path(void)
+{
+ static Dl_info info = {0};
+ if (!info.dli_fname)
+ dladdr((void *)main, &info);
+ return info.dli_fname;
+}
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap)
-
-#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
--- /dev/null
+#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)
+
+}
+++ /dev/null
-#include <i386/signal.h>
-
-INLINE void *openbsd_stack_pointer(void *uap)
-{
- struct sigcontext *sc = (struct sigcontext*) uap;
- return (void *)sc->sc_esp;
-}
-
-#define ucontext_stack_pointer openbsd_stack_pointer
-#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
--- /dev/null
+#include <i386/signal.h>
+
+namespace factor
+{
+
+inline static void *openbsd_stack_pointer(void *uap)
+{
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_esp;
+}
+
+#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
+
+}
+++ /dev/null
-#include <amd64/signal.h>
-
-INLINE void *openbsd_stack_pointer(void *uap)
-{
- struct sigcontext *sc = (struct sigcontext*) uap;
- return (void *)sc->sc_rsp;
-}
-
-#define ucontext_stack_pointer openbsd_stack_pointer
-#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
--- /dev/null
+#include <amd64/signal.h>
+
+namespace factor
+{
+
+inline static void *openbsd_stack_pointer(void *uap)
+{
+ struct sigcontext *sc = (struct sigcontext*) uap;
+ return (void *)sc->sc_rsp;
+}
+
+#define ucontext_stack_pointer openbsd_stack_pointer
+#define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
+
+}
+++ /dev/null
-#include "master.h"
-
-const char *vm_executable_path(void)
-{
- return NULL;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+const char *vm_executable_path(void)
+{
+ return NULL;
+}
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[ESP];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[ESP];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[EIP])
+
+}
+++ /dev/null
-#include <ucontext.h>
-
-INLINE void *ucontext_stack_pointer(void *uap)
-{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return (void *)ucontext->uc_mcontext.gregs[RSP];
-}
-
-#define UAP_PROGRAM_COUNTER(ucontext) \
- (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
--- /dev/null
+#include <ucontext.h>
+
+namespace factor
+{
+
+inline static void *ucontext_stack_pointer(void *uap)
+{
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return (void *)ucontext->uc_mcontext.gregs[RSP];
+}
+
+#define UAP_PROGRAM_COUNTER(ucontext) \
+ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[RIP])
+
+}
+++ /dev/null
-#include "master.h"
-
-const char *vm_executable_path(void)
-{
- return NULL;
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+const char *vm_executable_path(void)
+{
+ return NULL;
+}
+
+}
+++ /dev/null
-#include "master.h"
-
-void start_thread(void *(*start_routine)(void *))
-{
- pthread_attr_t attr;
- pthread_t thread;
-
- if (pthread_attr_init (&attr) != 0)
- fatal_error("pthread_attr_init() failed",0);
- if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED) != 0)
- fatal_error("pthread_attr_setdetachstate() failed",0);
- if (pthread_create (&thread, &attr, start_routine, NULL) != 0)
- fatal_error("pthread_create() failed",0);
- pthread_attr_destroy (&attr);
-}
-
-static void *null_dll;
-
-s64 current_micros(void)
-{
- struct timeval t;
- gettimeofday(&t,NULL);
- return (s64)t.tv_sec * 1000000 + t.tv_usec;
-}
-
-void sleep_micros(CELL usec)
-{
- usleep(usec);
-}
-
-void init_ffi(void)
-{
- /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
- null_dll = dlopen(NULL_DLL,RTLD_LAZY);
-}
-
-void ffi_dlopen(F_DLL *dll)
-{
- dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
-}
-
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
-{
- void *handle = (dll == NULL ? null_dll : dll->dll);
- return dlsym(handle,symbol);
-}
-
-void ffi_dlclose(F_DLL *dll)
-{
- if(dlclose(dll->dll))
- {
- general_error(ERROR_FFI,tag_object(
- from_char_string(dlerror())),F,NULL);
- }
- dll->dll = NULL;
-}
-
-void primitive_existsp(void)
-{
- struct stat sb;
- box_boolean(stat(unbox_char_string(),&sb) >= 0);
-}
-
-F_SEGMENT *alloc_segment(CELL size)
-{
- int pagesize = getpagesize();
-
- char *array = mmap(NULL,pagesize + size + pagesize,
- PROT_READ | PROT_WRITE | PROT_EXEC,
- MAP_ANON | MAP_PRIVATE,-1,0);
-
- if(array == (char*)-1)
- out_of_memory();
-
- if(mprotect(array,pagesize,PROT_NONE) == -1)
- 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);
-
- F_SEGMENT *retval = safe_malloc(sizeof(F_SEGMENT));
-
- retval->start = (CELL)(array + pagesize);
- retval->size = size;
- retval->end = retval->start + size;
-
- return retval;
-}
-
-void dealloc_segment(F_SEGMENT *block)
-{
- int pagesize = getpagesize();
-
- int retval = munmap((void*)(block->start - pagesize),
- pagesize + block->size + pagesize);
-
- if(retval)
- fatal_error("dealloc_segment failed",0);
-
- free(block);
-}
-
-INLINE F_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
- from Factor to C is a sign of things seriously gone wrong, not just
- 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);
- if(!ptr)
- critical_error("Invalid uap",(CELL)uap);
- return ptr;
- }
- else
- return NULL;
-}
-
-void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
-{
- signal_fault_addr = (CELL)siginfo->si_addr;
- signal_callstack_top = uap_stack_pointer(uap);
- 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;
-}
-
-static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
-{
- int ret;
- do
- {
- ret = sigaction(signum, act, oldact);
- }
- while(ret == -1 && errno == EINTR);
-
- if(ret == -1)
- fatal_error("sigaction failed", 0);
-}
-
-void unix_init_signals(void)
-{
- struct sigaction memory_sigaction;
- struct sigaction misc_sigaction;
- struct sigaction ignore_sigaction;
-
- memset(&memory_sigaction,0,sizeof(struct sigaction));
- sigemptyset(&memory_sigaction.sa_mask);
- memory_sigaction.sa_sigaction = memory_signal_handler;
- memory_sigaction.sa_flags = SA_SIGINFO;
-
- sigaction_safe(SIGBUS,&memory_sigaction,NULL);
- sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
-
- memset(&misc_sigaction,0,sizeof(struct sigaction));
- sigemptyset(&misc_sigaction.sa_mask);
- misc_sigaction.sa_sigaction = misc_signal_handler;
- misc_sigaction.sa_flags = SA_SIGINFO;
-
- sigaction_safe(SIGABRT,&misc_sigaction,NULL);
- sigaction_safe(SIGFPE,&misc_sigaction,NULL);
- sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
- sigaction_safe(SIGILL,&misc_sigaction,NULL);
-
- memset(&ignore_sigaction,0,sizeof(struct sigaction));
- sigemptyset(&ignore_sigaction.sa_mask);
- ignore_sigaction.sa_handler = SIG_IGN;
- sigaction_safe(SIGPIPE,&ignore_sigaction,NULL);
-}
-
-/* On Unix, shared fds such as stdin cannot be set to non-blocking mode
-(http://homepages.tesco.net/J.deBoynePollard/FGA/dont-set-shared-file-descriptors-to-non-blocking-mode.html)
-so we kludge around this by spawning a thread, which waits on a control pipe
-for a signal, upon receiving this signal it reads one block of data from stdin
-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;
-
-__attribute__((visibility("default"))) int control_read;
-__attribute__((visibility("default"))) int control_write;
-
-__attribute__((visibility("default"))) int size_read;
-__attribute__((visibility("default"))) int size_write;
-
-void safe_close(int fd)
-{
- if(close(fd) < 0)
- fatal_error("error closing fd",errno);
-}
-
-bool check_write(int fd, void *data, size_t size)
-{
- if(write(fd,data,size) == size)
- return true;
- else
- {
- if(errno == EINTR)
- return check_write(fd,data,size);
- else
- return false;
- }
-}
-
-void safe_write(int fd, void *data, size_t size)
-{
- if(!check_write(fd,data,size))
- fatal_error("error writing fd",errno);
-}
-
-bool safe_read(int fd, void *data, size_t size)
-{
- ssize_t bytes = read(fd,data,size);
- if(bytes < 0)
- {
- if(errno == EINTR)
- return safe_read(fd,data,size);
- else
- {
- fatal_error("error reading fd",errno);
- return false;
- }
- }
- else
- return (bytes == size);
-}
-
-void *stdin_loop(void *arg)
-{
- unsigned char buf[4096];
- bool loop_running = true;
-
- while(loop_running)
- {
- if(!safe_read(control_read,buf,1))
- break;
-
- if(buf[0] != 'X')
- fatal_error("stdin_loop: bad data on control fd",buf[0]);
-
- for(;;)
- {
- ssize_t bytes = read(0,buf,sizeof(buf));
- if(bytes < 0)
- {
- if(errno == EINTR)
- continue;
- else
- {
- loop_running = false;
- break;
- }
- }
- else if(bytes >= 0)
- {
- safe_write(size_write,&bytes,sizeof(bytes));
-
- if(!check_write(stdin_write,buf,bytes))
- loop_running = false;
- break;
- }
- }
- }
-
- safe_close(stdin_write);
- safe_close(control_read);
-
- return NULL;
-}
-
-void open_console(void)
-{
- int filedes[2];
-
- if(pipe(filedes) < 0)
- fatal_error("Error opening control pipe",errno);
-
- control_read = filedes[0];
- control_write = filedes[1];
-
- if(pipe(filedes) < 0)
- fatal_error("Error opening size pipe",errno);
-
- size_read = filedes[0];
- size_write = filedes[1];
-
- if(pipe(filedes) < 0)
- fatal_error("Error opening stdin pipe",errno);
-
- stdin_read = filedes[0];
- stdin_write = filedes[1];
-
- start_thread(stdin_loop);
-}
-
-DLLEXPORT void wait_for_stdin(void)
-{
- if(write(control_write,"X",1) != 1)
- {
- if(errno == EINTR)
- wait_for_stdin();
- else
- fatal_error("Error writing control fd",errno);
- }
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+void start_thread(void *(*start_routine)(void *))
+{
+ pthread_attr_t attr;
+ pthread_t thread;
+
+ if (pthread_attr_init (&attr) != 0)
+ fatal_error("pthread_attr_init() failed",0);
+ if (pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED) != 0)
+ fatal_error("pthread_attr_setdetachstate() failed",0);
+ if (pthread_create (&thread, &attr, start_routine, NULL) != 0)
+ fatal_error("pthread_create() failed",0);
+ pthread_attr_destroy (&attr);
+}
+
+static void *null_dll;
+
+s64 current_micros(void)
+{
+ struct timeval t;
+ gettimeofday(&t,NULL);
+ return (s64)t.tv_sec * 1000000 + t.tv_usec;
+}
+
+void sleep_micros(cell usec)
+{
+ usleep(usec);
+}
+
+void init_ffi(void)
+{
+ /* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic unix */
+ null_dll = dlopen(NULL_DLL,RTLD_LAZY);
+}
+
+void ffi_dlopen(dll *dll)
+{
+ dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
+}
+
+void *ffi_dlsym(dll *dll, symbol_char *symbol)
+{
+ void *handle = (dll == NULL ? null_dll : dll->dll);
+ return dlsym(handle,symbol);
+}
+
+void ffi_dlclose(dll *dll)
+{
+ if(dlclose(dll->dll))
+ general_error(ERROR_FFI,F,F,NULL);
+ dll->dll = NULL;
+}
+
+PRIMITIVE(existsp)
+{
+ struct stat sb;
+ char *path = (char *)(untag_check<byte_array>(dpop()) + 1);
+ box_boolean(stat(path,&sb) >= 0);
+}
+
+segment *alloc_segment(cell size)
+{
+ int pagesize = getpagesize();
+
+ char *array = (char *)mmap(NULL,pagesize + size + pagesize,
+ PROT_READ | PROT_WRITE | PROT_EXEC,
+ MAP_ANON | MAP_PRIVATE,-1,0);
+
+ if(array == (char*)-1)
+ out_of_memory();
+
+ if(mprotect(array,pagesize,PROT_NONE) == -1)
+ 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);
+
+ segment *retval = (segment *)safe_malloc(sizeof(segment));
+
+ retval->start = (cell)(array + pagesize);
+ retval->size = size;
+ retval->end = retval->start + size;
+
+ return retval;
+}
+
+void dealloc_segment(segment *block)
+{
+ int pagesize = getpagesize();
+
+ int retval = munmap((void*)(block->start - pagesize),
+ pagesize + block->size + pagesize);
+
+ if(retval)
+ fatal_error("dealloc_segment failed",0);
+
+ free(block);
+}
+
+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
+ from Factor to C is a sign of things seriously gone wrong, not just
+ a divide by zero or stack underflow in the listener */
+ if(in_code_heap_p(UAP_PROGRAM_COUNTER(uap)))
+ {
+ stack_frame *ptr = (stack_frame *)ucontext_stack_pointer(uap);
+ if(!ptr)
+ critical_error("Invalid uap",(cell)uap);
+ return ptr;
+ }
+ else
+ return NULL;
+}
+
+void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ signal_fault_addr = (cell)siginfo->si_addr;
+ signal_callstack_top = uap_stack_pointer(uap);
+ 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;
+}
+
+static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
+{
+ int ret;
+ do
+ {
+ ret = sigaction(signum, act, oldact);
+ }
+ while(ret == -1 && errno == EINTR);
+
+ if(ret == -1)
+ fatal_error("sigaction failed", 0);
+}
+
+void unix_init_signals(void)
+{
+ struct sigaction memory_sigaction;
+ struct sigaction misc_sigaction;
+ struct sigaction ignore_sigaction;
+
+ memset(&memory_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&memory_sigaction.sa_mask);
+ memory_sigaction.sa_sigaction = memory_signal_handler;
+ memory_sigaction.sa_flags = SA_SIGINFO;
+
+ sigaction_safe(SIGBUS,&memory_sigaction,NULL);
+ sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
+
+ memset(&misc_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&misc_sigaction.sa_mask);
+ misc_sigaction.sa_sigaction = misc_signal_handler;
+ misc_sigaction.sa_flags = SA_SIGINFO;
+
+ sigaction_safe(SIGABRT,&misc_sigaction,NULL);
+ sigaction_safe(SIGFPE,&misc_sigaction,NULL);
+ sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
+ sigaction_safe(SIGILL,&misc_sigaction,NULL);
+
+ memset(&ignore_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&ignore_sigaction.sa_mask);
+ ignore_sigaction.sa_handler = SIG_IGN;
+ sigaction_safe(SIGPIPE,&ignore_sigaction,NULL);
+}
+
+/* On Unix, shared fds such as stdin cannot be set to non-blocking mode
+(http://homepages.tesco.net/J.deBoynePollard/FGA/dont-set-shared-file-descriptors-to-non-blocking-mode.html)
+so we kludge around this by spawning a thread, which waits on a control pipe
+for a signal, upon receiving this signal it reads one block of data from stdin
+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. */
+extern "C" {
+ int stdin_read;
+ int stdin_write;
+
+ int control_read;
+ int control_write;
+
+ int size_read;
+ int size_write;
+}
+
+void safe_close(int fd)
+{
+ if(close(fd) < 0)
+ fatal_error("error closing fd",errno);
+}
+
+bool check_write(int fd, void *data, ssize_t size)
+{
+ if(write(fd,data,size) == size)
+ return true;
+ else
+ {
+ if(errno == EINTR)
+ return check_write(fd,data,size);
+ else
+ return false;
+ }
+}
+
+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, ssize_t size)
+{
+ ssize_t bytes = read(fd,data,size);
+ if(bytes < 0)
+ {
+ if(errno == EINTR)
+ return safe_read(fd,data,size);
+ else
+ {
+ fatal_error("error reading fd",errno);
+ return false;
+ }
+ }
+ else
+ return (bytes == size);
+}
+
+void *stdin_loop(void *arg)
+{
+ unsigned char buf[4096];
+ bool loop_running = true;
+
+ while(loop_running)
+ {
+ if(!safe_read(control_read,buf,1))
+ break;
+
+ if(buf[0] != 'X')
+ fatal_error("stdin_loop: bad data on control fd",buf[0]);
+
+ for(;;)
+ {
+ ssize_t bytes = read(0,buf,sizeof(buf));
+ if(bytes < 0)
+ {
+ if(errno == EINTR)
+ continue;
+ else
+ {
+ loop_running = false;
+ break;
+ }
+ }
+ else if(bytes >= 0)
+ {
+ safe_write(size_write,&bytes,sizeof(bytes));
+
+ if(!check_write(stdin_write,buf,bytes))
+ loop_running = false;
+ break;
+ }
+ }
+ }
+
+ safe_close(stdin_write);
+ safe_close(control_read);
+
+ return NULL;
+}
+
+void open_console(void)
+{
+ int filedes[2];
+
+ if(pipe(filedes) < 0)
+ fatal_error("Error opening control pipe",errno);
+
+ control_read = filedes[0];
+ control_write = filedes[1];
+
+ if(pipe(filedes) < 0)
+ fatal_error("Error opening size pipe",errno);
+
+ size_read = filedes[0];
+ size_write = filedes[1];
+
+ if(pipe(filedes) < 0)
+ fatal_error("Error opening stdin pipe",errno);
+
+ stdin_read = filedes[0];
+ stdin_write = filedes[1];
+
+ start_thread(stdin_loop);
+}
+
+VM_C_API void wait_for_stdin(void)
+{
+ if(write(control_write,"X",1) != 1)
+ {
+ if(errno == EINTR)
+ wait_for_stdin();
+ else
+ fatal_error("Error writing control fd",errno);
+ }
+}
+
+}
+++ /dev/null
-#include <dirent.h>
-#include <sys/mman.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <unistd.h>
-#include <sys/time.h>
-#include <dlfcn.h>
-#include <signal.h>
-#include <pthread.h>
-
-typedef char F_CHAR;
-typedef char F_SYMBOL;
-
-#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
-
-#define STRING_LITERAL(string) string
-
-#define SSCANF sscanf
-#define STRCMP strcmp
-#define STRNCMP strncmp
-#define STRDUP strdup
-
-#define FSEEK fseeko
-
-#define FIXNUM_FORMAT "%ld"
-#define CELL_FORMAT "%lu"
-#define CELL_HEX_FORMAT "%lx"
-
-#ifdef FACTOR_64
- #define CELL_HEX_PAD_FORMAT "%016lx"
-#else
- #define CELL_HEX_PAD_FORMAT "%08lx"
-#endif
-
-#define FIXNUM_FORMAT "%ld"
-
-#define OPEN_READ(path) fopen(path,"rb")
-#define OPEN_WRITE(path) fopen(path,"wb")
-
-#define print_native_string(string) print_string(string)
-
-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 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 open_console(void);
--- /dev/null
+#include <dirent.h>
+#include <sys/mman.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <sys/time.h>
+#include <dlfcn.h>
+#include <signal.h>
+#include <pthread.h>
+
+namespace factor
+{
+
+typedef char vm_char;
+typedef char symbol_char;
+
+#define STRING_LITERAL(string) string
+
+#define SSCANF sscanf
+#define STRCMP strcmp
+#define STRNCMP strncmp
+#define STRDUP strdup
+
+#define FSEEK fseeko
+
+#define FIXNUM_FORMAT "%ld"
+#define cell_FORMAT "%lu"
+#define cell_HEX_FORMAT "%lx"
+
+#ifdef FACTOR_64
+ #define cell_HEX_PAD_FORMAT "%016lx"
+#else
+ #define cell_HEX_PAD_FORMAT "%08lx"
+#endif
+
+#define FIXNUM_FORMAT "%ld"
+
+#define OPEN_READ(path) fopen(path,"rb")
+#define OPEN_WRITE(path) fopen(path,"wb")
+
+#define print_native_string(string) print_string(string)
+
+void start_thread(void *(*start_routine)(void *));
+
+void init_ffi(void);
+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 open_console(void);
+
+}
+++ /dev/null
-#include "master.h"
-
-s64 current_micros(void)
-{
- SYSTEMTIME st;
- FILETIME ft;
- GetSystemTime(&st);
- SystemTimeToFileTime(&st, &ft);
- return (((s64)ft.dwLowDateTime
- | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10;
-}
-
-char *strerror(int err)
-{
- /* strerror() is not defined on WinCE */
- return "strerror() is not defined on WinCE. Use native I/O.";
-}
-
-void flush_icache(CELL start, CELL end)
-{
- FlushInstructionCache(GetCurrentProcess(), 0, 0);
-}
-
-char *getenv(char *name)
-{
- not_implemented_error();
- return 0; /* unreachable */
-}
-
-void primitive_os_envs(void)
-{
- not_implemented_error();
-}
-
-void c_to_factor_toplevel(CELL quot)
-{
- c_to_factor(quot);
-}
-
-void open_console(void) { }
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+s64 current_micros(void)
+{
+ SYSTEMTIME st;
+ FILETIME ft;
+ GetSystemTime(&st);
+ SystemTimeToFileTime(&st, &ft);
+ return (((s64)ft.dwLowDateTime
+ | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10;
+}
+
+char *strerror(int err)
+{
+ /* strerror() is not defined on WinCE */
+ return "strerror() is not defined on WinCE. Use native I/O.";
+}
+
+void flush_icache(cell start, cell end)
+{
+ FlushInstructionCache(GetCurrentProcess(), 0, 0);
+}
+
+char *getenv(char *name)
+{
+ not_implemented_error();
+ return 0; /* unreachable */
+}
+
+PRIMITIVE(os_envs)
+{
+ not_implemented_error();
+}
+
+void c_to_factor_toplevel(cell quot)
+{
+ c_to_factor(quot);
+}
+
+void open_console(void) { }
+
+}
+++ /dev/null
-#ifndef UNICODE
-#define UNICODE
-#endif
-
-#include <windows.h>
-#include <ctype.h>
-
-typedef wchar_t F_SYMBOL;
-
-#define unbox_symbol_string unbox_u16_string
-#define from_symbol_string from_u16_string
-
-#define FACTOR_OS_STRING "wince"
-#define FACTOR_DLL L"factor-ce.dll"
-#define FACTOR_DLL_NAME "factor-ce.dll"
-
-int errno;
-char *strerror(int err);
-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 open_console(void);
--- /dev/null
+#ifndef UNICODE
+#define UNICODE
+#endif
+
+#include <windows.h>
+#include <ctype.h>
+
+namespace factor
+{
+
+typedef wchar_t symbol_char;
+
+#define FACTOR_OS_STRING "wince"
+#define FACTOR_DLL L"factor-ce.dll"
+#define FACTOR_DLL_NAME "factor-ce.dll"
+
+int errno;
+char *strerror(int err);
+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 open_console(void);
+
+}
+++ /dev/null
-#define ESP Esp
-#define EIP Eip
--- /dev/null
+namespace factor
+{
+
+#define ESP Esp
+#define EIP Eip
+
+}
+++ /dev/null
-#define ESP Rsp
-#define EIP Rip
--- /dev/null
+namespace factor
+{
+
+#define ESP Rsp
+#define EIP Rip
+
+}
+++ /dev/null
-#include "master.h"
-
-s64 current_micros(void)
-{
- FILETIME t;
- GetSystemTimeAsFileTime(&t);
- return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32)
- - EPOCH_OFFSET) / 10;
-}
-
-long exception_handler(PEXCEPTION_POINTERS pe)
-{
- PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
- CONTEXT *c = (CONTEXT*)pe->ContextRecord;
-
- if(in_code_heap_p(c->EIP))
- signal_callstack_top = (void *)c->ESP;
- else
- signal_callstack_top = NULL;
-
- 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;
- }
- /* If the Widcomm bluetooth stack is installed, the BTTray.exe process
- injects code into running programs. For some reason this results in
- random SEH exceptions with this (undocumented) exception code being
- raised. The workaround seems to be ignoring this altogether, since that
- is what happens if SEH is not enabled. Don't really have any idea what
- this exception means. */
- else if(e->ExceptionCode != 0x40010006)
- {
- signal_number = 11;
- c->EIP = (CELL)misc_signal_handler_impl;
- }
-
- return EXCEPTION_CONTINUE_EXECUTION;
-}
-
-void c_to_factor_toplevel(CELL quot)
-{
- if(!AddVectoredExceptionHandler(0, (void*)exception_handler))
- fatal_error("AddVectoredExceptionHandler failed", 0);
- c_to_factor(quot);
- RemoveVectoredExceptionHandler((void*)exception_handler);
-}
-
-void open_console(void)
-{
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+s64 current_micros(void)
+{
+ FILETIME t;
+ GetSystemTimeAsFileTime(&t);
+ return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32)
+ - EPOCH_OFFSET) / 10;
+}
+
+long exception_handler(PEXCEPTION_POINTERS pe)
+{
+ PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
+ CONTEXT *c = (CONTEXT*)pe->ContextRecord;
+
+ if(in_code_heap_p(c->EIP))
+ signal_callstack_top = (void *)c->ESP;
+ else
+ signal_callstack_top = NULL;
+
+ if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
+ {
+ signal_fault_addr = e->ExceptionInformation[1];
+ 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
+ random SEH exceptions with this (undocumented) exception code being
+ raised. The workaround seems to be ignoring this altogether, since that
+ is what happens if SEH is not enabled. Don't really have any idea what
+ this exception means. */
+ else if(e->ExceptionCode != 0x40010006)
+ {
+ signal_number = e->ExceptionCode;
+ c->EIP = (cell)misc_signal_handler_impl;
+ }
+
+ return EXCEPTION_CONTINUE_EXECUTION;
+}
+
+void c_to_factor_toplevel(cell quot)
+{
+ if(!AddVectoredExceptionHandler(0, (void*)exception_handler))
+ fatal_error("AddVectoredExceptionHandler failed", 0);
+ c_to_factor(quot);
+ RemoveVectoredExceptionHandler((void*)exception_handler);
+}
+
+void open_console(void)
+{
+}
+
+}
+++ /dev/null
-#undef _WIN32_WINNT
-#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
-
-#ifndef UNICODE
-#define UNICODE
-#endif
-
-#include <windows.h>
-
-typedef char F_SYMBOL;
-
-#define unbox_symbol_string unbox_char_string
-#define from_symbol_string from_char_string
-
-#define FACTOR_OS_STRING "winnt"
-#define FACTOR_DLL L"factor.dll"
-#define FACTOR_DLL_NAME "factor.dll"
-
-void c_to_factor_toplevel(CELL quot);
-long exception_handler(PEXCEPTION_POINTERS pe);
-void open_console(void);
--- /dev/null
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
+
+#ifndef UNICODE
+#define UNICODE
+#endif
+
+#include <shellapi.h>
+#include <windows.h>
+
+namespace factor
+{
+
+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);
+long exception_handler(PEXCEPTION_POINTERS pe);
+void open_console(void);
+
+}
+++ /dev/null
-#include "master.h"
-
-F_STRING *get_error_message(void)
-{
- 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;
-
-void init_ffi(void)
-{
- hFactorDll = GetModuleHandle(FACTOR_DLL);
- if(!hFactorDll)
- fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
-}
-
-void ffi_dlopen(F_DLL *dll)
-{
- dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
-}
-
-void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)
-{
- return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
-}
-
-void ffi_dlclose(F_DLL *dll)
-{
- FreeLibrary((HMODULE)dll->dll);
- dll->dll = NULL;
-}
-
-bool windows_stat(F_CHAR *path)
-{
- BY_HANDLE_FILE_INFORMATION bhfi;
- HANDLE h = CreateFileW(path,
- GENERIC_READ,
- FILE_SHARE_READ,
- NULL,
- OPEN_EXISTING,
- FILE_FLAG_BACKUP_SEMANTICS,
- NULL);
-
- if(h == INVALID_HANDLE_VALUE)
- {
- // FindFirstFile is the only call that can stat c:\pagefile.sys
- WIN32_FIND_DATA st;
- HANDLE h;
-
- if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
- return false;
- FindClose(h);
- return true;
- }
- bool ret;
- ret = GetFileInformationByHandle(h, &bhfi);
- CloseHandle(h);
- return ret;
-}
-
-void windows_image_path(F_CHAR *full_path, F_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)
-{
- F_CHAR full_path[MAX_UNICODE_PATH];
- F_CHAR *ptr;
- F_CHAR temp_path[MAX_UNICODE_PATH];
-
- if(!GetModuleFileName(NULL, full_path, MAX_UNICODE_PATH))
- fatal_error("GetModuleFileName() failed", 0);
-
- if((ptr = wcsrchr(full_path, '.')))
- *ptr = 0;
-
- snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path);
- temp_path[sizeof(temp_path) - 1] = 0;
-
- return safe_strdup(temp_path);
-}
-
-/* You must free() this yourself. */
-const F_CHAR *vm_executable_path(void)
-{
- F_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)
-{
-
- F_CHAR *path = unbox_u16_string();
- box_boolean(windows_stat(path));
-}
-
-F_SEGMENT *alloc_segment(CELL size)
-{
- char *mem;
- DWORD ignore;
-
- if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
- MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
- out_of_memory();
-
- if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
- 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);
-
- F_SEGMENT *block = safe_malloc(sizeof(F_SEGMENT));
-
- block->start = (CELL)mem + getpagesize();
- block->size = size;
- block->end = block->start + size;
-
- return block;
-}
-
-void dealloc_segment(F_SEGMENT *block)
-{
- SYSTEM_INFO si;
- GetSystemInfo(&si);
- if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
- fatal_error("dealloc_segment failed",0);
- free(block);
-}
-
-long getpagesize(void)
-{
- static long g_pagesize = 0;
- if (! g_pagesize)
- {
- SYSTEM_INFO system_info;
- GetSystemInfo (&system_info);
- g_pagesize = system_info.dwPageSize;
- }
- return g_pagesize;
-}
-
-void sleep_micros(u64 usec)
-{
- Sleep((DWORD)(usec / 1000));
-}
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+HMODULE hFactorDll;
+
+void init_ffi(void)
+{
+ hFactorDll = GetModuleHandle(FACTOR_DLL);
+ if(!hFactorDll)
+ fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
+}
+
+void ffi_dlopen(dll *dll)
+{
+ dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
+}
+
+void *ffi_dlsym(dll *dll, symbol_char *symbol)
+{
+ return GetProcAddress(dll ? (HMODULE)dll->dll : hFactorDll, symbol);
+}
+
+void ffi_dlclose(dll *dll)
+{
+ FreeLibrary((HMODULE)dll->dll);
+ dll->dll = NULL;
+}
+
+bool windows_stat(vm_char *path)
+{
+ BY_HANDLE_FILE_INFORMATION bhfi;
+ HANDLE h = CreateFileW(path,
+ GENERIC_READ,
+ FILE_SHARE_READ,
+ NULL,
+ OPEN_EXISTING,
+ FILE_FLAG_BACKUP_SEMANTICS,
+ NULL);
+
+ if(h == INVALID_HANDLE_VALUE)
+ {
+ // FindFirstFile is the only call that can stat c:\pagefile.sys
+ WIN32_FIND_DATA st;
+ HANDLE h;
+
+ if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
+ return false;
+ FindClose(h);
+ return true;
+ }
+ bool ret;
+ ret = GetFileInformationByHandle(h, &bhfi);
+ CloseHandle(h);
+ return ret;
+}
+
+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 vm_char *default_image_path(void)
+{
+ 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);
+
+ if((ptr = wcsrchr(full_path, '.')))
+ *ptr = 0;
+
+ snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path);
+ temp_path[sizeof(temp_path) - 1] = 0;
+
+ return safe_strdup(temp_path);
+}
+
+/* You must free() this yourself. */
+const vm_char *vm_executable_path(void)
+{
+ 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);
+}
+
+
+PRIMITIVE(existsp)
+{
+ vm_char *path = (vm_char *)(untag_check<byte_array>(dpop()) + 1);
+ box_boolean(windows_stat(path));
+}
+
+segment *alloc_segment(cell size)
+{
+ char *mem;
+ DWORD ignore;
+
+ if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
+ MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
+ out_of_memory();
+
+ if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
+ 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);
+
+ segment *block = safe_malloc(sizeof(segment));
+
+ block->start = (cell)mem + getpagesize();
+ block->size = size;
+ block->end = block->start + size;
+
+ return block;
+}
+
+void dealloc_segment(segment *block)
+{
+ SYSTEM_INFO si;
+ GetSystemInfo(&si);
+ if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
+ fatal_error("dealloc_segment failed",0);
+ free(block);
+}
+
+long getpagesize(void)
+{
+ static long g_pagesize = 0;
+ if (! g_pagesize)
+ {
+ SYSTEM_INFO system_info;
+ GetSystemInfo (&system_info);
+ g_pagesize = system_info.dwPageSize;
+ }
+ return g_pagesize;
+}
+
+void sleep_micros(u64 usec)
+{
+ Sleep((DWORD)(usec / 1000));
+}
+
+}
+++ /dev/null
-#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);
-
--- /dev/null
+#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);
+
+}
+++ /dev/null
-#if defined(__arm__)
- #define FACTOR_ARM
-#elif defined(__amd64__) || defined(__x86_64__)
- #define FACTOR_AMD64
-#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
- #define FACTOR_X86
-#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
- #define FACTOR_PPC
-#else
- #error "Unsupported architecture"
-#endif
-
-#if defined(WINDOWS)
- #if defined(WINCE)
- #include "os-windows-ce.h"
- #else
- #include "os-windows-nt.h"
- #endif
-
- #include "os-windows.h"
- #if defined(FACTOR_AMD64)
- #include "os-windows-nt.64.h"
- #elif defined(FACTOR_X86)
- #include "os-windows-nt.32.h"
- #endif
-#else
- #include "os-unix.h"
-
- #ifdef __APPLE__
- #include "os-macosx.h"
- #include "mach_signal.h"
-
- #ifdef FACTOR_X86
- #include "os-macosx-x86.32.h"
- #elif defined(FACTOR_PPC)
- #include "os-macosx-ppc.h"
- #elif defined(FACTOR_AMD64)
- #include "os-macosx-x86.64.h"
- #else
- #error "Unsupported Mac OS X flavor"
- #endif
- #else
- #include "os-genunix.h"
-
- #ifdef __FreeBSD__
- #define FACTOR_OS_STRING "freebsd"
- #include "os-freebsd.h"
-
- #if defined(FACTOR_X86)
- #include "os-freebsd-x86.32.h"
- #elif defined(FACTOR_AMD64)
- #include "os-freebsd-x86.64.h"
- #else
- #error "Unsupported FreeBSD flavor"
- #endif
- #elif defined(__OpenBSD__)
- #define FACTOR_OS_STRING "openbsd"
-
- #if defined(FACTOR_X86)
- #include "os-openbsd-x86.32.h"
- #elif defined(FACTOR_AMD64)
- #include "os-openbsd-x86.64.h"
- #else
- #error "Unsupported OpenBSD flavor"
- #endif
- #elif defined(__NetBSD__)
- #define FACTOR_OS_STRING "netbsd"
-
- #if defined(FACTOR_X86)
- #include "os-netbsd-x86.32.h"
- #elif defined(FACTOR_AMD64)
- #include "os-netbsd-x86.64.h"
- #else
- #error "Unsupported NetBSD flavor"
- #endif
-
- #include "os-netbsd.h"
- #elif defined(linux)
- #define FACTOR_OS_STRING "linux"
- #include "os-linux.h"
-
- #if defined(FACTOR_X86)
- #include "os-linux-x86.32.h"
- #elif defined(FACTOR_PPC)
- #include "os-linux-ppc.h"
- #elif defined(FACTOR_ARM)
- #include "os-linux-arm.h"
- #elif defined(FACTOR_AMD64)
- #include "os-linux-x86.64.h"
- #else
- #error "Unsupported Linux flavor"
- #endif
- #elif defined(__SVR4) && defined(sun)
- #define FACTOR_OS_STRING "solaris"
-
- #if defined(FACTOR_X86)
- #include "os-solaris-x86.32.h"
- #elif defined(FACTOR_AMD64)
- #include "os-solaris-x86.64.h"
- #else
- #error "Unsupported Solaris flavor"
- #endif
-
- #else
- #error "Unsupported OS"
- #endif
- #endif
-#endif
-
-#if defined(FACTOR_X86)
- #include "cpu-x86.32.h"
- #include "cpu-x86.h"
-#elif defined(FACTOR_AMD64)
- #include "cpu-x86.64.h"
- #include "cpu-x86.h"
-#elif defined(FACTOR_PPC)
- #include "cpu-ppc.h"
-#elif defined(FACTOR_ARM)
- #include "cpu-arm.h"
-#else
- #error "Unsupported CPU"
-#endif
--- /dev/null
+#if defined(__arm__)
+ #define FACTOR_ARM
+#elif defined(__amd64__) || defined(__x86_64__)
+ #define FACTOR_AMD64
+#elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
+ #define FACTOR_X86
+#elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC)
+ #define FACTOR_PPC
+#else
+ #error "Unsupported architecture"
+#endif
+
+#if defined(WINDOWS)
+ #if defined(WINCE)
+ #include "os-windows-ce.hpp"
+ #else
+ #include "os-windows-nt.hpp"
+ #endif
+
+ #include "os-windows.hpp"
+ #if defined(FACTOR_AMD64)
+ #include "os-windows-nt.64.hpp"
+ #elif defined(FACTOR_X86)
+ #include "os-windows-nt.32.hpp"
+ #endif
+#else
+ #include "os-unix.hpp"
+
+ #ifdef __APPLE__
+ #include "os-macosx.hpp"
+ #include "mach_signal.hpp"
+
+ #ifdef FACTOR_X86
+ #include "os-macosx-x86.32.hpp"
+ #elif defined(FACTOR_PPC)
+ #include "os-macosx-ppc.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-macosx-x86.64.hpp"
+ #else
+ #error "Unsupported Mac OS X flavor"
+ #endif
+ #else
+ #include "os-genunix.hpp"
+
+ #ifdef __FreeBSD__
+ #define FACTOR_OS_STRING "freebsd"
+ #include "os-freebsd.hpp"
+
+ #if defined(FACTOR_X86)
+ #include "os-freebsd-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-freebsd-x86.64.hpp"
+ #else
+ #error "Unsupported FreeBSD flavor"
+ #endif
+ #elif defined(__OpenBSD__)
+ #define FACTOR_OS_STRING "openbsd"
+
+ #if defined(FACTOR_X86)
+ #include "os-openbsd-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-openbsd-x86.64.hpp"
+ #else
+ #error "Unsupported OpenBSD flavor"
+ #endif
+ #elif defined(__NetBSD__)
+ #define FACTOR_OS_STRING "netbsd"
+
+ #if defined(FACTOR_X86)
+ #include "os-netbsd-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-netbsd-x86.64.hpp"
+ #else
+ #error "Unsupported NetBSD flavor"
+ #endif
+
+ #include "os-netbsd.hpp"
+ #elif defined(linux)
+ #define FACTOR_OS_STRING "linux"
+ #include "os-linux.hpp"
+
+ #if defined(FACTOR_X86)
+ #include "os-linux-x86.32.hpp"
+ #elif defined(FACTOR_PPC)
+ #include "os-linux-ppc.hpp"
+ #elif defined(FACTOR_ARM)
+ #include "os-linux-arm.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-linux-x86.64.hpp"
+ #else
+ #error "Unsupported Linux flavor"
+ #endif
+ #elif defined(__SVR4) && defined(sun)
+ #define FACTOR_OS_STRING "solaris"
+
+ #if defined(FACTOR_X86)
+ #include "os-solaris-x86.32.hpp"
+ #elif defined(FACTOR_AMD64)
+ #include "os-solaris-x86.64.hpp"
+ #else
+ #error "Unsupported Solaris flavor"
+ #endif
+
+ #else
+ #error "Unsupported OS"
+ #endif
+ #endif
+#endif
+
+#if defined(FACTOR_X86)
+ #include "cpu-x86.32.hpp"
+ #include "cpu-x86.hpp"
+#elif defined(FACTOR_AMD64)
+ #include "cpu-x86.64.hpp"
+ #include "cpu-x86.hpp"
+#elif defined(FACTOR_PPC)
+ #include "cpu-ppc.hpp"
+#elif defined(FACTOR_ARM)
+ #include "cpu-arm.hpp"
+#else
+ #error "Unsupported CPU"
+#endif
+++ /dev/null
-#include "master.h"
-
-void *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,
- primitive_fixnum_divint,
- primitive_fixnum_divmod,
- primitive_fixnum_shift,
- primitive_bignum_eq,
- primitive_bignum_add,
- primitive_bignum_subtract,
- primitive_bignum_multiply,
- primitive_bignum_divint,
- primitive_bignum_mod,
- primitive_bignum_divmod,
- primitive_bignum_and,
- primitive_bignum_or,
- primitive_bignum_xor,
- primitive_bignum_not,
- primitive_bignum_shift,
- primitive_bignum_less,
- primitive_bignum_lesseq,
- primitive_bignum_greater,
- primitive_bignum_greatereq,
- primitive_bignum_bitp,
- primitive_bignum_log2,
- primitive_byte_array_to_bignum,
- 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_word,
- primitive_word_xt,
- primitive_getenv,
- primitive_setenv,
- primitive_existsp,
- primitive_gc,
- primitive_gc_stats,
- primitive_save_image,
- primitive_save_image_and_exit,
- primitive_datastack,
- primitive_retainstack,
- primitive_callstack,
- primitive_set_datastack,
- primitive_set_retainstack,
- primitive_set_callstack,
- primitive_exit,
- primitive_data_room,
- primitive_code_room,
- primitive_micros,
- primitive_modify_code_heap,
- primitive_dlopen,
- primitive_dlsym,
- primitive_dlclose,
- primitive_byte_array,
- primitive_uninitialized_byte_array,
- primitive_displaced_alien,
- 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_alien_address,
- primitive_set_slot,
- primitive_string_nth,
- primitive_set_string_nth_fast,
- primitive_set_string_nth_slow,
- primitive_resize_array,
- primitive_resize_string,
- primitive_array,
- primitive_begin_scan,
- primitive_next_object,
- primitive_end_scan,
- primitive_size,
- primitive_die,
- primitive_fopen,
- primitive_fgetc,
- primitive_fread,
- primitive_fputc,
- primitive_fwrite,
- primitive_fflush,
- primitive_fseek,
- primitive_fclose,
- primitive_wrapper,
- primitive_clone,
- primitive_string,
- primitive_array_to_quotation,
- primitive_quotation_xt,
- primitive_tuple,
- primitive_profiling,
- primitive_become,
- primitive_sleep,
- primitive_tuple_boa,
- primitive_callstack_to_array,
- primitive_innermost_stack_frame_quot,
- primitive_innermost_stack_frame_scan,
- primitive_set_innermost_stack_frame_quot,
- primitive_call_clear,
- primitive_resize_byte_array,
- primitive_dll_validp,
- primitive_unimplemented,
- primitive_clear_gc_stats,
- primitive_jit_compile,
- primitive_load_locals,
- primitive_check_datastack
-};
--- /dev/null
+#include "master.hpp"
+
+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_str_to_float,
+ primitive_float_to_str,
+ primitive_float_bits,
+ primitive_double_bits,
+ primitive_bits_float,
+ primitive_bits_double,
+ primitive_fixnum_add,
+ primitive_fixnum_subtract,
+ primitive_fixnum_multiply,
+ primitive_fixnum_divint,
+ primitive_fixnum_divmod,
+ primitive_fixnum_shift,
+ primitive_bignum_eq,
+ primitive_bignum_add,
+ primitive_bignum_subtract,
+ primitive_bignum_multiply,
+ primitive_bignum_divint,
+ primitive_bignum_mod,
+ primitive_bignum_divmod,
+ primitive_bignum_and,
+ primitive_bignum_or,
+ primitive_bignum_xor,
+ primitive_bignum_not,
+ primitive_bignum_shift,
+ primitive_bignum_less,
+ primitive_bignum_lesseq,
+ primitive_bignum_greater,
+ primitive_bignum_greatereq,
+ primitive_bignum_bitp,
+ primitive_bignum_log2,
+ primitive_byte_array_to_bignum,
+ 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_word,
+ primitive_word_xt,
+ primitive_getenv,
+ primitive_setenv,
+ primitive_existsp,
+ primitive_gc,
+ primitive_gc_stats,
+ primitive_save_image,
+ primitive_save_image_and_exit,
+ primitive_datastack,
+ primitive_retainstack,
+ primitive_callstack,
+ primitive_set_datastack,
+ primitive_set_retainstack,
+ primitive_set_callstack,
+ primitive_exit,
+ primitive_data_room,
+ primitive_code_room,
+ primitive_micros,
+ primitive_modify_code_heap,
+ primitive_dlopen,
+ primitive_dlsym,
+ primitive_dlclose,
+ primitive_byte_array,
+ primitive_uninitialized_byte_array,
+ primitive_displaced_alien,
+ 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_alien_address,
+ primitive_set_slot,
+ primitive_string_nth,
+ primitive_set_string_nth_fast,
+ primitive_set_string_nth_slow,
+ primitive_resize_array,
+ primitive_resize_string,
+ primitive_array,
+ primitive_begin_scan,
+ primitive_next_object,
+ primitive_end_scan,
+ primitive_size,
+ primitive_die,
+ primitive_fopen,
+ primitive_fgetc,
+ primitive_fread,
+ primitive_fputc,
+ primitive_fwrite,
+ primitive_fflush,
+ primitive_fseek,
+ primitive_fclose,
+ primitive_wrapper,
+ primitive_clone,
+ primitive_string,
+ primitive_array_to_quotation,
+ primitive_quotation_xt,
+ primitive_tuple,
+ primitive_profiling,
+ primitive_become,
+ primitive_sleep,
+ primitive_tuple_boa,
+ primitive_callstack_to_array,
+ primitive_innermost_stack_frame_quot,
+ primitive_innermost_stack_frame_scan,
+ primitive_set_innermost_stack_frame_quot,
+ primitive_call_clear,
+ primitive_resize_byte_array,
+ primitive_dll_validp,
+ primitive_unimplemented,
+ primitive_clear_gc_stats,
+ primitive_jit_compile,
+ primitive_load_locals,
+ 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,
+};
+
+}
+++ /dev/null
-extern void *primitives[];
--- /dev/null
+namespace factor
+{
+
+extern "C" typedef void (*primitive_type)();
+extern const primitive_type primitives[];
+
+#define PRIMITIVE(name) extern "C" void primitive_##name()
+
+}
+++ /dev/null
-#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()));
-}
--- /dev/null
+#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()));
+}
+
+}
+++ /dev/null
-bool profiling_p;
-void primitive_profiling(void);
-F_CODE_BLOCK *compile_profiling_stub(F_WORD *word);
-void update_word_xt(F_WORD *word);
--- /dev/null
+namespace factor
+{
+
+extern bool profiling_p;
+void init_profiler(void);
+code_block *compile_profiling_stub(cell word);
+PRIMITIVE(profiling);
+
+}
+++ /dev/null
-#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);
-}
--- /dev/null
+#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();
+}
+
+}
+++ /dev/null
-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);
--- /dev/null
+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);
+
+}
+++ /dev/null
-#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;
-}
--- /dev/null
+#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()));
+}
+
+}
+++ /dev/null
-#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;
--- /dev/null
+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];
--- /dev/null
+namespace factor
+{
+
+struct segment {
+ cell start;
+ cell size;
+ cell end;
+};
+
+}
--- /dev/null
+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); \
+ }
+
+}
--- /dev/null
+#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)
+ && (str->aux == F || in_zone(&nursery,untag<byte_array>(str->aux)))
+ && 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);
+}
+
+}
--- /dev/null
+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);
+
+}
--- /dev/null
+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();
+}
+
+}
--- /dev/null
+#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());
+}
+
+}
--- /dev/null
+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);
+
+}
+++ /dev/null
-#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);
-}
+++ /dev/null
-/* 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))
+++ /dev/null
-#include "master.h"
-
-/* If memory allocation fails, bail out */
-void *safe_malloc(size_t size)
-{
- void *ptr = malloc(size);
- if(!ptr) fatal_error("Out of memory in safe_malloc", 0);
- return ptr;
-}
-
-F_CHAR *safe_strdup(const F_CHAR *str)
-{
- F_CHAR *ptr = STRDUP(str);
- if(!ptr) fatal_error("Out of memory in safe_strdup", 0);
- return ptr;
-}
-
-/* We don't use printf directly, because format directives are not portable.
-Instead we define the common cases here. */
-void nl(void)
-{
- fputs("\n",stdout);
-}
-
-void print_string(const char *str)
-{
- fputs(str,stdout);
-}
-
-void print_cell(CELL x)
-{
- printf(CELL_FORMAT,x);
-}
-
-void print_cell_hex(CELL x)
-{
- printf(CELL_HEX_FORMAT,x);
-}
-
-void print_cell_hex_pad(CELL x)
-{
- printf(CELL_HEX_PAD_FORMAT,x);
-}
-
-void print_fixnum(F_FIXNUM x)
-{
- printf(FIXNUM_FORMAT,x);
-}
-
-CELL read_cell_hex(void)
-{
- CELL cell;
- scanf(CELL_HEX_FORMAT,&cell);
- return cell;
-};
--- /dev/null
+#include "master.hpp"
+
+namespace factor
+{
+
+/* If memory allocation fails, bail out */
+void *safe_malloc(size_t size)
+{
+ void *ptr = malloc(size);
+ if(!ptr) fatal_error("Out of memory in safe_malloc", 0);
+ return ptr;
+}
+
+vm_char *safe_strdup(const vm_char *str)
+{
+ vm_char *ptr = STRDUP(str);
+ if(!ptr) fatal_error("Out of memory in safe_strdup", 0);
+ return ptr;
+}
+
+/* We don't use printf directly, because format directives are not portable.
+Instead we define the common cases here. */
+void nl(void)
+{
+ fputs("\n",stdout);
+}
+
+void print_string(const char *str)
+{
+ fputs(str,stdout);
+}
+
+void print_cell(cell x)
+{
+ printf(cell_FORMAT,x);
+}
+
+void print_cell_hex(cell x)
+{
+ printf(cell_HEX_FORMAT,x);
+}
+
+void print_cell_hex_pad(cell x)
+{
+ printf(cell_HEX_PAD_FORMAT,x);
+}
+
+void print_fixnum(fixnum x)
+{
+ printf(FIXNUM_FORMAT,x);
+}
+
+cell read_cell_hex(void)
+{
+ cell cell;
+ if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1);
+ return cell;
+};
+
+}
+++ /dev/null
-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);
--- /dev/null
+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);
+
+}
--- /dev/null
+#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));
+}
+
+}
--- /dev/null
+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);
+
+}
--- /dev/null
+#include "master.hpp"
+
+using namespace factor;
+
+cell cards_offset;
+cell decks_offset;
+cell allot_markers_offset;
+++ /dev/null
-/* 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);
-}
--- /dev/null
+/* 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);
+}
+
+}