CC = gcc
+CPP = g++
AR = ar
LD = ld
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): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
- $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
- $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
$(TEST_LIBRARY): vm/ffi_test.o
clean:
rm -f vm/*.o
- rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
+ rm -f factor.dll
+ rm -f libfactor.*
+ rm -f libfactor-ffi-test.*
+ rm -f Factor.app/Contents/Frameworks/libfactor.dylib
+
+tags:
+ etags vm/*.{cpp,hpp,mm,S,c}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
.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
-gcc.
-
Factor supports various platforms. For an up-to-date list, see
<http://factorcode.org>.
-Factor requires gcc 3.4 or later.
-
-On x86, Factor /will not/ build using gcc 3.3 or earlier.
-
-If you are using gcc 4.3, you might get an unusable Factor binary unless
-you add 'SITE_CFLAGS=-fno-forward-propagate' to the command-line
-arguments for make.
+The Factor VM is written in C++ and uses GNU extensions. When compiling
+with GCC 3.x, boost::unordered_map must be installed. On GCC 4.x, Factor
+uses std::tr1::unordered_map which is shipped as part of GCC.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
* Bootstrapping the Factor image
-Once you have compiled the Factor runtime, you must bootstrap the Factor
+Once you have compiled the Factor VM, you must bootstrap the Factor
system using the image that corresponds to your CPU architecture.
Boot images can be obtained from <http://factorcode.org/images/latest/>.
Then bootstrap with the following switches:
- ./factor -i=boot.<cpu>.image -ui-backend=x11 -ui-text-backend=pango
+ ./factor -i=boot.<cpu>.image -ui-backend=x11
Now if $DISPLAY is set, running ./factor will start the UI.
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/ - Factor VM
core/ - Factor core library
basis/ - Factor basis library, compiler, tools
extra/ - more libraries and applications
] 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
! 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 ;
"uchar" define-primitive-type
<c-type>
- [ alien-unsigned-4 zero? not ] >>getter
- [ [ 1 0 ? ] 2dip set-alien-unsigned-4 ] >>setter
- 4 >>size
- 4 >>align
+ [ alien-unsigned-1 zero? not ] >>getter
+ [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
+ 1 >>size
+ 1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
"bool" define-primitive-type
{ $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" }
! 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 ) [ string>symbol ] 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
"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
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
! which are also quick to compile are replaced by
! compiled definitions as soon as possible.
{
- roll -roll declare not
+ not
array? hashtable? vector?
tuple? sbuf? tombstone?
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 bootstrap.image.syntax ;
IN: bootstrap.image
: arch ( os cpu -- arch )
SYMBOL: sub-primitives
-: make-jit ( quot rc rt offset -- quad )
- [ [ call( -- ) ] { } make ] 3dip 4array ;
+SYMBOL: jit-relocations
-: jit-define ( quot rc rt offset name -- )
+: compute-offset ( rc -- offset )
+ [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
+
+: jit-rel ( rc rt -- )
+ over compute-offset 3array jit-relocations get push-all ;
+
+: make-jit ( quot -- jit-data )
+ [
+ V{ } clone jit-relocations set
+ call( -- )
+ jit-relocations get >array
+ ] 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
! Bootstrap architecture name
SYMBOL: architecture
-! Bootstrap global namesapce
-SYMBOL: bootstrap-global
+RESET
! Boot quotation, set in stage1.factor
-SYMBOL: bootstrap-boot-quot
+USERENV: bootstrap-boot-quot 20
+
+! Bootstrap global namesapce
+USERENV: bootstrap-global 21
! JIT parameters
-SYMBOL: jit-code-format
-SYMBOL: jit-prolog
-SYMBOL: jit-primitive-word
-SYMBOL: jit-primitive
-SYMBOL: jit-word-jump
-SYMBOL: jit-word-call
-SYMBOL: jit-push-immediate
-SYMBOL: jit-if-word
-SYMBOL: jit-if-1
-SYMBOL: jit-if-2
-SYMBOL: jit-dispatch-word
-SYMBOL: jit-dispatch
-SYMBOL: jit-dip-word
-SYMBOL: jit-dip
-SYMBOL: jit-2dip-word
-SYMBOL: jit-2dip
-SYMBOL: jit-3dip-word
-SYMBOL: jit-3dip
-SYMBOL: jit-epilog
-SYMBOL: jit-return
-SYMBOL: jit-profiling
-SYMBOL: jit-declare-word
-SYMBOL: jit-save-stack
+USERENV: jit-prolog 23
+USERENV: jit-primitive-word 24
+USERENV: jit-primitive 25
+USERENV: jit-word-jump 26
+USERENV: jit-word-call 27
+USERENV: jit-word-special 28
+USERENV: jit-if-word 29
+USERENV: jit-if 30
+USERENV: jit-epilog 31
+USERENV: jit-return 32
+USERENV: jit-profiling 33
+USERENV: jit-push-immediate 34
+USERENV: jit-dip-word 35
+USERENV: jit-dip 36
+USERENV: jit-2dip-word 37
+USERENV: jit-2dip 38
+USERENV: jit-3dip-word 39
+USERENV: jit-3dip 40
+USERENV: jit-execute-word 41
+USERENV: jit-execute-jump 42
+USERENV: jit-execute-call 43
+
+! PIC stubs
+USERENV: pic-load 47
+USERENV: pic-tag 48
+USERENV: pic-hi-tag 49
+USERENV: pic-tuple 50
+USERENV: pic-hi-tag-tuple 51
+USERENV: pic-check-tag 52
+USERENV: pic-check 53
+USERENV: pic-hit 54
+USERENV: pic-miss-word 55
+USERENV: pic-miss-tail-word 56
+
+! Megamorphic dispatch
+USERENV: mega-lookup 57
+USERENV: mega-lookup-word 58
+USERENV: mega-miss-word 59
! Default definition for undefined words
-SYMBOL: undefined-quot
-
-: userenvs ( -- assoc )
- H{
- { bootstrap-boot-quot 20 }
- { bootstrap-global 21 }
- { jit-code-format 22 }
- { jit-prolog 23 }
- { jit-primitive-word 24 }
- { jit-primitive 25 }
- { jit-word-jump 26 }
- { jit-word-call 27 }
- { 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 }
- { undefined-quot 60 }
- } ; inline
+USERENV: undefined-quot 60
: userenv-offset ( symbol -- n )
- userenvs at header-size + ;
+ userenvs get at header-size + ;
: emit ( cell -- ) image get push ;
: 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 , ]
+ [ pic-def>> , ]
+ [ pic-tail-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
class<=-cache class-not-cache classes-intersect-cache
class-and-cache class-or-cache next-method-quot-cache
} [ H{ } clone ] H{ } map>assoc assoc-union
- bootstrap-global set
- bootstrap-global emit-userenv ;
-
-: emit-boot-quot ( -- )
- bootstrap-boot-quot emit-userenv ;
+ bootstrap-global set ;
: 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
- [ undefined ] undefined-quot set
- {
- jit-code-format
- jit-prolog
- jit-primitive-word
- jit-primitive
- jit-word-jump
- jit-word-call
- jit-push-immediate
- 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-epilog
- jit-return
- jit-profiling
- jit-declare-word
- jit-save-stack
- undefined-quot
- } [ emit-userenv ] each ;
+ \ (execute) jit-execute-word set
+ \ inline-cache-miss \ pic-miss-word set
+ \ inline-cache-miss-tail \ pic-miss-tail-word set
+ \ mega-cache-lookup \ mega-lookup-word set
+ \ mega-cache-miss \ mega-miss-word set
+ [ undefined ] undefined-quot set ;
+
+: emit-userenvs ( -- )
+ userenvs get keys [ emit-userenv ] each ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
emit-jit-data
"Serializing global namespace..." print flush
emit-global
- "Serializing boot quotation..." print flush
- emit-boot-quot
+ "Serializing user environment..." print flush
+ emit-userenvs
"Performing word fixups..." print flush
fixup-words
"Performing header fixups..." print flush
--- /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: parser kernel namespaces assocs words.symbol ;
+IN: bootstrap.image.syntax
+
+SYMBOL: userenvs
+
+SYNTAX: RESET H{ } clone userenvs set-global ;
+
+SYNTAX: USERENV:
+ CREATE-WORD scan-word
+ [ swap userenvs get set-at ]
+ [ drop define-symbol ]
+ 2bi ;
\ No newline at end of file
"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 ;
"stage2: deployment mode" print
] [
"debugger" require
- "alien.prettyprint" require
"inspector" require
"tools.errors" require
"listener" require
"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: 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 )
-! Copyright (C) 2006 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
IN: cocoa
: (remember-send) ( selector variable -- )
- global [ dupd ?set-at ] change-at ;
+ [ dupd ?set-at ] change-global ;
SYMBOL: sent-messages
frameworks [ V{ } clone ] initialize
-[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
+[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
SYNTAX: IMPORT: scan [ ] import-objc-class ;
-"Compiling Objective C bridge..." print
+"Importing Cocoa classes..." print
"cocoa.classes" create-vocab drop
-{
- "cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
-} [ words ] map concat compile
-
-"Importing Cocoa classes..." print
-
[
{
"NSApplication"
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: ;
[ 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 ;
-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
[ 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 ] }
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
SYMBOL: compiling-word
-: compiled-stack-traces? ( -- ? ) 59 getenv ;
+: compiled-stack-traces? ( -- ? ) 67 getenv ;
! Mapping _label IDs to label instances
SYMBOL: labels
word>> dup sub-primitive>>
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
-M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ;
+M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
M: ##return generate-insn drop %return ;
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-pic ( word class -- )
+ [ add-literal ] dip rt-xt-pic rel-fixup ;
+
+: rel-word-pic-tail ( word class -- )
+ [ add-literal ] dip rt-xt-pic-tail 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: 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 words.private ;
+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:"
! 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 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 compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
+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
+compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
+compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
SYMBOL: compiled
-: queue-compile? ( word -- ? )
+: compile? ( word -- ? )
#! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
} 1|| not ;
: queue-compile ( word -- )
- dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
+ dup compile? [ compile-queue get push-front ] [ drop ] if ;
: recompile-callers? ( word -- ? )
changed-effects get key? ;
H{ } clone generic-dependencies set
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 -- ? )
#! Ignore some errors on inline combinators, macros, and special
#! words such as 'call'.
{
[ macro? ]
[ inline? ]
+ [ no-compile? ]
[ "special" word-prop ]
- [ "no-compile" word-prop ]
} 1||
] [
{
: 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.
- 2dup ignore-error? [
- drop
- [ dup def>> deoptimize-with ]
- [ clear-compiler-error ]
- bi
- ] [
- [ swap <compiler-error> compiler-error ]
- [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
- 2bi
- ] if ;
+ {
+ { [ dup inference-error? not ] [ rethrow ] }
+ { [ 2dup ignore-error? ] [ ignore-error ] }
+ [ remember-error ]
+ } cond ;
+
+: optimize? ( word -- ? )
+ { [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
+
+: contains-breakpoints? ( -- ? )
+ dependencies get keys [ "break?" word-prop ] any? ;
: frontend ( word -- nodes )
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
- dup contains-breakpoints? [ dup def>> deoptimize-with ] [
- [ build-tree ] [ deoptimize ] recover optimize-tree
- ] if ;
+ dup optimize? [
+ [ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
+ contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
+ ] [ dup def>> deoptimize-with ] if ;
: compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee.
- dup optimized>> [ drop ] [ queue-compile ] if ;
+ dup optimized? [ drop ] [ queue-compile ] if ;
! Only switch this off for debugging.
SYMBOL: compile-dependencies?
[
<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 ( -- )
-! 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 literals sequences ;
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 ) 8 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
-: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
+: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
+: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
+: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
+: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
+: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
! Relocation classes
-CONSTANT: rc-absolute-cell 0
-CONSTANT: rc-absolute 1
-CONSTANT: rc-relative 2
+CONSTANT: rc-absolute-cell 0
+CONSTANT: rc-absolute 1
+CONSTANT: rc-relative 2
CONSTANT: rc-absolute-ppc-2/2 3
-CONSTANT: rc-relative-ppc-2 4
-CONSTANT: rc-relative-ppc-3 5
-CONSTANT: rc-relative-arm-3 6
-CONSTANT: rc-indirect-arm 7
-CONSTANT: rc-indirect-arm-pc 8
+CONSTANT: rc-absolute-ppc-2 4
+CONSTANT: rc-relative-ppc-2 5
+CONSTANT: rc-relative-ppc-3 6
+CONSTANT: rc-relative-arm-3 7
+CONSTANT: rc-indirect-arm 8
+CONSTANT: rc-indirect-arm-pc 9
! Relocation types
-CONSTANT: rt-primitive 0
-CONSTANT: rt-dlsym 1
-CONSTANT: rt-dispatch 2
-CONSTANT: rt-xt 3
-CONSTANT: rt-here 4
-CONSTANT: rt-this 5
-CONSTANT: rt-immediate 6
-CONSTANT: rt-stack-chain 7
+CONSTANT: rt-primitive 0
+CONSTANT: rt-dlsym 1
+CONSTANT: rt-dispatch 2
+CONSTANT: rt-xt 3
+CONSTANT: rt-xt-pic 4
+CONSTANT: rt-xt-pic-tail 5
+CONSTANT: rt-here 6
+CONSTANT: rt-this 7
+CONSTANT: rt-immediate 8
+CONSTANT: rt-stack-chain 9
+CONSTANT: rt-untagged 10
+CONSTANT: rt-megamorphic-cache-hits 11
: rc-absolute? ( n -- ? )
- [ rc-absolute-ppc-2/2 = ]
- [ rc-absolute-cell = ]
- [ rc-absolute = ]
- tri or or ;
+ ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;
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 )
C{ 1.0 2.0 }
C{ 1.5 1.0 } ffi_test_47
] unit-test
+
+! Reported by jedahu
+C-STRUCT: bool-field-test
+ { "char*" "name" }
+ { "bool" "on" }
+ { "short" "parents" } ;
+
+FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
+
+[ 123 ] [
+ "bool-field-test" <c-object> 123 over set-bool-field-test-parents
+ ffi_test_48
+] unit-test
\ No newline at end of file
--- /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.
--- /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
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
: 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
dup "a" get { array-capacity } declare >=
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
-[ t ] [ \ interval-inference-bug optimized>> ] unit-test
+[ 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
+
+! Modular arithmetic bug
+: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
+
+[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
+[ -10 ] [ -10 modular-arithmetic-bug ] 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
\ test-11 forget
\ quot forget
] with-compilation-unit
-] unit-test
\ No newline at end of file
+] 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
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.
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.
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.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.
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.
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.
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.
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.
-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
+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( -- obj )
+ "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 ;
#! 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.
- specialize-method? off
- [
- #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
- {
- { [ 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 ;
+ f specialize-method? [
+ [
+ #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d
+ {
+ { [ 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? ;
[ 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 ]
M: #call run-escape-analysis*
{
- { [ dup word>> \ <complex> eq? ] [ t ] }
{ [ dup immutable-tuple-boa? ] [ t ] }
[ f ]
} cond nip ;
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 ;
] { mod fixnum-mod } inlined?
] unit-test
-
[ f ] [
[
256 mod
] { mod fixnum-mod } inlined?
] unit-test
+[ f ] [
+ [
+ >fixnum 256 mod
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
[ f ] [
[
dup 0 >= [ 256 mod ] when
{ integer } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test
+
+[ [ >fixnum 255 fixnum-bitand ] ]
+[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
\ No newline at end of file
! See http://factorcode.org/license.txt for BSD license.
USING: math math.partial-dispatch namespaces sequences sets
accessors assocs words kernel memoize fry combinators
+combinators.short-circuit
compiler.tree
compiler.tree.combinators
compiler.tree.def-use
: optimize->fixnum ( #call -- nodes )
dup redundant->fixnum? [ drop f ] when ;
+: optimize->integer ( #call -- nodes )
+ dup out-d>> first actually-used-by dup length 1 = [
+ first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
+ [ drop { } ] when
+ ] [ drop ] if ;
+
MEMO: fixnum-coercion ( flags -- nodes )
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
M: #call optimize-modular-arithmetic*
dup word>> {
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
+ { [ dup \ >integer eq? ] [ drop optimize->integer ] }
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
[ drop ]
} cond ;
: <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 )
! 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 hints
locals
] sum-outputs ;
: should-inline? ( #call word -- ? )
- {
- { [ dup contains-breakpoints? ] [ 2drop f ] }
- { [ dup "inline" word-prop ] [ 2drop t ] }
- [ inlining-rank 5 >= ]
- } cond ;
+ dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
SYMBOL: history
{ curry compose } memq? ;
: never-inline-word? ( word -- ? )
- [ deferred? ]
- [ "default" word-prop ]
- [ { call execute } memq? ] tri or or ;
+ [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
comparison-ops
[ dup '[ _ define-comparison-constraints ] each-derived-op ] each
-! generic-comparison-ops [
-! dup specific-comparison define-comparison-constraints
-! ] each
-
! Remove redundant comparisons
: fold-comparison ( info1 info2 word -- info )
[ [ interval>> ] bi@ ] dip interval-comparison {
{ >float float }
{ fixnum>float float }
{ bignum>float float }
+
+ { >integer integer }
} [
'[
_
] "outputs" set-word-prop
] assoc-each
+: rem-custom-inlining ( #call -- quot/f )
+ second value-info literal>> dup integer?
+ [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
+
{
mod-integer-integer
mod-integer-fixnum
mod-fixnum-integer
fixnum-mod
- rem
} [
[
- in-d>> second value-info >literal<
- [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
+ in-d>> dup first value-info interval>> [0,inf] interval-subset?
+ [ rem-custom-inlining ] [ drop f ] if
] "custom-inlining" set-word-prop
] each
+\ rem [
+ in-d>> rem-custom-inlining
+] "custom-inlining" set-word-prop
+
{
bitand-integer-integer
bitand-integer-fixnum
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
[ V{ } ] [ [ ] 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
[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test
[ 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
+
+! Joe found an oversight
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
\ No newline at end of file
: 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
[ 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 ;
\ 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 )
HOOK: stack-frame-size cpu ( stack-frame -- n )
HOOK: %call cpu ( word -- )
+HOOK: %jump cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )
make vocabs sequences ;
: test-assembler ( expected quot -- )
- [ 1array ] [ [ { } make ] curry ] bi* unit-test ;
+ [ 1array ] [ [ B{ } make ] curry ] bi* unit-test ;
-{ HEX: 38220003 } [ 1 2 3 ADDI ] test-assembler
-{ HEX: 3c220003 } [ 1 2 3 ADDIS ] test-assembler
-{ HEX: 30220003 } [ 1 2 3 ADDIC ] test-assembler
-{ HEX: 34220003 } [ 1 2 3 ADDIC. ] test-assembler
-{ HEX: 38400001 } [ 1 2 LI ] test-assembler
-{ HEX: 3c400001 } [ 1 2 LIS ] test-assembler
-{ HEX: 3822fffd } [ 1 2 3 SUBI ] test-assembler
-{ HEX: 1c220003 } [ 1 2 3 MULI ] test-assembler
-{ HEX: 7c221a14 } [ 1 2 3 ADD ] test-assembler
-{ HEX: 7c221a15 } [ 1 2 3 ADD. ] test-assembler
-{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
-{ HEX: 7c221e15 } [ 1 2 3 ADDO. ] test-assembler
-{ HEX: 7c221814 } [ 1 2 3 ADDC ] test-assembler
-{ HEX: 7c221815 } [ 1 2 3 ADDC. ] test-assembler
-{ HEX: 7c221e14 } [ 1 2 3 ADDO ] test-assembler
-{ HEX: 7c221c15 } [ 1 2 3 ADDCO. ] test-assembler
-{ HEX: 7c221914 } [ 1 2 3 ADDE ] test-assembler
-{ HEX: 7c411838 } [ 1 2 3 AND ] test-assembler
-{ HEX: 7c411839 } [ 1 2 3 AND. ] test-assembler
-{ HEX: 7c221bd6 } [ 1 2 3 DIVW ] test-assembler
-{ HEX: 7c221b96 } [ 1 2 3 DIVWU ] test-assembler
-{ HEX: 7c411a38 } [ 1 2 3 EQV ] test-assembler
-{ HEX: 7c411bb8 } [ 1 2 3 NAND ] test-assembler
-{ HEX: 7c4118f8 } [ 1 2 3 NOR ] test-assembler
-{ HEX: 7c4110f8 } [ 1 2 NOT ] test-assembler
-{ HEX: 60410003 } [ 1 2 3 ORI ] test-assembler
-{ HEX: 64410003 } [ 1 2 3 ORIS ] test-assembler
-{ HEX: 7c411b78 } [ 1 2 3 OR ] test-assembler
-{ HEX: 7c411378 } [ 1 2 MR ] test-assembler
-{ HEX: 7c221896 } [ 1 2 3 MULHW ] test-assembler
-{ HEX: 1c220003 } [ 1 2 3 MULLI ] test-assembler
-{ HEX: 7c221816 } [ 1 2 3 MULHWU ] test-assembler
-{ HEX: 7c2219d6 } [ 1 2 3 MULLW ] test-assembler
-{ HEX: 7c411830 } [ 1 2 3 SLW ] test-assembler
-{ HEX: 7c411e30 } [ 1 2 3 SRAW ] test-assembler
-{ HEX: 7c411c30 } [ 1 2 3 SRW ] test-assembler
-{ HEX: 7c411e70 } [ 1 2 3 SRAWI ] test-assembler
-{ HEX: 7c221850 } [ 1 2 3 SUBF ] test-assembler
-{ HEX: 7c221810 } [ 1 2 3 SUBFC ] test-assembler
-{ HEX: 7c221910 } [ 1 2 3 SUBFE ] test-assembler
-{ HEX: 7c410774 } [ 1 2 EXTSB ] test-assembler
-{ HEX: 68410003 } [ 1 2 3 XORI ] test-assembler
-{ HEX: 7c411a78 } [ 1 2 3 XOR ] test-assembler
-{ HEX: 7c2200d0 } [ 1 2 NEG ] test-assembler
-{ HEX: 2c220003 } [ 1 2 3 CMPI ] test-assembler
-{ HEX: 28220003 } [ 1 2 3 CMPLI ] test-assembler
-{ HEX: 7c411800 } [ 1 2 3 CMP ] test-assembler
-{ HEX: 5422190a } [ 1 2 3 4 5 RLWINM ] test-assembler
-{ HEX: 54221838 } [ 1 2 3 SLWI ] test-assembler
-{ HEX: 5422e8fe } [ 1 2 3 SRWI ] test-assembler
-{ HEX: 88220003 } [ 1 2 3 LBZ ] test-assembler
-{ HEX: 8c220003 } [ 1 2 3 LBZU ] test-assembler
-{ HEX: a8220003 } [ 1 2 3 LHA ] test-assembler
-{ HEX: ac220003 } [ 1 2 3 LHAU ] test-assembler
-{ HEX: a0220003 } [ 1 2 3 LHZ ] test-assembler
-{ HEX: a4220003 } [ 1 2 3 LHZU ] test-assembler
-{ HEX: 80220003 } [ 1 2 3 LWZ ] test-assembler
-{ HEX: 84220003 } [ 1 2 3 LWZU ] test-assembler
-{ HEX: 7c4118ae } [ 1 2 3 LBZX ] test-assembler
-{ HEX: 7c4118ee } [ 1 2 3 LBZUX ] test-assembler
-{ HEX: 7c411aae } [ 1 2 3 LHAX ] test-assembler
-{ HEX: 7c411aee } [ 1 2 3 LHAUX ] test-assembler
-{ HEX: 7c411a2e } [ 1 2 3 LHZX ] test-assembler
-{ HEX: 7c411a6e } [ 1 2 3 LHZUX ] test-assembler
-{ HEX: 7c41182e } [ 1 2 3 LWZX ] test-assembler
-{ HEX: 7c41186e } [ 1 2 3 LWZUX ] test-assembler
-{ HEX: 48000001 } [ 1 B ] test-assembler
-{ HEX: 48000001 } [ 1 BL ] test-assembler
-{ HEX: 41800004 } [ 1 BLT ] test-assembler
-{ HEX: 41810004 } [ 1 BGT ] test-assembler
-{ HEX: 40810004 } [ 1 BLE ] test-assembler
-{ HEX: 40800004 } [ 1 BGE ] test-assembler
-{ HEX: 41800004 } [ 1 BLT ] test-assembler
-{ HEX: 40820004 } [ 1 BNE ] test-assembler
-{ HEX: 41820004 } [ 1 BEQ ] test-assembler
-{ HEX: 41830004 } [ 1 BO ] test-assembler
-{ HEX: 40830004 } [ 1 BNO ] test-assembler
-{ HEX: 4c200020 } [ 1 BCLR ] test-assembler
-{ HEX: 4e800020 } [ BLR ] test-assembler
-{ HEX: 4e800021 } [ BLRL ] test-assembler
-{ HEX: 4c200420 } [ 1 BCCTR ] test-assembler
-{ HEX: 4e800420 } [ BCTR ] test-assembler
-{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
-{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
-{ HEX: 7c6902a6 } [ 3 MFCTR ] test-assembler
-{ HEX: 7c6103a6 } [ 3 MTXER ] test-assembler
-{ HEX: 7c6803a6 } [ 3 MTLR ] test-assembler
-{ HEX: 7c6903a6 } [ 3 MTCTR ] test-assembler
-{ HEX: 7c6102a6 } [ 3 MFXER ] test-assembler
-{ HEX: 7c6802a6 } [ 3 MFLR ] test-assembler
-{ HEX: c0220003 } [ 1 2 3 LFS ] test-assembler
-{ HEX: c4220003 } [ 1 2 3 LFSU ] test-assembler
-{ HEX: c8220003 } [ 1 2 3 LFD ] test-assembler
-{ HEX: cc220003 } [ 1 2 3 LFDU ] test-assembler
-{ HEX: d0220003 } [ 1 2 3 STFS ] test-assembler
-{ HEX: d4220003 } [ 1 2 3 STFSU ] test-assembler
-{ HEX: d8220003 } [ 1 2 3 STFD ] test-assembler
-{ HEX: dc220003 } [ 1 2 3 STFDU ] test-assembler
-{ HEX: fc201048 } [ 1 2 FMR ] test-assembler
-{ HEX: fc20101e } [ 1 2 FCTIWZ ] test-assembler
-{ HEX: fc22182a } [ 1 2 3 FADD ] test-assembler
-{ HEX: fc22182b } [ 1 2 3 FADD. ] test-assembler
-{ HEX: fc221828 } [ 1 2 3 FSUB ] test-assembler
-{ HEX: fc2200f2 } [ 1 2 3 FMUL ] test-assembler
-{ HEX: fc221824 } [ 1 2 3 FDIV ] test-assembler
-{ HEX: fc20102c } [ 1 2 FSQRT ] test-assembler
-{ 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
+B{ HEX: 38 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDI ] test-assembler
+B{ HEX: 3c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIS ] test-assembler
+B{ HEX: 30 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC ] test-assembler
+B{ HEX: 34 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 ADDIC. ] test-assembler
+B{ HEX: 38 HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LI ] test-assembler
+B{ HEX: 3c HEX: 40 HEX: 00 HEX: 01 } [ 1 2 LIS ] test-assembler
+B{ HEX: 38 HEX: 22 HEX: ff HEX: fd } [ 1 2 3 SUBI ] test-assembler
+B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULI ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1a HEX: 14 } [ 1 2 3 ADD ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1a HEX: 15 } [ 1 2 3 ADD. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1e HEX: 15 } [ 1 2 3 ADDO. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 14 } [ 1 2 3 ADDC ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 15 } [ 1 2 3 ADDC. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1e HEX: 14 } [ 1 2 3 ADDO ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1c HEX: 15 } [ 1 2 3 ADDCO. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 19 HEX: 14 } [ 1 2 3 ADDE ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 38 } [ 1 2 3 AND ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 39 } [ 1 2 3 AND. ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1b HEX: d6 } [ 1 2 3 DIVW ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 1b HEX: 96 } [ 1 2 3 DIVWU ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 38 } [ 1 2 3 EQV ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1b HEX: b8 } [ 1 2 3 NAND ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: f8 } [ 1 2 3 NOR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 10 HEX: f8 } [ 1 2 NOT ] test-assembler
+B{ HEX: 60 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORI ] test-assembler
+B{ HEX: 64 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 ORIS ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1b HEX: 78 } [ 1 2 3 OR ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 13 HEX: 78 } [ 1 2 MR ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 96 } [ 1 2 3 MULHW ] test-assembler
+B{ HEX: 1c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 MULLI ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 16 } [ 1 2 3 MULHWU ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 19 HEX: d6 } [ 1 2 3 MULLW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 30 } [ 1 2 3 SLW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1e HEX: 30 } [ 1 2 3 SRAW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1c HEX: 30 } [ 1 2 3 SRW ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1e HEX: 70 } [ 1 2 3 SRAWI ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 50 } [ 1 2 3 SUBF ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 18 HEX: 10 } [ 1 2 3 SUBFC ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 19 HEX: 10 } [ 1 2 3 SUBFE ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 07 HEX: 74 } [ 1 2 EXTSB ] test-assembler
+B{ HEX: 68 HEX: 41 HEX: 00 HEX: 03 } [ 1 2 3 XORI ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 78 } [ 1 2 3 XOR ] test-assembler
+B{ HEX: 7c HEX: 22 HEX: 00 HEX: d0 } [ 1 2 NEG ] test-assembler
+B{ HEX: 2c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPI ] test-assembler
+B{ HEX: 28 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 CMPLI ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 CMP ] test-assembler
+B{ HEX: 54 HEX: 22 HEX: 19 HEX: 0a } [ 1 2 3 4 5 RLWINM ] test-assembler
+B{ HEX: 54 HEX: 22 HEX: 18 HEX: 38 } [ 1 2 3 SLWI ] test-assembler
+B{ HEX: 54 HEX: 22 HEX: e8 HEX: fe } [ 1 2 3 SRWI ] test-assembler
+B{ HEX: 88 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZ ] test-assembler
+B{ HEX: 8c HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LBZU ] test-assembler
+B{ HEX: a8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHA ] test-assembler
+B{ HEX: ac HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHAU ] test-assembler
+B{ HEX: a0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZ ] test-assembler
+B{ HEX: a4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LHZU ] test-assembler
+B{ HEX: 80 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZ ] test-assembler
+B{ HEX: 84 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LWZU ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: ae } [ 1 2 3 LBZX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: ee } [ 1 2 3 LBZUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: ae } [ 1 2 3 LHAX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: ee } [ 1 2 3 LHAUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 2e } [ 1 2 3 LHZX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 1a HEX: 6e } [ 1 2 3 LHZUX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 2e } [ 1 2 3 LWZX ] test-assembler
+B{ HEX: 7c HEX: 41 HEX: 18 HEX: 6e } [ 1 2 3 LWZUX ] test-assembler
+B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 B ] test-assembler
+B{ HEX: 48 HEX: 00 HEX: 00 HEX: 01 } [ 1 BL ] test-assembler
+B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
+B{ HEX: 41 HEX: 81 HEX: 00 HEX: 04 } [ 1 BGT ] test-assembler
+B{ HEX: 40 HEX: 81 HEX: 00 HEX: 04 } [ 1 BLE ] test-assembler
+B{ HEX: 40 HEX: 80 HEX: 00 HEX: 04 } [ 1 BGE ] test-assembler
+B{ HEX: 41 HEX: 80 HEX: 00 HEX: 04 } [ 1 BLT ] test-assembler
+B{ HEX: 40 HEX: 82 HEX: 00 HEX: 04 } [ 1 BNE ] test-assembler
+B{ HEX: 41 HEX: 82 HEX: 00 HEX: 04 } [ 1 BEQ ] test-assembler
+B{ HEX: 41 HEX: 83 HEX: 00 HEX: 04 } [ 1 BO ] test-assembler
+B{ HEX: 40 HEX: 83 HEX: 00 HEX: 04 } [ 1 BNO ] test-assembler
+B{ HEX: 4c HEX: 20 HEX: 00 HEX: 20 } [ 1 BCLR ] test-assembler
+B{ HEX: 4e HEX: 80 HEX: 00 HEX: 20 } [ BLR ] test-assembler
+B{ HEX: 4e HEX: 80 HEX: 00 HEX: 21 } [ BLRL ] test-assembler
+B{ HEX: 4c HEX: 20 HEX: 04 HEX: 20 } [ 1 BCCTR ] test-assembler
+B{ HEX: 4e HEX: 80 HEX: 04 HEX: 20 } [ BCTR ] test-assembler
+B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
+B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
+B{ HEX: 7c HEX: 69 HEX: 02 HEX: a6 } [ 3 MFCTR ] test-assembler
+B{ HEX: 7c HEX: 61 HEX: 03 HEX: a6 } [ 3 MTXER ] test-assembler
+B{ HEX: 7c HEX: 68 HEX: 03 HEX: a6 } [ 3 MTLR ] test-assembler
+B{ HEX: 7c HEX: 69 HEX: 03 HEX: a6 } [ 3 MTCTR ] test-assembler
+B{ HEX: 7c HEX: 61 HEX: 02 HEX: a6 } [ 3 MFXER ] test-assembler
+B{ HEX: 7c HEX: 68 HEX: 02 HEX: a6 } [ 3 MFLR ] test-assembler
+B{ HEX: c0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFS ] test-assembler
+B{ HEX: c4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFSU ] test-assembler
+B{ HEX: c8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFD ] test-assembler
+B{ HEX: cc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 LFDU ] test-assembler
+B{ HEX: d0 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFS ] test-assembler
+B{ HEX: d4 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFSU ] test-assembler
+B{ HEX: d8 HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFD ] test-assembler
+B{ HEX: dc HEX: 22 HEX: 00 HEX: 03 } [ 1 2 3 STFDU ] test-assembler
+B{ HEX: fc HEX: 20 HEX: 10 HEX: 48 } [ 1 2 FMR ] test-assembler
+B{ HEX: fc HEX: 20 HEX: 10 HEX: 1e } [ 1 2 FCTIWZ ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 2a } [ 1 2 3 FADD ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 2b } [ 1 2 3 FADD. ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 28 } [ 1 2 3 FSUB ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 00 HEX: f2 } [ 1 2 3 FMUL ] test-assembler
+B{ HEX: fc HEX: 22 HEX: 18 HEX: 24 } [ 1 2 3 FDIV ] test-assembler
+B{ HEX: fc HEX: 20 HEX: 10 HEX: 2c } [ 1 2 FSQRT ] test-assembler
+B{ HEX: fc HEX: 41 HEX: 18 HEX: 00 } [ 1 2 3 FCMPU ] test-assembler
+B{ HEX: fc HEX: 41 HEX: 18 HEX: 40 } [ 1 2 3 FCMPO ] test-assembler
+B{ HEX: 3c HEX: 60 HEX: 12 HEX: 34 HEX: 60 HEX: 63 HEX: 56 HEX: 78 } [ HEX: 12345678 3 LOAD ] test-assembler
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.codegen.fixup kernel namespaces words
-io.binary math math.order cpu.ppc.assembler.backend ;
+USING: kernel namespaces words io.binary math math.order
+cpu.ppc.assembler.backend ;
IN: cpu.ppc.assembler
! See the Motorola or IBM documentation for details. The opcode
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.codegen.fixup cpu.architecture
-compiler.constants kernel namespaces make sequences words math
-math.bitwise io.binary parser lexer ;
+USING: kernel namespaces make sequences words math
+math.bitwise io.binary parser lexer fry ;
IN: cpu.ppc.assembler.backend
-: insn ( operand opcode -- ) { 26 0 } bitfield , ;
+: insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ;
: a-insn ( d a b c xo rc opcode -- )
[ { 0 1 6 11 16 21 } bitfield ] dip insn ;
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
-M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
-M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ;
-M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
-M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
: CREATE-B ( -- word ) scan "B" prepend create-in ;
SYNTAX: BC:
CREATE-B scan-word scan-word
- [ rot BC ] 2curry (( c -- )) define-declared ;
+ '[ [ _ _ ] dip BC ] (( c -- )) define-declared ;
SYNTAX: B:
CREATE-B scan-word scan-word scan-word scan-word scan-word
- [ b-insn ] curry curry curry curry curry
- (( bo -- )) define-declared ;
+ '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
! 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
+CONSTANT: ds-reg 13\r
+CONSTANT: rs-reg 14\r
\r
: factor-area-size ( -- n ) 4 bootstrap-cells ;\r
\r
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;\r
\r
[\r
- 0 6 LOAD32\r
- 11 6 profile-count-offset LWZ\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
+ 11 3 profile-count-offset LWZ\r
11 11 1 tag-fixnum ADDI\r
- 11 6 profile-count-offset STW\r
- 11 6 word-code-offset LWZ\r
+ 11 3 profile-count-offset STW\r
+ 11 3 word-code-offset LWZ\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 3 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
+ 3 1 xt-save STW\r
+ stack-frame 3 LI\r
+ 3 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
-\r
-[\r
- 0 6 LOAD32\r
- 6 ds-reg 4 STWU\r
-] rc-absolute-ppc-2/2 rt-immediate 1 jit-push-immediate jit-define\r
+] jit-prolog jit-define\r
\r
[\r
- 0 6 LOAD32\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
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
+ 3 ds-reg 4 STWU\r
+] jit-push-immediate jit-define\r
\r
[\r
- 0 6 LOAD32\r
- 6 MTCTR\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel\r
+ 4 3 0 LWZ\r
+ 1 4 0 STW\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel\r
+ 3 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-pic jit-rel ] jit-word-call jit-define\r
\r
-[ 0 BL ] rc-relative-ppc-3 rt-xt 0 jit-word-call jit-define\r
+[\r
+ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel\r
+ 0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel\r
+] jit-word-jump 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-special 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
-\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
+ 0 B rc-relative-ppc-3 rt-xt jit-rel\r
+] jit-if 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
+: prepare-(execute) ( -- operand )\r
+ 3 ds-reg 0 LWZ\r
+ ds-reg dup 4 SUBI\r
+ 4 3 word-xt-offset LWZ\r
+ 4 ;\r
+\r
+[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define\r
+\r
+[ prepare-(execute) MTLR BLRL ] jit-execute-call 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
+! ! ! Polymorphic inline caches\r
\r
-! Quotations and words\r
+! Don't touch r6 here; it's used to pass the tail call site\r
+! address for tail PICs\r
+\r
+! Load a value from a stack position\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 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel\r
+] pic-load jit-define\r
+\r
+! Tag\r
+: load-tag ( -- )\r
+ 4 4 tag-mask get ANDI\r
+ 4 4 tag-bits get SLWI ;\r
+\r
+[ load-tag ] pic-tag jit-define\r
+\r
+! Hi-tag\r
+[\r
+ 3 4 MR\r
+ load-tag\r
+ 0 4 object tag-number tag-fixnum CMPI\r
+ 2 BNE\r
+ 4 3 object tag-number neg LWZ\r
+] pic-hi-tag jit-define\r
\r
+! Tuple\r
+[\r
+ 3 4 MR\r
+ load-tag\r
+ 0 4 tuple tag-number tag-fixnum CMPI\r
+ 2 BNE\r
+ 4 3 tuple tag-number neg bootstrap-cell + LWZ\r
+] pic-tuple jit-define\r
+\r
+! Hi-tag and tuple\r
+[\r
+ 3 4 MR\r
+ load-tag\r
+ ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)\r
+ 0 4 BIN: 110 tag-fixnum CMPI\r
+ 5 BLT\r
+ ! Untag r3\r
+ 3 3 0 0 31 tag-bits get - RLWINM\r
+ ! Set r4 to 0 for objects, and bootstrap-cell for tuples\r
+ 4 4 1 tag-fixnum ANDI\r
+ 4 4 1 SRAWI\r
+ ! Load header cell or tuple layout cell\r
+ 4 4 3 LWZX\r
+] pic-hi-tag-tuple jit-define\r
+\r
+[\r
+ 0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel\r
+] pic-check-tag jit-define\r
+\r
+[\r
+ 0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
+ 4 0 5 CMP\r
+] pic-check jit-define\r
+\r
+[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define\r
+\r
+! ! ! Megamorphic caches\r
+\r
+[\r
+ ! cache = ...\r
+ 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel\r
+ ! key = class\r
+ 5 4 MR\r
+ ! key &= cache.length - 1\r
+ 5 5 mega-cache-size get 1- bootstrap-cell * ANDI\r
+ ! cache += array-start-offset\r
+ 3 3 array-start-offset ADDI\r
+ ! cache += key\r
+ 3 3 5 ADD\r
+ ! if(get(cache) == class)\r
+ 6 3 0 LWZ\r
+ 6 0 4 CMP\r
+ 10 BNE\r
+ ! megamorphic_cache_hits++\r
+ 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel\r
+ 5 4 0 LWZ\r
+ 5 5 1 ADDI\r
+ 5 4 0 STW\r
+ ! ... goto get(cache + bootstrap-cell)\r
+ 3 3 4 LWZ\r
+ 3 3 word-xt-offset LWZ\r
+ 3 MTCTR\r
+ BCTR\r
+ ! fall-through on miss\r
+] mega-lookup jit-define\r
+\r
+! ! ! Sub-primitives\r
+\r
+! Quotations and words\r
[\r
3 ds-reg 0 LWZ\r
ds-reg dup 4 SUBI\r
- 4 3 word-xt-offset LWZ\r
+ 4 3 quot-xt-offset LWZ\r
4 MTCTR\r
BCTR\r
-] f f f \ (execute) define-sub-primitive\r
+] \ (call) 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
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
[ 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
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
-alien alien.c-types cpu.architecture cpu.ppc.assembler
-compiler.cfg.registers compiler.cfg.instructions
-compiler.constants compiler.codegen compiler.codegen.fixup
-compiler.cfg.intrinsics compiler.cfg.stack-frame ;
+alien alien.c-types literals cpu.architecture cpu.ppc.assembler
+cpu.ppc.assembler.backend literals compiler.cfg.registers
+compiler.cfg.instructions compiler.constants compiler.codegen
+compiler.codegen.fixup compiler.cfg.intrinsics
+compiler.cfg.stack-frame ;
IN: cpu.ppc
! PowerPC register assignments:
-! r2-r27: integer vregs
-! r28: integer scratch
-! r29: data stack
-! r30: retain stack
+! r2-r12: integer vregs
+! r15-r29
+! r30: integer scratch
! f0-f29: float vregs
-! f30, f31: float scratch
+! f30: float scratch
+
+! Add some methods to the assembler that are useful to us
+M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
+M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
enable-float-intrinsics
-<< \ ##integer>float t frame-required? set-word-prop
-\ ##float>integer t frame-required? set-word-prop >>
+<<
+\ ##integer>float t frame-required? set-word-prop
+\ ##float>integer t frame-required? set-word-prop
+>>
M: ppc machine-registers
{
- { int-regs T{ range f 2 26 1 } }
- { double-float-regs T{ range f 0 29 1 } }
+ { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
+ { double-float-regs $[ 0 29 [a,b] ] }
} ;
-CONSTANT: scratch-reg 28
+CONSTANT: scratch-reg 30
CONSTANT: fp-scratch-reg 30
M: ppc two-operand? f ;
M: ppc %alien-global ( register symbol dll -- )
[ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
-CONSTANT: ds-reg 29
-CONSTANT: rs-reg 30
+CONSTANT: ds-reg 13
+CONSTANT: rs-reg 14
GENERIC: loc-reg ( loc -- reg )
factor-area-size +
4 cells align ;
-M: ppc %call ( label -- ) BL ;
+M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ;
+
+M: ppc %jump ( word -- )
+ 0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here
+ 0 B rc-relative-ppc-3 rel-word-pic-tail ;
+
M: ppc %jump-label ( label -- ) B ;
M: ppc %return ( -- ) BLR ;
BCTR ;
M: ppc %dispatch-label ( word -- )
- 0 , rc-absolute-cell rel-word ;
+ B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
:: (%slot) ( obj slot tag temp -- reg offset )
temp slot obj ADD
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
- 13 3 MR ;
+ 15 3 MR ;
M: ppc %alien-indirect ( -- )
- 13 MTLR BLRL ;
+ 15 MTLR BLRL ;
M: ppc %callback-value ( ctype -- )
! Save top of data stack
} cond
"complex-double" c-type t >>return-in-registers? drop
+"bool" c-type 4 >>size 4 >>align drop
\ No newline at end of file
M: x86.32 param-reg-1 EAX ;
M: x86.32 param-reg-2 EDX ;
+M: x86.32 pic-tail-reg EBX ;
+
M: x86.32 reserved-area-size 0 ;
-M: x86.32 %alien-invoke (CALL) rel-dlsym ;
+M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
-M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
+M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
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? [
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants ;
: 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
-
-[
- (JMP) drop
-] rc-relative rt-primitive 1 jit-primitive jit-define
+ ! load stack_chain
+ temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
+ ! save stack pointer
+ temp0 [] stack-reg MOV
+ ! call the primitive
+ 0 JMP rc-relative rt-primitive jit-rel
+] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>
call
M: x86.64 param-reg-2 int-regs param-regs second ;
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
+M: x86.64 pic-tail-reg RBX ;
+
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system
cpu.x86.assembler layouts vocabs parser compiler.constants math ;
: 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
-
-[
- temp1 0 MOV ! load XT
- temp1 JMP ! go
-] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
+ ! save stack pointer
+ temp0 [] stack-reg MOV
+ ! 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
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays cpu.architecture compiler.constants
-compiler.codegen.fixup io.binary kernel combinators
-kernel.private math namespaces make sequences words system
-layouts math.order accessors cpu.x86.assembler.syntax ;
+USING: arrays io.binary kernel combinators
+kernel.private math namespaces make sequences words system layouts
+math.order accessors cpu.x86.assembler.syntax ;
IN: cpu.x86.assembler
-! A postfix assembler for x86 and AMD64.
+! A postfix assembler for x86-32 and x86-64.
! In 32-bit mode, { 1234 } is absolute indirect addressing.
! In 64-bit mode, { 1234 } is RIP-relative.
{ BIN: 000 t HEX: c6 }
pick byte? [ immediate-1 ] [ immediate-4 ] if ;
-PREDICATE: callable < word register? not ;
-
GENERIC: MOV ( dst src -- )
M: immediate MOV swap (MOV-I) ;
-M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ;
M: operand MOV HEX: 88 2-operand ;
: LEA ( dst src -- ) swap HEX: 8d 2-operand ;
! Control flow
GENERIC: JMP ( op -- )
-: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ;
-M: f JMP (JMP) 2drop ;
-M: callable JMP (JMP) rel-word ;
-M: label JMP (JMP) label-fixup ;
+M: integer JMP HEX: e9 , 4, ;
M: operand JMP { BIN: 100 t HEX: ff } 1-operand ;
GENERIC: CALL ( op -- )
-: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ;
-M: f CALL (CALL) 2drop ;
-M: callable CALL (CALL) rel-word ;
-M: label CALL (CALL) label-fixup ;
+M: integer CALL HEX: e8 , 4, ;
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 ;
+M: integer JUMPcc extended-opcode, 4, ;
: 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
+
+[
+ temp3 0 MOV rc-absolute-cell rt-here jit-rel
+ 0 JMP rc-relative rt-xt-pic-tail jit-rel
+] jit-word-jump jit-define
[
- f JMP
-] rc-relative rt-xt 1 jit-word-jump jit-define
+ 0 CALL rc-relative rt-xt-pic jit-rel
+] jit-word-call jit-define
[
- f CALL
-] rc-relative rt-xt 1 jit-word-call jit-define
+ 0 JMP rc-relative rt-xt jit-rel
+] jit-word-special 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
-
-[
+ 0 JNE rc-relative rt-xt jit-rel
! 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
+ 0 JMP rc-relative rt-xt jit-rel
+] jit-if jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
[
jit->r
- f CALL
+ 0 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
+ 0 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
+ 0 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
+
+! ! ! Polymorphic inline caches
+
+! The PIC and megamorphic code stubs are not permitted to touch temp3.
+
+! 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 ;
-[ 0 RET ] f f f jit-return jit-define
+[ load-tag ] pic-tag jit-define
-! Sub-primitives
+! 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 bootstrap-cell 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
+
+[ 0 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
+ bootstrap-cell 4 = 14 22 ? JNE ! Yuck!
+ ! megamorphic_cache_hits++
+ temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel
+ temp1 [] 1 ADD
+ ! goto get(cache + bootstrap-cell)
+ temp0 temp0 bootstrap-cell [+] MOV
+ temp0 word-xt-offset [+] JMP
+ ! 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
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
! compute result
[ 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
<< enable-fixnum-log2 >>
+! Add some methods to the assembler to be more useful to the backend
+M: label JMP 0 JMP rc-relative label-fixup ;
+M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ;
+
M: x86 two-operand? t ;
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: param-reg-1 cpu ( -- reg )
HOOK: param-reg-2 cpu ( -- reg )
+HOOK: pic-tail-reg cpu ( -- reg )
+
M: x86 %load-immediate MOV ;
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
reserved-area-size +
align-stack ;
-M: x86 %call ( label -- ) CALL ;
-M: x86 %jump-label ( label -- ) JMP ;
+M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
+
+: xt-tail-pic-offset ( -- n )
+ #! See the comment in vm/cpu-x86.hpp
+ cell 4 + 1 + ; inline
+
+M: x86 %jump ( word -- )
+ pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
+ 0 JMP rc-relative rel-word-pic-tail ;
+
+M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
+
M: x86 %return ( -- ) 0 RET ;
: code-alignment ( align -- n )
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
! 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
+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-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
"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 ;
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
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
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser lexer kernel namespaces sequences definitions io.files
-io.backend io.pathnames io summary continuations tools.crossref
-tools.vocabs prettyprint source-files source-files.errors assocs
-vocabs vocabs.loader splitting accessors debugger prettyprint
-help.topics ;
+USING: parser lexer kernel namespaces sequences definitions
+io.files io.backend io.pathnames io summary continuations
+tools.crossref vocabs.hierarchy prettyprint source-files
+source-files.errors assocs vocabs vocabs.loader splitting
+accessors debugger prettyprint help.topics ;
IN: editors
TUPLE: no-edit-hook ;
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 ] ;
-
-
: list ( url -- ftp-response )
utf8 open-passive-client
ftp-list
- lines
+ stream-lines
<ftp-response> swap >>strings
read-response 226 ftp-assert
parse-list ;
[ 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 ( -- )
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 -- )
-! 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
{ $heading "Workflow" }
{ $subsection "listener" }
{ $subsection "editor" }
-{ $subsection "tools.vocabs" }
+{ $subsection "vocabs.refresh" }
{ $subsection "tools.test" }
{ $subsection "help" }
{ $heading "Debugging" }
{ $heading "Browsing" }
{ $subsection "see" }
{ $subsection "tools.crossref" }
+{ $subsection "vocabs.hierarchy" }
{ $heading "Performance" }
{ $subsection "timing" }
{ $subsection "profiling" }
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs
-tools.vocabs help.vocabs namespaces prettyprint io
+vocabs.hierarchy help.vocabs namespaces prettyprint io
vocabs.loader serialize fry memoize ascii unicode.case math.order
sorting debugger html xml.syntax xml.writer math.parser ;
IN: help.html
! See http://factorcode.org/license.txt for BSD license.
USING: assocs continuations fry help help.lint.checks
help.topics io kernel namespaces parser sequences
-source-files.errors tools.vocabs vocabs words classes
+source-files.errors vocabs.hierarchy vocabs words classes
locals tools.errors ;
FROM: help.lint.checks => all-vocabs ;
IN: help.lint
: help-lint-all ( -- ) "" help-lint ;
-: :lint-failures ( -- ) lint-failures get errors. ;
+: :lint-failures ( -- ) lint-failures get values errors. ;
: unlinked-words ( words -- seq )
all-word-help [ article-parent not ] filter ;
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
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
-math.parser generic generic.standard generic.standard.engines classes
+math.parser generic generic.single generic.standard classes
hashtables namespaces ;
IN: hints
t specialize-method? set-global
+: method-declaration ( method -- quot )
+ [ "method-generic" word-prop dispatch# object <array> ]
+ [ "method-class" word-prop ]
+ bi prefix [ declare ] curry [ ] like ;
+
: specialize-method ( quot method -- quot' )
- [
- specialize-method? get [
- [ "method-class" word-prop ] [ "method-generic" word-prop ] bi
- method-declaration prepend
- ] [ drop ] if
- ]
+ [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
[ "method-generic" word-prop "specializer" word-prop ] bi
[ specialize-quot ] when* ;
SYNTAX: HINTS:
scan-object
[ changed-definition ]
- [ parse-definition "specializer" set-word-prop ] bi ;
+ [ parse-definition { } like "specializer" set-word-prop ] bi ;
! Default specializers
{ first first2 first3 first4 }
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:"
--- /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: 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
-! 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
io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
-strings math.vectors specialized-arrays.float ;
+strings math.vectors specialized-arrays.float locals ;
IN: images.tiff
TUPLE: tiff-image < image ;
software date-time photoshop exif-ifd sub-ifd inter-color-profile
xmp iptc fill-order document-name page-number page-name
x-position y-position host-computer copyright artist
-min-sample-value max-sample-value make model cell-width cell-length
+min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length
gray-response-unit gray-response-curve color-map threshholding
image-description free-offsets free-byte-counts tile-width tile-length
matteing data-type image-depth tile-depth
ERROR: no-tag class ;
-: find-tag ( idf class -- tag )
- swap processed-tags>> ?at [ no-tag ] unless ;
+: find-tag* ( ifd class -- tag/class ? )
+ swap processed-tags>> ?at ;
-: tag? ( idf class -- tag )
+: find-tag ( ifd class -- tag )
+ find-tag* [ no-tag ] unless ;
+
+: tag? ( ifd class -- tag )
swap processed-tags>> key? ;
: read-strips ( ifd -- ifd )
{ 266 [ fill-order ] }
{ 269 [ ascii decode document-name ] }
{ 270 [ ascii decode image-description ] }
- { 271 [ ascii decode make ] }
- { 272 [ ascii decode model ] }
+ { 271 [ ascii decode tiff-make ] }
+ { 272 [ ascii decode tiff-model ] }
{ 273 [ strip-offsets ] }
{ 274 [ orientation ] }
{ 277 [ samples-per-pixel ] }
{ 281 [ max-sample-value ] }
{ 282 [ first x-resolution ] }
{ 283 [ first y-resolution ] }
- { 284 [ planar-configuration ] }
+ { 284 [ lookup-planar-configuration planar-configuration ] }
{ 285 [ page-name ] }
{ 286 [ x-position ] }
{ 287 [ y-position ] }
[ samples-per-pixel find-tag ] tri
[ * ] keep
'[
- _ group [ _ group [ rest ] [ first ] bi
- [ v+ ] accumulate swap suffix concat ] map
+ _ group
+ [ _ group unclip [ v+ ] accumulate swap suffix concat ] map
concat >byte-array
] change-bitmap ;
] with-tiff-endianness
] with-file-reader ;
-: process-tif-ifds ( parsed-tiff -- parsed-tiff )
- dup ifds>> [
- read-strips
- uncompress-strips
- strips>bitmap
- fix-bitmap-endianness
- strips-predictor
- dup extra-samples tag? [ handle-alpha-data ] when
- drop
- ] each ;
+: process-chunky-ifd ( ifd -- )
+ read-strips
+ uncompress-strips
+ strips>bitmap
+ fix-bitmap-endianness
+ strips-predictor
+ dup extra-samples tag? [ handle-alpha-data ] when
+ drop ;
+
+: process-planar-ifd ( ifd -- )
+ "planar ifd not supported" throw ;
+
+: dispatch-planar-configuration ( ifd planar-configuration -- )
+ {
+ { planar-configuration-chunky [ process-chunky-ifd ] }
+ { planar-configuration-planar [ process-planar-ifd ] }
+ } case ;
+
+: process-ifd ( ifd -- )
+ dup planar-configuration find-tag* [
+ dispatch-planar-configuration
+ ] [
+ drop "no planar configuration" throw
+ ] if ;
+
+: process-tif-ifds ( parsed-tiff -- )
+ ifds>> [ process-ifd ] each ;
: load-tiff ( path -- parsed-tiff )
- [ load-tiff-ifds ] [
- binary [
- [ process-tif-ifds ] with-tiff-endianness
- ] with-file-reader
- ] bi ;
+ [ load-tiff-ifds dup ] keep
+ binary [
+ [ process-tif-ifds ] with-tiff-endianness
+ ] with-file-reader ;
! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image )
+! 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
: <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ;
: funny-tuple ( -- ) "OOPS" throw ;
-[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
\ No newline at end of file
+[ ] [ [ <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
\ 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 ;
] 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
--- /dev/null
+IN: io.backend.windows.privileges.tests\r
+USING: io.backend.windows.privileges tools.test ;\r
+\r
+[ [ ] with-privileges ] must-infer\r
USING: io.backend kernel continuations sequences\r
-system vocabs.loader combinators ;\r
+system vocabs.loader combinators fry ;\r
IN: io.backend.windows.privileges\r
\r
-HOOK: set-privilege io-backend ( name ? -- ) inline\r
+HOOK: set-privilege io-backend ( name ? -- )\r
\r
: with-privileges ( seq quot -- )\r
- over [ [ t set-privilege ] each ] curry compose\r
- swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline\r
+ [ '[ _ [ t set-privilege ] each @ ] ]\r
+ [ drop '[ _ [ f set-privilege ] each ] ]\r
+ 2bi [ ] cleanup ; inline\r
\r
{\r
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }\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 ;
! 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 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 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> ;
{ $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 ;
: random-name ( -- string )
unique-length get [ random-ch ] "" replicate-as ;
+: retry ( quot: ( -- ? ) n -- )
+ swap [ drop ] prepose attempt-all ; inline
+
: (make-unique-file) ( path prefix suffix -- path )
'[
_ _ _ random-name glue append-path
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 windows.shell32 ;
+namespaces make accessors tr windows.time windows.shell32
+windows.errors ;
IN: io.files.windows.nt
M: winnt cwd
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 ;
"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
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
- ascii [ input-stream get contents ] with-process-reader
+ ascii [ contents ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
<process>
console-vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr
- ascii <process-reader> lines first
+ ascii <process-reader> stream-lines first
] with-directory
] unit-test
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
console-vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode
os-envs >>environment
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
<process>
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"A" swap at
console-vm "-script" "env.factor" 3array >>command
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
- ascii <process-reader> contents
+ ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
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
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
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
: 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
+++ /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> 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
+++ /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
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 ;
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> ;
! 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
SYMBOL: error-summary?
+t error-summary? set-global
+
<PRIVATE
: title. ( string -- )
--- /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 }" }
+
+} ;
+
+HELP: ${
+{ $syntax "${ code }" }
+{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." }
+{ $notes { $snippet "code" } "'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 math prettyprint ;
+IN: scratchpad
+
+CONSTANT: five 5
+CONSTANT: six 6
+${ five six 7 } .
+ "> "{ 5 6 7 }"
+ }
+} ;
+
+{ POSTPONE: $ 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: $[ }
+{ $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
+
+: sixty-nine ( -- a b ) 6 9 ;
+
+[ { 6 9 } ] [ ${ sixty-nine } ] unit-test
--- /dev/null
+! (c) Joe Groff, see license for details
+USING: accessors continuations kernel parser words quotations
+combinators.smart vectors sequences fry ;
+IN: literals
+
+<PRIVATE
+
+! Use def>> call so that CONSTANT:s defined in the same file can
+! be called
+
+: expand-literal ( seq obj -- seq' )
+ '[ _ dup word? [ def>> call ] when ] with-datastack ;
+
+: expand-literals ( seq -- seq' )
+ [ [ { } ] dip expand-literal ] map concat ;
+
+PRIVATE>
+
+SYNTAX: $ scan-word expand-literal >vector ;
+SYNTAX: $[ parse-quotation with-datastack >vector ;
+SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
--- /dev/null
+Expression interpolation into sequence literals
--- /dev/null
+extensions
+syntax
:: ed's-test-case ( a -- b )
{ [ a ed's-bug ] } && ;
-[ t ] [ \ ed's-test-case optimized>> ] unit-test
+[ 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"
C: <bits> bits
: make-bits ( number -- bits )
- dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
+ dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
M: bits length length>> ;
: unmask? ( x n -- ? ) unmask 0 > ; inline
: mask ( x n -- ? ) bitand ; inline
: mask? ( x n -- ? ) mask 0 > ; inline
-: wrap ( m n -- m' ) 1- bitand ; inline
+: wrap ( m n -- m' ) 1 - bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 2^ mask ; inline
-: on-bits ( n -- m ) 2^ 1- ; inline
+: on-bits ( n -- m ) 2^ 1 - ; inline
: toggle-bit ( m n -- m' ) 2^ bitxor ; inline
: shift-mod ( n s w -- n )
<<
\ byte-bit-count
-256 [
- 8 <bits> 0 [ [ 1+ ] when ] reduce
+256 iota [
+ 8 <bits> 0 [ [ 1 + ] when ] reduce
] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
(( byte -- table )) define-declared
! Signed byte array to integer conversion
: signed-le> ( bytes -- x )
- [ le> ] [ length 8 * 1- on-bits ] bi
+ [ le> ] [ length 8 * 1 - on-bits ] bi
2dup > [ bitnot bitor ] [ drop ] if ;
: signed-be> ( bytes -- x )
<reversed> signed-le> ;
: >signed ( x n -- y )
- 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
+ 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
M: VECTOR Vswap
(prepare-swap) [ XSWAP ] 2dip ;
M: VECTOR Viamax
- (prepare-nrm2) IXAMAX 1- ;
+ (prepare-nrm2) IXAMAX 1 - ;
M: VECTOR (blas-vector-like)
drop <VECTOR> ;
{ $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/ ;
: euler ( -- gamma ) 0.57721566490153286060 ; inline
: phi ( -- phi ) 1.61803398874989484820 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
+: 2pi ( -- pi ) 2 pi * ; inline
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
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" } "." } ;
2135623355842621559
[ >bignum ] tri@ ^mod
] unit-test
+
+[ 1.0 ] [ 1.0 2.5 0.0 lerp ] unit-test
+[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test
+[ 1.75 ] [ 1.0 2.5 0.5 lerp ] 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
: factor-2s ( n -- r s )
#! factor an integer into 2^r * s
dup 0 = [ 1 ] [
- 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while
+ 0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
] if ; inline
<PRIVATE
-GENERIC# ^n 1 ( z w -- z^w )
+GENERIC# ^n 1 ( z w -- z^w ) foldable
: (^n) ( z w -- z^w )
make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
: coth ( x -- y ) tanh recip ; inline
: acosh ( x -- y )
- dup sq 1- sqrt + log ; inline
+ dup sq 1 - sqrt + log ; inline
: asech ( x -- y ) recip acosh ; inline
: asinh ( x -- y )
- dup sq 1+ sqrt + log ; inline
+ dup sq 1 + sqrt + log ; inline
: acosech ( x -- y ) recip asinh ; inline
: atanh ( x -- y )
- [ 1+ ] [ 1- neg ] bi / log 2 / ; inline
+ [ 1 + ] [ 1 - neg ] bi / log 2 / ; inline
: acoth ( x -- y ) recip atanh ; inline
: floor ( x -- y )
dup 1 mod dup zero?
- [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
+ [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
: ceiling ( x -- y ) neg floor neg ; foldable
+
+: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
+
: (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
+: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+
: [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? )
: interval-abs ( i1 -- i2 )
{
{ [ dup empty-interval eq? ] [ ] }
- { [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
+ { [ dup full-interval eq? ] [ drop [0,inf] ] }
{ [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
[ (interval-abs) points>interval ]
} cond ;
: interval-log2 ( i1 -- i2 )
{
{ empty-interval [ empty-interval ] }
- { full-interval [ 0 [a,inf] ] }
+ { full-interval [ [0,inf] ] }
[
to>> first 1 max dup most-positive-fixnum >
[ drop full-interval interval-log2 ]
- [ 1+ >integer log2 0 swap [a,b] ]
+ [ 1 + >integer log2 0 swap [a,b] ]
if
]
} case ;
: integral-closure ( i1 -- i2 )
dup special-interval? [
- [ from>> first2 [ 1+ ] unless ]
- [ to>> first2 [ 1- ] unless ]
+ [ from>> first2 [ 1 + ] unless ]
+ [ to>> first2 [ 1 - ] unless ]
bi [a,b]
] unless ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel sequences math ;
+IN: math.miller-rabin
+
+HELP: find-relative-prime
+{ $values
+ { "n" integer }
+ { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
+
+HELP: find-relative-prime*
+{ $values
+ { "n" integer } { "guess" integer }
+ { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
+
+HELP: miller-rabin
+{ $values
+ { "n" integer }
+ { "?" "a boolean" }
+}
+{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ;
+
+{ miller-rabin miller-rabin* } related-words
+
+HELP: miller-rabin*
+{ $values
+ { "n" integer } { "numtrials" integer }
+ { "?" "a boolean" }
+}
+{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
+
+HELP: next-prime
+{ $values
+ { "n" integer }
+ { "p" integer }
+}
+{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ;
+
+HELP: next-safe-prime
+{ $values
+ { "n" integer }
+ { "q" integer }
+}
+{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
+
+HELP: random-bits*
+{ $values
+ { "numbits" integer }
+ { "n" integer }
+}
+{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
+
+HELP: random-prime
+{ $values
+ { "numbits" integer }
+ { "p" integer }
+}
+{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: random-safe-prime
+{ $values
+ { "numbits" integer }
+ { "p" integer }
+}
+{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: safe-prime?
+{ $values
+ { "q" integer }
+ { "?" "a boolean" }
+}
+{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
+
+HELP: unique-primes
+{ $values
+ { "numbits" integer } { "n" integer }
+ { "seq" sequence }
+}
+{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
+
+ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
+"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
+"The Miller-Rabin probabilistic primality test:"
+{ $subsection miller-rabin }
+{ $subsection miller-rabin* }
+"Generating relative prime numbers:"
+{ $subsection find-relative-prime }
+{ $subsection find-relative-prime* }
+"Generating prime numbers:"
+{ $subsection next-prime }
+{ $subsection random-prime }
+"Generating safe prime numbers:"
+{ $subsection next-safe-prime }
+{ $subsection random-safe-prime } ;
+
+ABOUT: "math.miller-rabin"
-USING: math.miller-rabin tools.test ;
+USING: math.miller-rabin tools.test kernel sequences
+math.miller-rabin.private math ;
IN: math.miller-rabin.tests
[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
[ t ] [ 3 miller-rabin ] unit-test
[ f ] [ 36 miller-rabin ] unit-test
[ t ] [ 37 miller-rabin ] unit-test
+[ 2 ] [ 1 next-prime ] unit-test
+[ 3 ] [ 2 next-prime ] unit-test
+[ 5 ] [ 3 next-prime ] unit-test
[ 101 ] [ 100 next-prime ] unit-test
[ t ] [ 2135623355842621559 miller-rabin ] unit-test
-[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
\ No newline at end of file
+[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
+
+[ 863 ] [ 862 next-safe-prime ] unit-test
+[ f ] [ 862 safe-prime? ] unit-test
+[ t ] [ 7 safe-prime? ] unit-test
+[ f ] [ 31 safe-prime? ] unit-test
+[ t ] [ 47 safe-prime-candidate? ] unit-test
+[ t ] [ 47 safe-prime? ] unit-test
+[ t ] [ 863 safe-prime? ] unit-test
+
+[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
+
+[ 47 ] [ 31 next-safe-prime ] unit-test
+[ 49 ] [ 50 random-prime log2 ] unit-test
+[ 49 ] [ 50 random-bits* log2 ] unit-test
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel locals math math.functions math.ranges
-random sequences sets ;
+random sequences sets combinators.short-circuit math.bitwise
+math math.order ;
IN: math.miller-rabin
-<PRIVATE
+: >odd ( n -- int ) 0 set-bit ; foldable
+
+: >even ( n -- int ) 0 clear-bit ; foldable
-: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable
+: next-even ( m -- n ) >even 2 + ;
-TUPLE: positive-even-expected n ;
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
+
+<PRIVATE
:: (miller-rabin) ( n trials -- ? )
- [let | r [ n 1- factor-2s drop ]
- s [ n 1- factor-2s nip ]
- prime?! [ t ]
- a! [ 0 ]
- count! [ 0 ] |
- trials [
- n 1- [1,b] random a!
- a s n ^mod 1 = [
- 0 count!
- r [
- 2^ s * a swap n ^mod n - -1 =
- [ count 1+ count! r + ] when
- ] each
- count zero? [ f prime?! trials + ] when
- ] unless drop
- ] each prime? ] ;
+ n 1 - :> n-1
+ n-1 factor-2s :> s :> r
+ 0 :> a!
+ trials [
+ drop
+ 2 n 2 - [a,b] random a!
+ a s n ^mod 1 = [
+ f
+ ] [
+ r iota [
+ 2^ s * a swap n ^mod n - -1 =
+ ] any? not
+ ] if
+ ] any? not ;
PRIVATE>
-: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ;
-
: miller-rabin* ( n numtrials -- ? )
over {
{ [ dup 1 <= ] [ 3drop f ] }
: miller-rabin ( n -- ? ) 10 miller-rabin* ;
+ERROR: prime-range-error n ;
+
: next-prime ( n -- p )
- next-odd dup miller-rabin [ next-prime ] unless ;
+ dup 1 < [ prime-range-error ] when
+ dup 1 = [
+ drop 2
+ ] [
+ next-odd dup miller-rabin [ next-prime ] unless
+ ] if ;
+
+: random-bits* ( numbits -- n )
+ 1 - [ random-bits ] keep set-bit ;
: random-prime ( numbits -- p )
- random-bits next-prime ;
+ random-bits* next-prime ;
ERROR: no-relative-prime n ;
dup 5 < [ too-few-primes ] when
2dup [ random-prime ] curry replicate
dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
+
+! Safe primes are of the form p = 2q + 1, p,q are prime
+! See http://en.wikipedia.org/wiki/Safe_prime
+
+<PRIVATE
+
+: safe-prime-candidate? ( n -- ? )
+ 1 + 6 divisor? ;
+
+: next-safe-prime-candidate ( n -- candidate )
+ next-prime dup safe-prime-candidate?
+ [ next-safe-prime-candidate ] unless ;
+
+PRIVATE>
+
+: safe-prime? ( q -- ? )
+ {
+ [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ]
+ [ miller-rabin ]
+ } 1&& ;
+
+: next-safe-prime ( n -- q )
+ next-safe-prime-candidate
+ dup safe-prime? [ next-safe-prime ] unless ;
+
+: random-safe-prime ( numbits -- p )
+ random-bits* next-safe-prime ;
PRIVATE>
: powers ( n x -- seq )
- <array> 1 [ * ] accumulate nip ;
+ <repetition> 1 [ * ] accumulate nip ;
: p= ( p q -- ? ) pextend = ;
: n*p ( n p -- n*p ) n*v ;
: pextend-conv ( p q -- p q )
- 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ;
+ 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ;
: p* ( p q -- r )
2unempty pextend-conv <reversed> dup length
2ptrim
2dup [ length ] bi@ -
dup 1 < [ drop 1 ] when
- [ over length + 0 pad-head pextend ] keep 1+ ;
+ [ over length + 0 pad-head pextend ] keep 1 + ;
: /-last ( seq seq -- a )
#! divide the last two numbers in the sequences
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 ;
{ step read-only } ;
: <range> ( a b step -- range )
- [ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline
+ [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline
M: range length ( seq -- n )
length>> ;
{ $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
: median ( seq -- n )
natural-sort dup length even? [
- [ midpoint@ dup 1- 2array ] keep nths mean
+ [ midpoint@ dup 1 - 2array ] keep nths mean
] [
[ midpoint@ ] keep nth
] if ;
drop 0
] [
[ [ mean ] keep [ - sq ] with sigma ] keep
- length 1- /
+ length 1 - /
] if ;
: std ( seq -- x )
0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ;
: (r) ( mean(x) mean(y) {x} {y} sx sy -- r )
- * recip [ [ ((r)) ] keep length 1- / ] dip * ;
+ * recip [ [ ((r)) ] keep length 1 - / ] dip * ;
: [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy )
first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ;
[ 5 ] [ { 1 2 } norm-sq ] unit-test
[ 13 ] [ { 2 3 } norm-sq ] unit-test
+[ { 1.0 2.5 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test
+[ { 2.5 1.0 } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test
+[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test
+
+[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
: vneg ( u -- v ) [ neg ] map ;
+: v+n ( u n -- v ) [ + ] curry map ;
+: n+v ( n u -- v ) [ + ] with map ;
+: v-n ( u n -- v ) [ - ] curry map ;
+: n-v ( n u -- v ) [ - ] with map ;
+
: v*n ( u n -- v ) [ * ] curry map ;
: n*v ( n u -- v ) [ * ] with map ;
: v/n ( u n -- v ) [ / ] curry map ;
: vmax ( u v -- w ) [ max ] 2map ;
: vmin ( u v -- w ) [ min ] 2map ;
+: vfloor ( v -- _v_ ) [ floor ] map ;
+: vceiling ( v -- ^v^ ) [ ceiling ] map ;
+: vtruncate ( v -- -v- ) [ truncate ] map ;
+
: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ;
: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ;
: set-axis ( u v axis -- w )
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
+: vlerp ( a b t -- a_t )
+ [ lerp ] 3map ;
+
+: vnlerp ( a b t -- a_t )
+ [ lerp ] curry 2map ;
+
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;
HINTS: norm { array } ;
HINTS: vmax { array array } ;
HINTS: vmin { array array } ;
HINTS: v. { array array } ;
+
+HINTS: vlerp { array array array } ;
+HINTS: vnlerp { array array object } ;
-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
: 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
GENERIC: draw-scaled-texture ( dim texture -- )
+DEFER: make-texture
+
<PRIVATE
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
[ 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
- 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_NEAREST glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
PRIVATE>
+: 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
+ non-power-of-2-textures? get
+ [ dup bitmap>> (tex-image) ]
+ [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
+ ] do-attribs
+ ] keep ;
+
: <texture> ( image loc -- texture )
over dim>> max-texture-size [ <= ] 2all?
[ <single-texture> ]
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
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 ;
[ 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 ;
USING: alien.c-types kernel math namespaces sequences
io.backend io.binary combinators system vocabs.loader
summary math.bitwise byte-vectors fry byte-arrays
-math.ranges ;
+math.ranges math.constants math.functions accessors ;
IN: random
SYMBOL: system-random-generator
: 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 )
: with-secure-random ( quot -- )
secure-random-generator get swap with-random ; inline
+: uniform-random-float ( min max -- n )
+ 4 random-bytes underlying>> *uint >float
+ 4 random-bytes underlying>> *uint >float
+ 2.0 32 ^ * +
+ [ over - 2.0 -64 ^ * ] dip
+ * + ; inline
+
+: normal-random-float ( mean sigma -- n )
+ 0.0 1.0 uniform-random-float
+ 0.0 1.0 uniform-random-float
+ [ 2 pi * * cos ]
+ [ 1.0 swap - log -2.0 * sqrt ]
+ bi* * * + ;
+
USE: vocabs.loader
{
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 ;
! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: boxes help.markup help.syntax kernel math namespaces ;
+USING: boxes help.markup help.syntax kernel math namespaces assocs ;
IN: refs
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 the " { $link "refs-protocol" } "."
-{ $subsection get-ref }
-{ $subsection set-ref }
-{ $subsection set-ref* }
-{ $subsection delete-ref }
+"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> }
{ $subsection slot-ref }
{ $subsection <slot-ref> }
"Using boxes as references:"
-{ $subsection "box-refs" }
-"References are used by the UI inspector." ;
+{ $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"
+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" "Using Boxes as References"
-"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." ;
+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 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 } "." } ;
{ $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 set-ref* } related-words
! 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 words.constant words.alias ;
+prettyprint.sections sequences sets sorting strings summary words
+words.symbol words.constant words.alias ;
IN: see
GENERIC: synopsis* ( defspec -- )
USING: tools.test specialized-arrays sequences
specialized-arrays.int specialized-arrays.bool
specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int arrays ;
+specialized-arrays.direct.int specialized-arrays.char arrays ;
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
[ 2 ] [ int-array{ 1 2 3 } second ] unit-test
-[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >int-array underlying>> = ] unit-test
+[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test
[ ushort-array{ 1234 } ] [
little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array
! 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 macros 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
-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 words ;
+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>>
[ ] [
[ '[ _ 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?
} ;
ARTICLE: "inference-errors" "Stack checker errors"
-"These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "."
-$nl
+"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 }
"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:"
ERROR: transform-expansion-error < inference-error word error ;
+ERROR: bad-declaration-error < inference-error declaration ;
+
M: object (literal) "literal value" literal-expected ;
\ 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 ;
! More words not to compile
\ call t "no-compile" set-word-prop
-\ call subwords [ t "no-compile" set-word-prop ] each
-
\ execute t "no-compile" set-word-prop
-\ execute subwords [ t "no-compile" set-word-prop ] each
-
-\ effective-method t "no-compile" set-word-prop
-\ effective-method subwords [ t "no-compile" set-word-prop ] each
-
\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
\ bignum>float { bignum } { float } define-primitive
\ bignum>float make-foldable
-\ <ratio> { integer integer } { ratio } define-primitive
-\ <ratio> make-foldable
+\ (string>float) { byte-array } { float } define-primitive
+\ (string>float) make-foldable
-\ string>float { string } { float } define-primitive
-\ string>float make-foldable
-
-\ float>string { float } { string } define-primitive
-\ float>string make-foldable
+\ (float>string) { float } { byte-array } define-primitive
+\ (float>string) make-foldable
\ float>bits { real } { integer } define-primitive
\ float>bits make-foldable
\ 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
\ become { array array } { } define-primitive
-\ innermost-frame-quot { callstack } { quotation } define-primitive
+\ innermost-frame-executing { callstack } { object } define-primitive
\ innermost-frame-scan { callstack } { fixnum } define-primitive
\ 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
"Comparing effects:"
{ $subsection effect-height }
{ $subsection effect<= }
+{ $subsection effect= }
"The class of stack effects:"
{ $subsection effect }
{ $subsection effect? } ;
rstate recursive-state
[ word stack quot call-transformer ] with-variable
[
- word inlined-dependency depends-on
values [ length meta-d shorten-by ] [ #drop, ] bi
rstate infer-quot
] [ word infer-word ] if* ;
] 1 define-transform
\ boa t "no-compile" set-word-prop
-M\ tuple-class boa t "no-compile" set-word-prop
\ new [
dup tuple-class? [
! 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
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel arrays sequences math namespaces
-strings io fry vectors words assocs combinators sorting
-unicode.case unicode.categories math.order vocabs
-tools.vocabs unicode.data locals ;
+USING: accessors kernel arrays sequences math namespaces strings io
+fry vectors words assocs combinators sorting unicode.case
+unicode.categories math.order vocabs vocabs.hierarchy unicode.data
+locals ;
IN: tools.completion
:: (fuzzy) ( accum i full ch -- accum i full ? )
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 tools.crossref ;
+generic generic.single definitions make sbufs tools.crossref fry ;
IN: tools.continuations
<PRIVATE
: (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 single-generic? ] [ effective-method (step-into-execute) ] }
{ [ dup uses \ suspend swap member? ] [ execute break ] }
{ [ dup primitive? ] [ execute break ] }
[ def>> (step-into-quot) ]
(step-into-call-next-method)
} [ t "no-compile" set-word-prop ] each >>
+: >innermost-frame< ( callstack -- n quot )
+ [ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
+
+: (change-frame) ( callstack quot -- callstack' )
+ [ dup innermost-frame-executing quotation? ] dip '[
+ clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
+ ] when ; inline
+
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
- [ clone ] dip [
- [ clone ] dip
- [
- [
- [ innermost-frame-scan 1+ ]
- [ innermost-frame-quot ] bi
- ] dip call
- ]
- [ drop set-innermost-frame-quot ]
- [ drop ]
- 2tri
- ] curry change-call ; inline
+ [ clone ] dip '[ _ (change-frame) ] change-call ; inline
PRIVATE>
[
2dup length = [ nip [ break ] append ] [
2dup nth \ break = [ nip ] [
- swap 1+ cut [ break ] glue
+ 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) ] }
! Never step into these words
: don't-step-into ( word -- )
- dup [ execute break ] curry "step-into" set-word-prop ;
+ dup '[ _ execute break ] "step-into" set-word-prop ;
{
>n ndrop >c c>
] change-frame ;
: continuation-current ( continuation -- obj )
- call>>
- [ innermost-frame-scan 1+ ]
- [ innermost-frame-quot ] bi ?nth ;
+ call>> >innermost-frame< ?nth ;
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.standard.engines.tuple threads
-compiler.units init ;
+graphs vocabs generic generic.single threads compiler.units init ;
IN: tools.crossref
SYMBOL: crossref
M: default-method irrelevant? drop t ;
-M: engine-word irrelevant? drop t ;
+M: predicate-engine irrelevant? drop t ;
PRIVATE>
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 hashtables ;
+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 )
! 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 ;
: strip-init-hooks ( -- )
"Stripping startup hooks" show
- { "cpu.x86" "command-line" "libc" "system" "environment" }
+ {
+ "command-line"
+ "cpu.x86"
+ "environment"
+ "libc"
+ "alien.strings"
+ }
[ init-hooks get delete-at ] each
deploy-threads? get [
"threads" init-hooks get delete-at
"io.backend" init-hooks get delete-at
] when
strip-dictionary? [
- "compiler.units" init-hooks get delete-at
- "tools.vocabs" init-hooks get delete-at
+ {
+ "compiler.units"
+ "vocabs"
+ "vocabs.cache"
+ "source-files.errors"
+ } [ init-hooks get delete-at ] each
] when ;
: strip-debugger ( -- )
"compiled-uses"
"constraints"
"custom-inlining"
+ "decision-tree"
"declared-effect"
"default"
"default-method"
"engines"
"forgotten"
"identities"
- "if-intrinsics"
- "infer"
"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"
compiler.errors:compiler-errors
definition-observers
interactive-vocabs
- layouts:num-tags
- layouts:num-types
- layouts:tag-mask
- layouts:tag-numbers
- layouts:type-numbers
lexer-factory
print-use-hook
root-cache
source-files.errors:error-types
+ source-files.errors:error-observers
vocabs:dictionary
vocabs:load-vocab-hook
+ vocabs:vocab-observers
word
parser-notes
} %
+ { } { "layouts" } strip-vocab-globals %
+
{ } { "math.partial-dispatch" } strip-vocab-globals %
{ } { "peg" } strip-vocab-globals %
: compress-wrappers ( -- )
[ wrapper? ] [ ] "wrappers" compress ;
-: finish-deploy ( final-image -- )
- "Finishing up" show
- V{ } set-namestack
- V{ } set-catchstack
- "Saving final image" show
- save-image-and-exit ;
-
SYMBOL: deploy-vocab
: [:c] ( -- word ) ":c" "debugger" lookup ;
"Vocabulary has no MAIN: word." print flush 1 exit
] unless
strip
- finish-deploy
+ "Saving final image" show
+ save-image-and-exit
] deploy-error-handler
] bind ;
: 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
-[ ] [ M\ string pprint* disassemble ] unit-test\r
+"math" words [ [ [ ] ] dip '[ _ disassemble ] unit-test ] each
\ No newline at end of file
--- /dev/null
+IN: tools.disassembler.udis.tests
+USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
+
+{
+ { [ os linux? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
+ { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ "ud" heap-size ] unit-test ] }
+ { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ "ud" heap-size ] unit-test ] }
+ [ ]
+} cond
\ No newline at end of file
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
<<
LIBRARY: libudis86
-TYPEDEF: char[592] ud
+C-STRUCT: ud_operand
+ { "int" "type" }
+ { "uchar" "size" }
+ { "ulonglong" "lval" }
+ { "int" "base" }
+ { "int" "index" }
+ { "uchar" "offset" }
+ { "uchar" "scale" } ;
+
+C-STRUCT: ud
+ { "void*" "inp_hook" }
+ { "uchar" "inp_curr" }
+ { "uchar" "inp_fill" }
+ { "FILE*" "inp_file" }
+ { "uchar" "inp_ctr" }
+ { "uchar*" "inp_buff" }
+ { "uchar*" "inp_buff_end" }
+ { "uchar" "inp_end" }
+ { "void*" "translator" }
+ { "ulonglong" "insn_offset" }
+ { "char[32]" "insn_hexcode" }
+ { "char[64]" "insn_buffer" }
+ { "uint" "insn_fill" }
+ { "uchar" "dis_mode" }
+ { "ulonglong" "pc" }
+ { "uchar" "vendor" }
+ { "struct map_entry*" "mapen" }
+ { "int" "mnemonic" }
+ { "ud_operand[3]" "operand" }
+ { "uchar" "error" }
+ { "uchar" "pfx_rex" }
+ { "uchar" "pfx_seg" }
+ { "uchar" "pfx_opr" }
+ { "uchar" "pfx_adr" }
+ { "uchar" "pfx_lock" }
+ { "uchar" "pfx_rep" }
+ { "uchar" "pfx_repe" }
+ { "uchar" "pfx_repne" }
+ { "uchar" "pfx_insn" }
+ { "uchar" "default64" }
+ { "uchar" "opr_mode" }
+ { "uchar" "adr_mode" }
+ { "uchar" "br_far" }
+ { "uchar" "br_near" }
+ { "uchar" "implicit_addr" }
+ { "uchar" "c1" }
+ { "uchar" "c2" }
+ { "uchar" "c3" }
+ { "uchar[256]" "inp_cache" }
+ { "uchar[64]" "inp_sess" }
+ { "ud_itab_entry*" "itab_entry" } ;
FUNCTION: void ud_translate_intel ( ud* u ) ;
FUNCTION: void ud_translate_att ( ud* u ) ;
FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
: <ud> ( -- ud )
- "ud" <c-object>
+ "ud" malloc-object &free
dup ud_init
dup cell-bits ud_set_mode
dup UD_SYN_INTEL ud_set_syntax ;
+: with-ud ( quot: ( ud -- ) -- )
+ [ [ <ud> ] dip call ] with-destructors ; inline
+
SINGLETON: udis-disassembler
: buf/len ( from to -- buf len ) [ drop <alien> ] [ swap - ] 2bi ;
] { } 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
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
-system ;
+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
] 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 ? )
"}" 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-emacs ( -- ) ".emacs" scaffold-rc ;
+
+HOOK: scaffold-emacs os ( -- )
+
+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. ;
continuations debugger effects fry generalizations io io.files
io.styles kernel lexer locals macros math.parser namespaces
parser prettyprint quotations sequences source-files splitting
-stack-checker summary unicode.case vectors vocabs vocabs.loader words
-tools.vocabs tools.errors source-files.errors io.streams.string make
-compiler.errors ;
+stack-checker summary unicode.case vectors vocabs vocabs.loader
+vocabs.files words tools.errors source-files.errors
+io.streams.string make compiler.errors ;
IN: tools.test
TUPLE: test-failure < source-file-error continuation ;
! 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 ;
+USING: kernel math memory io io.styles prettyprint
+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
+: time. ( time -- )
+ "== Running time ==" print nl 1000000 /f pprint " seconds" print ;
+
+: gc-stats. ( stats -- )
5 cut*
- "==== GARBAGE COLLECTION" print nl
+ "== 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 (us):"
+ "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
IN: tools.trace.tests
-USING: tools.trace tools.test sequences ;
+USING: tools.trace tools.test tools.continuations kernel math combinators
+sequences ;
-[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test
\ No newline at end of file
+[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] 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 ] trace ] unit-test
+
+: case-breakpoint-test ( -- x )
+ 5 { [ break 1 + ] } case ;
+
+\ case-breakpoint-test don't-step-into
+
+[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test
+
+: call(-breakpoint-test ( -- x )
+ [ break 1 ] call( -- x ) 2 + ;
+
+\ call(-breakpoint-test don't-step-into
+
+[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test
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 ;
+generic.math combinators.short-circuit kernel.private quotations ;
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
+<PRIVATE
+
+: callstack-depth ( callstack -- n )
+ callstack>array length 2/ ;
+
+SYMBOL: end
+
: include? ( vocab -- ? )
include-vocabs get dup [ member? ] [ 2drop t ] if ;
[ CHAR: \s <string> write ]
[ number>string write ": " write ] bi ;
+: trace-into? ( continuation -- ? )
+ continuation-current into? ;
+
: 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 ;
+ dup call>> innermost-frame-executing quotation? [
+ dup continuation-current end eq? [
+ [ print-depth ]
+ [ print-step ]
+ [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ]
+ tri
+ ] unless
+ ] when ;
+
+PRIVATE>
: trace ( quot -- data )
[ [ trace-step ] break-hook ] dip
+++ /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-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-scope ;\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
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
-tools.continuations accessors words ;
+generic.single sequences.private kernel.private
+tools.continuations accessors words combinators ;
IN: tools.walker.tests
[ { } ] [
\ breakpoint-test don't-step-into
-[ f ] [ \ breakpoint-test optimized>> ] unit-test
+[ f ] [ \ breakpoint-test optimized? ] unit-test
[ { 3 } ] [ [ breakpoint-test ] test-walker ] unit-test
\ 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
+[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
+
+: case-breakpoint-test ( -- x )
+ 5 { [ break 1 + ] } case ;
+
+\ case-breakpoint-test don't-step-into
+
+[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test
+
+: call(-breakpoint-test ( -- x )
+ [ break 1 ] call( -- x ) 2 + ;
+
+\ call(-breakpoint-test don't-step-into
+
+[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test
-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, 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 { $ NSOpenGLPFARendererID $ 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
handle>> view>> -> isInFullScreenMode zero? not ;
M:: cocoa-ui-backend (open-window) ( world -- )
- world dim>> <FactorView> :> view
+ world [ [ dim>> ] dip <FactorView> ]
+ with-world-pixel-format :> view
view world world>NSRect <ViewWindow> :> window
view -> release
world view register-window
] 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 -- )
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
-> 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
x11.glx x11.clipboard x11.constants x11.windows x11.io
io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
command-line math.vectors classes.tuple opengl.gl threads
-math.rectangles environment ascii ;
+math.rectangles environment ascii literals
+ui.pixel-formats ui.pixel-formats.private ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
! 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 ;
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 ]
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals ;
+concurrency.flags math.order math.rectangles fry locals
+prettyprint.backend prettyprint.custom ;
IN: ui.gadgets
! Values for orientation slot
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>> ;
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
[ 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
{ $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 -- )
{ 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
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
namespaces opengl opengl.textures sequences io combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ;
+ui.commands ui.pixel-formats destructors literals ;
IN: ui.gadgets.worlds
+CONSTANT: default-world-pixel-format-attributes
+ { windowed double-buffered T{ depth-bits { value 16 } } }
+
TUPLE: world < track
-active? focused?
-layers
-title status status-owner
-text-handle handle images
-window-loc ;
+ active? focused?
+ layers
+ title status status-owner
+ text-handle handle images
+ window-loc
+ pixel-format-attributes ;
+
+TUPLE: world-attributes
+ { world-class initial: world }
+ title
+ status
+ gadgets
+ { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
+
+: <world-attributes> ( -- world-attributes )
+ world-attributes new ; inline
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
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>> [
- check-extensions
- {
- [ init-gl ]
- [ draw-gadget ]
- [ text-handle>> [ purge-cache ] when* ]
- [ images>> [ purge-cache ] when* ]
- } cleave
- ] with-gl-context
- flush-layout-cache-hook get call( -- ) ;
+GENERIC: begin-world ( world -- )
+GENERIC: end-world ( world -- )
+
+GENERIC: resize-world ( world -- )
+
+M: world begin-world
+ drop ;
+M: world end-world
+ drop ;
+M: world resize-world
+ drop ;
+
+M: world (>>dim)
+ [ call-next-method ]
+ [
+ dup handle>>
+ [ select-gl-context resize-world ]
+ [ drop ] if*
+ ] bi ;
+
+GENERIC: draw-world* ( world -- )
+
+M: world draw-world*
+ check-extensions
+ {
+ [ init-gl ]
+ [ draw-gadget ]
+ [ text-handle>> [ purge-cache ] when* ]
+ [ images>> [ purge-cache ] when* ]
+ } cleave ;
: draw-world? ( world -- ? )
#! We don't draw deactivated worlds, or those with 0 size.
: 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
+
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
[
--- /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
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
: show-help ( link browser-gadget -- )
[ >link ] dip
- [ [ add-recent ] [ history>> add-history ] bi* ]
+ [
+ 2dup model>> value>> =
+ [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if
+ ]
[ model>> set-model ]
2bi ;
SYMBOL: tool-dims
-tool-dims global [ H{ } clone or ] change-at
+tool-dims [ H{ } clone ] initialize
TUPLE: tool < track ;
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 ui.tools.listener
+ui.gadgets.labels ui.baseline-alignment ui.images
compiler.errors tools.errors tools.errors.model ;
IN: ui.tools.error-list
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
[ ] [
[
"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
continuations destructors documents documents.elements fry hashtables
help help.markup io io.styles kernel lexer listener math models sets
models.delay models.arrow namespaces parser prettyprint quotations
-sequences strings threads tools.vocabs vocabs vocabs.loader
+sequences strings threads vocabs vocabs.refresh vocabs.loader
vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors
ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
ui.tools.listener.completion ui.tools.listener.popups
-ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ;
+ui.tools.listener.history ui.images ui.tools.error-list
+tools.errors.model ;
FROM: source-files.errors => all-errors ;
IN: ui.tools.listener
stack-checker summary io.pathnames io.styles kernel namespaces parser
prettyprint quotations tools.crossref tools.annotations editors
tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader
-words sequences tools.vocabs classes compiler.errors compiler.units
+words sequences classes compiler.errors compiler.units
accessors vocabs.parser macros.expander ui ui.tools.browser
ui.tools.listener ui.tools.listener.completion ui.tools.profiler
ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: memory system kernel tools.vocabs ui.tools.operations
+USING: memory system kernel vocabs.refresh ui.tools.operations
ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
ui.tools.walker ui.commands ui.gestures ui ui.private ;
IN: ui.tools
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 } }
deques sequences threads sequences words continuations init
combinators combinators.short-circuit hashtables concurrency.flags
sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
+ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
+strings ;
IN: ui
<PRIVATE
[ [ 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*
PRIVATE>
: find-window ( quot -- world )
- [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline
+ [ windows get values ] dip
+ '[ dup children>> [ ] [ nip first ] if-empty @ ]
+ find-last nip ; inline
: ui-running? ( -- ? )
\ ui-running get-global ;
: 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* ;
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 ) ;
--- /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
TOKEN_ADJUST_DEFAULT
} flags ; foldable
-CONSTANT: HKEY_CLASSES_ROOT 1
-CONSTANT: HKEY_CURRENT_CONFIG 2
-CONSTANT: HKEY_CURRENT_USER 3
-CONSTANT: HKEY_LOCAL_MACHINE 4
-CONSTANT: HKEY_USERS 5
-
-CONSTANT: KEY_ALL_ACCESS HEX: 0001
-CONSTANT: KEY_CREATE_LINK HEX: 0002
+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_EXECUTE HEX: 0010
-CONSTANT: KEY_NOTIFY HEX: 0020
-CONSTANT: KEY_QUERY_VALUE HEX: 0040
-CONSTANT: KEY_READ HEX: 0080
-CONSTANT: KEY_SET_VALUE HEX: 0100
-CONSTANT: KEY_WOW64_64KEY HEX: 0200
-CONSTANT: KEY_WOW64_32KEY HEX: 0400
-CONSTANT: KEY_WRITE HEX: 0800
-
-CONSTANT: REG_BINARY 1
-CONSTANT: REG_DWORD 2
-CONSTANT: REG_EXPAND_SZ 3
-CONSTANT: REG_MULTI_SZ 4
-CONSTANT: REG_QWORD 5
-CONSTANT: REG_SZ 6
+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 ;
! : A_SHAInit ;
! : ReadEncryptedFileRaw ;
! : ReadEventLogA ;
! : ReadEventLogW ;
-! : RegCloseKey ;
+FUNCTION: LONG RegCloseKey ( HKEY hKey ) ;
! : RegConnectRegistryA ;
! : RegConnectRegistryW ;
! : RegCreateKeyA ;
! : 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 ;
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 ;
-FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ;
+FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPDWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ;
+ALIAS: RegQueryValueEx RegQueryValueExW
! : RegQueryValueW ;
! : RegReplaceKeyA ;
! : RegReplaceKeyW ;
[ define-constants ] "windows.dinput.constants" add-init-hook
: uninitialize ( variable quot -- )
- [ global ] dip '[ _ when* f ] change-at ; inline
+ '[ _ when* f ] change-global ; inline
: free-dinput-constants ( -- )
{
CONSTANT: DISCL_BACKGROUND HEX: 00000008
CONSTANT: DISCL_NOWINKEY HEX: 00000010
+CONSTANT: DIMOFS_X 0
+CONSTANT: DIMOFS_Y 4
+CONSTANT: DIMOFS_Z 8
+CONSTANT: DIMOFS_BUTTON0 12
+CONSTANT: DIMOFS_BUTTON1 13
+CONSTANT: DIMOFS_BUTTON2 14
+CONSTANT: DIMOFS_BUTTON3 15
+CONSTANT: DIMOFS_BUTTON4 16
+CONSTANT: DIMOFS_BUTTON5 17
+CONSTANT: DIMOFS_BUTTON6 18
+CONSTANT: DIMOFS_BUTTON7 19
+
CONSTANT: DIK_ESCAPE HEX: 01
CONSTANT: DIK_1 HEX: 02
CONSTANT: DIK_2 HEX: 03
--- /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: 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 ) ;
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
! 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
-cache namespaces init fonts alien.c-types windows windows.usp10
+cache namespaces init fonts alien.c-types windows.usp10
windows.offscreen windows.gdi32 windows.ole32 windows.types
-windows.fonts opengl.textures locals ;
+windows.fonts opengl.textures locals windows.errors ;
IN: windows.uniscribe
TUPLE: script-string font string metrics ssa size image disposed ;
{ "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: 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
! 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) ;
! GLX_ARB_get_proc_address extension
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* ;
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 ;
[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
write_test_program() {
echo "#include <stdio.h>" > $C_WORD.c
- echo "int main(){printf(\"%ld\", 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() {
--- /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 )
+
+M: windows alien>native-string utf16n alien>string ;
+
+M: unix alien>native-string utf8 alien>string ;
+
+HOOK: native-string>alien os ( string -- alien )
+
+M: windows native-string>alien utf16n string>alien ;
+
+M: unix native-string>alien utf8 string>alien ;
+
+: dll-path ( dll -- string )
+ path>> alien>native-string ;
+
+HOOK: string>symbol* os ( str/seq -- alien )
+
+M: winnt string>symbol* utf8 string>alien ;
+
+M: wince string>symbol* utf16n string>alien ;
+
+M: unix string>symbol* utf8 string>alien ;
+
+GENERIC: string>symbol ( str -- alien )
+
+M: string string>symbol string>symbol* ;
+
+M: sequence string>symbol [ string>symbol* ] map ;
+
+[
+ 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
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
"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 }
+ "pic-def"
+ "pic-tail-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 -- )) }
{ "(sleep)" "threads.private" (( us -- )) }
{ "<tuple-boa>" "classes.tuple.private" (( ... layout -- tuple )) }
{ "callstack>array" "kernel" (( callstack -- array )) }
- { "innermost-frame-quot" "kernel.private" (( callstack -- quot )) }
+ { "innermost-frame-executing" "kernel.private" (( callstack -- obj )) }
{ "innermost-frame-scan" "kernel.private" (( callstack -- n )) }
{ "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 -- )) }
+ { "inline-cache-miss-tail" "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:"
--- /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
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
+ ] times
] map 0 crc32-table copy
: (crc32) ( crc ch -- crc )
- >bignum dupd bitxor
- mask-byte crc32-table nth-unsafe >bignum
+ dupd bitxor
+ mask-byte crc32-table nth-unsafe
swap -8 shift bitxor ; inline
SINGLETON: crc32
\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 ;
[ ] [ "IN: classes.mixin.tests.a" <string-reader> "move-mixin-test-1" parse-stream drop ] unit-test
[ { 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
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 ;
" } ;"
""
": next-position ( role -- newrole )"
- " positions [ index 1+ ] keep nth ;"
+ " positions [ index 1 + ] keep nth ;"
""
": promote ( employee -- employee )"
" [ 1.2 * ] change-salary"
-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 compiler.errors ;
+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 ;
{
[ , ]
[ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
- [ superclasses length 1- , ]
+ [ superclasses length 1 - , ]
[ superclasses [ [ , ] [ hashcode , ] bi ] each ]
} cleave
] { } make ;
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
"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 }
-{ $subsection "call-unsafe" }
"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" } ;
{ $subsection "combinators.smart" }
"More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "."
{ $subsection "combinators-quot" }
+{ $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
<< \ 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
[ [ [ 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
] unit-test
[ "A" "B" ] [
- disable-compiler
+ disable-optimizer
gensym "a" set
gensym "b" set
] with-compilation-unit
"b" get execute
- enable-compiler
+ enable-optimizer
] unit-test
! Check that we notify observers
! Non-optimizing compiler
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.
SINGLETON: dummy-compiler
[ 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 ;
{ $subsection continue-with }
"Continuations as control-flow:"
{ $subsection attempt-all }
-{ $subsection retry }
{ $subsection with-return }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsection "continuations.private" } ;
}
} ;
-HELP: retry
-{ $values
- { "quot" quotation } { "n" integer }
-}
-{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
-{ $examples
- "Try to get a 0 as a random number:"
- { $unchecked-example "USING: continuations math prettyprint random ;"
- "[ 5 random 0 = ] 5 retry"
- "t"
- }
-} ;
-
-{ attempt-all retry } related-words
-
HELP: return
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
IN: continuations.tests
: (callcc1-test) ( n obj -- n' obj )
- [ 1- dup ] dip ?push
+ [ 1 - dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ;
[ 1 2 ] [ bar ] unit-test
-[ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test
+[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test
] { } make peek swap [ rethrow ] when
] if ; inline
-: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline
-
TUPLE: condition error restarts continuation ;
C: <condition> condition ( error restarts cc -- condition )
{ $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"
[ 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
-
! Regression
TUPLE: first-one ;
TUPLE: second-one ;
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 ]
}
--- /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 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
--- /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 pic-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-quots combination ( word methods -- pic-quot/f pic-tail-quot/f )
+
+M: single-combination inline-cache-quots 2drop f f ;
+
+: define-inline-cache-quot ( word methods -- )
+ [ drop ] [ inline-cache-quots ] 2bi
+ [ >>pic-def ] [ >>pic-tail-def ] bi*
+ 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 where "tuple-dispatch-generic" word-prop where ;
-
-M: engine-word crossref? "forgotten" word-prop not ;
-
-: 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 ( 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: 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
-
-[ 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 make ;
IN: generic.standard
-GENERIC: dispatch# ( word -- n )
-
-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 # ;
+TUPLE: standard-combination < single-combination # ;
C: <standard-combination> standard-combination
"combination" word-prop standard-combination? ;
PREDICATE: simple-generic < standard-generic
- "combination" word-prop #>> zero? ;
+ "combination" word-prop #>> 0 = ;
CONSTANT: simple-combination T{ standard-combination f 0 }
: define-simple-generic ( word effect -- )
[ simple-combination ] dip define-generic ;
-: with-standard ( combination quot -- quot' )
- [ #>> (dispatch#) ] dip with-variable ; inline
+: (picker) ( n -- quot )
+ {
+ { 0 [ [ dup ] ] }
+ { 1 [ [ over ] ] }
+ { 2 [ [ pick ] ] }
+ [ 1 - (picker) [ dip swap ] curry ]
+ } case ;
-M: standard-generic extra-values drop 0 ;
-
-M: standard-combination make-default-method
- [ error-method ] with-standard ;
-
-M: standard-combination perform-combination
- [ drop ] [ [ single-combination ] with-standard ] 2bi define ;
+M: standard-combination picker
+ combination get #>> (picker) ;
M: standard-combination dispatch# #>> ;
-M: standard-combination method-declaration
- dispatch# object <array> swap prefix [ declare ] curry [ ] like ;
-
-M: standard-combination next-method-quot*
- [
- single-next-method-quot
- dup [ picker prepend ] when
- ] with-standard ;
-
M: standard-generic effective-method
- [ dispatch# (picker) call ] keep single-effective-method ;
-
-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 ;
+: inline-cache-quot ( word methods miss-word -- quot )
+ [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ;
-M: hook-combination dispatch# drop 0 ;
+M: standard-combination inline-cache-quots
+ #! 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.
+ [ \ inline-cache-miss inline-cache-quot ]
+ [ \ inline-cache-miss-tail inline-cache-quot ]
+ 2bi ;
-M: hook-combination method-declaration 2drop [ ] ;
+: make-empty-cache ( -- array )
+ mega-cache-size get f <array> ;
-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 [ ] 4sequence ;
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) ;
[ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi
] dip
pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if
- ] 2curry each
+ ] 2curry each-integer
] keep { } like ;
M: hashtable clone
! 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
--- /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> ;
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 generic.standard ;
+make math sequences system threads tools.test generic.single ;
IN: io.files.tests
[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
-! 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 "Seeks to an offset from the current position of the stream pointer." } ;
+{ seek-absolute seek-relative seek-end } related-words
HELP: seek-input
{ $values
{ $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"
{ $subsection bl }
"Seeking on the default output stream:"
{ $subsection seek-output }
+"Seeking descriptors:"
+{ $subsection seek-absolute }
+{ $subsection seek-relative }
+{ $subsection seek-end }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }
"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:"
: 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
{ $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. 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." }
! Regression
: (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap
- < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
+ < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
: loop ( obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
-! 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
[ 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
] [
pre-scale
/f-loop over odd?
- [ zero? [ 1+ ] unless ] [ drop ] if
+ [ zero? [ 1 + ] unless ] [ drop ] if
post-scale
] if
] if ; inline
-! 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
-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
$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." } ;
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math.private namespaces sequences sequences.private
-strings arrays combinators splitting math assocs make ;
+strings arrays combinators splitting math assocs byte-arrays make ;
IN: math.parser
: digit> ( ch -- n )
string>natural
] if ; inline
+: string>float ( str -- n/f )
+ >byte-array 0 suffix (string>float) ;
+
PRIVATE>
: base> ( str radix -- n/f )
[ ".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." ] }
{ [ 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 ;
-! 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-and-exit) ;
+
: 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 }
{ $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
"tools.test"
"tools.threads"
"tools.time"
- "tools.vocabs"
"vocabs"
"vocabs.loader"
+ "vocabs.refresh"
+ "vocabs.hierarchy"
"words"
"scratchpad"
} interactive-vocabs set-global
: parse-stream ( stream name -- quot )
[
[
- lines dup parse-fresh
+ stream-lines dup parse-fresh
[ nip ] [ finish-parsing ] 2bi
forget-smudged
] with-source-file
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
{ $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? }
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
[ empty? not ] filter ;
: mismatch ( seq1 seq2 -- i )
- [ min-length ] 2keep
+ [ min-length iota ] 2keep
[ 2nth-unsafe = not ] 2curry
find drop ; inline
: (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 } }" }
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 ;
[
\ 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 ;
[ [ [ 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 [
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 }
$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" } }
: (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 combinators ;
+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"
"<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"
""
! 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
-! 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 ( -- ) ;
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 ;
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
ABOUT: "words"
-HELP: execute ( word -- )
-{ $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: deferred
{ $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ;
! 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 ;
: reset-generic ( word -- )
[ subwords forget-all ]
[ reset-word ]
- [ { "methods" "combination" "default-method" } reset-props ]
- tri ;
+ [
+ f >>pic-def
+ f >>pic-tail-def
+ {
+ "methods"
+ "combination"
+ "default-method"
+ "engines"
+ "decision-tree"
+ } reset-props
+ ] tri ;
: gensym ( -- word )
"( gensym )" f <word> ;
--- /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 ;
! 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 namespaces ;
+continuations debugger math namespaces memory ;
IN: benchmark
<PRIVATE
: run-benchmark ( vocab -- )
[ "=== " write vocab-name print flush ] [
- [ [ require ] [ [ run ] benchmark ] [ ] tri timings ]
+ [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
[ swap errors ]
recover get set-at
] bi ;
}
: 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
+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: 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: 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
+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
GL_FLOAT 0 0 buffer-offset glNormalPointer
[
nv>> "float" heap-size * buffer-offset
- 3 GL_FLOAT 0 roll glVertexPointer
+ [ 3 GL_FLOAT 0 ] dip glVertexPointer
] [
ni>>
GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
: outlining-supported? ( -- ? )
"2.0" {
- "GL_ARB_shading_objects"
+ "GL_ARB_shader_objects"
"GL_ARB_draw_buffers"
"GL_ARB_multitexture"
} has-gl-version-or-extensions? {
] 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 ]
: 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 )
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 ;
--- /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
+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
--- /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
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 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 struct-arrays
+math.bitwise ;
IN: game-input.dinput
+CONSTANT: MOUSE-BUFFER-SIZE 16
+
SINGLETON: dinput-game-input-backend
dinput-game-input-backend game-input-backend set-global
SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
+controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+ ;
+ +device-change-window+ +device-change-handle+
+ +mouse-device+ +mouse-state+ +mouse-buffer+ ;
: create-dinput ( -- )
f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
+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*>
: set-data-format ( device format-symbol -- )
get IDirectInputDevice8W::SetDataFormat ole32-error ;
+: <buffer-size-diprop> ( size -- DIPROPDWORD )
+ "DIPROPDWORD" <c-object>
+ "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
+ "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
+ 0 over set-DIPROPHEADER-dwObj
+ DIPH_DEVICE over set-DIPROPHEADER-dwHow
+ swap over set-DIPROPDWORD-dwData ;
+
+: set-buffer-size ( device size -- )
+ DIPROP_BUFFERSIZE swap <buffer-size-diprop>
+ IDirectInputDevice8W::SetProperty ole32-error ;
+
: configure-keyboard ( keyboard -- )
[ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
+: configure-mouse ( mouse -- )
+ [ c_dfDIMouse2 set-data-format ]
+ [ MOUSE-BUFFER-SIZE set-buffer-size ]
+ [ set-coop-level ] tri ;
: configure-controller ( controller -- )
[ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
256 <byte-array> <keys-array> keyboard-state boa
+keyboard-state+ set-global ;
+: find-mouse ( -- )
+ GUID_SysMouse device-for-guid
+ [ configure-mouse ]
+ [ +mouse-device+ set-global ] bi
+ 0 0 0 0 8 f <array> mouse-state boa
+ +mouse-state+ set-global
+ MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
+ +mouse-buffer+ set-global ;
+
: device-info ( device -- DIDEVICEIMAGEINFOW )
"DIDEVICEINSTANCEW" <c-object>
"DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
[ +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 ;
+: release-mouse ( -- )
+ +mouse-device+ [ com-release f ] change-global
+ f +mouse-state+ set-global ;
+
M: dinput-game-input-backend (open-game-input)
create-dinput
create-device-change-window
find-keyboard
+ find-mouse
set-up-controllers
add-wm-devicechange ;
M: dinput-game-input-backend (close-game-input)
remove-wm-devicechange
release-controllers
+ release-mouse
release-keyboard
close-device-change-window
delete-dinput ;
[ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
} 2cleave ;
+: read-device-buffer ( device buffer count -- buffer count' )
+ [ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
+ [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
+
+: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
+ [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
+ { DIMOFS_X [ [ + ] curry change-dx ] }
+ { DIMOFS_Y [ [ + ] curry change-dy ] }
+ { DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
+ [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ]
+ } case ;
+
+: fill-mouse-state ( buffer count -- state )
+ [ +mouse-state+ get ] 2dip swap
+ [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
+
: get-device-state ( device byte-array -- )
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
[ length ] keep
+keyboard-device+ get
[ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
[ ] [ f ] with-acquisition ;
+
+M: dinput-game-input-backend read-mouse
+ +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ fill-mouse-state ] [ f ] with-acquisition ;
+
+M: dinput-game-input-backend reset-mouse
+ +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ 2drop ] [ ] with-acquisition
+ +mouse-state+ get
+ 0 >>dx
+ 0 >>dy
+ 0 >>scroll-dx
+ 0 >>scroll-dy
+ drop ;
IN: game-input
ARTICLE: "game-input" "Game controller input"
-"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl
+"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
"The game input interface must be initialized before being used:"
{ $subsection open-game-input }
{ $subsection close-game-input }
{ $subsection instance-id }
"A hook is provided for invoking the system calibration tool:"
{ $subsection calibrate-controller }
-"The current state of a controller or the keyboard can be read:"
+"The current state of a controller, the keyboard, and the mouse can be read:"
{ $subsection read-controller }
{ $subsection read-keyboard }
+{ $subsection read-mouse }
{ $subsection controller-state }
-{ $subsection keyboard-state } ;
+{ $subsection keyboard-state }
+{ $subsection mouse-state } ;
HELP: open-game-input
{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
$nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
+HELP: read-mouse
+{ $values { "mouse-state" mouse-state } }
+{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." }
+{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ;
+
+HELP: reset-mouse
+{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ;
+
HELP: controller-state
{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
{ $list
{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
+HELP: mouse-state
+{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"
+{ $list
+ { { $snippet "dx" } " contains the mouse's X axis movement." }
+ { { $snippet "dy" } " contains the mouse's Y axis movement." }
+ { { $snippet "scroll-dx" } " contains the scroller's X axis movement." }
+ { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." }
+ { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." }
+}
+"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "."
+} ;
+
+
{ keyboard-state read-keyboard } related-words
ABOUT: "game-input"
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
+
+M: mouse-state clone
+ call-next-method dup buttons>> clone >>buttons ;
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
{
{ [ os windows? ] [ "game-input.dinput" require ] }
{ [ os macosx? ] [ "game-input.iokit" require ] }
sequences locals combinators.short-circuit threads
namespaces assocs vectors arrays combinators
core-foundation.run-loop accessors sequences.private
-alien.c-types math parser game-input ;
+alien.c-types math parser game-input vectors ;
IN: game-input.iokit
SINGLETON: iokit-game-input-backend
CONSTANT: game-devices-matching-seq
{
+ H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers
+ H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
+ H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
+ H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
}
CONSTANT: buttons-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
CONSTANT: slider-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
+CONSTANT: wheel-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } }
CONSTANT: hat-switch-matching-hash
H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
: transfer-element-property ( element from-key to-key -- )
[ dupd element-property ] dip swap set-element-property ;
+: mouse-device? ( device -- ? )
+ {
+ [ 1 1 IOHIDDeviceConformsTo ]
+ [ 1 2 IOHIDDeviceConformsTo ]
+ } 1|| ;
+
: controller-device? ( device -- ? )
{
[ 1 4 IOHIDDeviceConformsTo ]
[ 1 5 IOHIDDeviceConformsTo ]
+ [ 1 8 IOHIDDeviceConformsTo ]
} 1|| ;
: element-usage ( element -- {usage-page,usage} )
{ 1 HEX: 35 } = ; inline
: slider? ( {usage-page,usage} -- ? )
{ 1 HEX: 36 } = ; inline
+: wheel? ( {usage-page,usage} -- ? )
+ { 1 HEX: 38 } = ; inline
: hat-switch? ( {usage-page,usage} -- ? )
{ 1 HEX: 39 } = ; inline
IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
: axis-value ( value -- [-1,1] )
kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
+: mouse-axis-value ( value -- n )
+ IOHIDValueGetIntegerValue ;
: pov-value ( value -- pov-direction )
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
+: record-button ( hid-value usage state -- )
+ [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ;
+
: record-controller ( controller-state value -- )
dup IOHIDValueGetElement element-usage {
- { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] }
+ { [ dup button? ] [ rot record-button ] }
{ [ dup x-axis? ] [ drop axis-value >>x drop ] }
{ [ dup y-axis? ] [ drop axis-value >>y drop ] }
{ [ dup z-axis? ] [ drop axis-value >>z drop ] }
[ 3drop ]
} cond ;
-SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ;
+SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
: ?set-nth ( value nth seq -- )
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
+keyboard-state+ get ?set-nth
] [ drop ] if ;
+: record-mouse ( value -- )
+ dup IOHIDValueGetElement element-usage {
+ { [ dup button? ] [ +mouse-state+ get record-button ] }
+ { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
+ { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
+ { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
+ { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
+ [ 2drop ]
+ } cond ;
+
+M: iokit-game-input-backend read-mouse
+ +mouse-state+ get ;
+
+M: iokit-game-input-backend reset-mouse
+ +mouse-state+ get
+ 0 >>dx
+ 0 >>dy
+ 0 >>scroll-dx
+ 0 >>scroll-dy
+ drop ;
+
: default-calibrate-saturation ( element -- )
[ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
[ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
[ button-count f <array> ]
} cleave controller-state boa ;
+: ?add-mouse-buttons ( device -- )
+ button-count +mouse-state+ get buttons>>
+ 2dup length >
+ [ set-length ] [ 2drop ] if ;
+
: device-matched-callback ( -- alien )
[| context result sender device |
- device controller-device? [
- device <device-controller-state>
- device +controller-states+ get set-at
- ] when
+ {
+ { [ device controller-device? ] [
+ device <device-controller-state>
+ device +controller-states+ get set-at
+ ] }
+ { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
+ [ ]
+ } cond
] IOHIDDeviceCallback ;
: device-removed-callback ( -- alien )
: device-input-callback ( -- alien )
[| context result sender value |
- sender controller-device?
- [ sender +controller-states+ get at value record-controller ]
- [ value record-keyboard ]
- if
+ {
+ { [ sender controller-device? ] [
+ sender +controller-states+ get at value record-controller
+ ] }
+ { [ sender mouse-device? ] [ value record-mouse ] }
+ [ value record-keyboard ]
+ } cond
] IOHIDValueCallback ;
: initialize-variables ( manager -- )
+hid-manager+ set-global
4 <vector> +controller-states+ set-global
+ 0 0 0 0 2 <vector> mouse-state boa
+ +mouse-state+ set-global
256 f <array> +keyboard-state+ set-global ;
M: iokit-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 calendar 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 ] [ 1 milliseconds sleep (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
USING: tools.deploy.config ;
H{
- { deploy-name "Hello world (console)" }
- { deploy-c-types? f }
- { deploy-word-props? f }
- { deploy-ui? f }
- { deploy-reflection 1 }
- { deploy-compiler? f }
{ deploy-unicode? f }
+ { deploy-ui? f }
+ { deploy-compiler? t }
+ { deploy-name "Hello world (console)" }
{ deploy-io 2 }
- { deploy-word-defs? f }
{ deploy-threads? f }
- { "stop-after-last-window?" t }
+ { deploy-reflection 1 }
{ deploy-math? f }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
}
ui.gadgets.panes ui.render ui.images ;
IN: images.viewer
-TUPLE: image-gadget < gadget image-name ;
+TUPLE: image-gadget < gadget image texture ;
-M: image-gadget pref-dim*
- image-name>> image-dim ;
+M: image-gadget pref-dim* image>> dim>> ;
+
+: image-gadget-texture ( gadget -- texture )
+ dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
M: image-gadget draw-gadget* ( gadget -- )
- image-name>> draw-image ;
+ [ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
+
+! Todo: delete texture on ungraft
+
+GENERIC: <image-gadget> ( object -- gadget )
-: <image-gadget> ( image-name -- gadget )
+M: image <image-gadget>
\ image-gadget new
- swap >>image-name ;
+ swap >>image ;
-: image-window ( path -- gadget )
- [ <image-name> <image-gadget> dup ] [ open-window ] bi ;
+M: string <image-gadget> load-image <image-gadget> ;
-GENERIC: image. ( object -- )
+M: pathname <image-gadget> string>> load-image <image-gadget> ;
-M: string image. ( image -- ) <image-name> <image-gadget> gadget. ;
+: image-window ( object -- ) <image-gadget> "Image" open-window ;
-M: pathname image. ( image -- ) <image-name> <image-gadget> gadget. ;
+: image. ( object -- ) <image-gadget> gadget. ;
"--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
-! 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
! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 mason.email mason.notify
-namespaces prettyprint ;
+io.files io.launcher namespaces prettyprint mason.child mason.cleanup
+mason.common mason.help mason.release mason.report mason.email
+mason.notify ;
IN: mason.build
QUALIFIED: continuations
: begin-build ( -- )
"factor" [ git-id ] with-directory
- [ "git-id" to-file ] [ notify-begin-build ] bi ;
+ [ "git-id" to-file ]
+ [ current-git-id set ]
+ [ notify-begin-build ]
+ tri ;
: build ( -- )
create-build-dir
math.functions make io io.files io.pathnames io.directories
io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
combinators.short-circuit parser combinators calendar
-calendar.format arrays mason.config locals system debugger ;
+calendar.format arrays mason.config locals system debugger fry
+continuations ;
IN: mason.common
+SYMBOL: current-git-id
+
ERROR: output-process-error output process ;
M: output-process-error error.
: try-output-process ( command -- )
>process +stdout+ >>stderr utf8 <process-reader*>
- [ contents ] [ dup wait-for-process ] bi*
+ [ stream-contents ] [ dup wait-for-process ] bi*
0 = [ 2drop ] [ output-process-error ] if ;
HOOK: really-delete-tree os ( path -- )
<process>
swap >>command
15 minutes >>timeout
+ +closed+ >>stdin
try-output-process ;
+: retry ( n quot -- )
+ '[ drop @ f ] attempt-all drop ; inline
+
:: upload-safely ( local username host remote -- )
[let* | temp [ remote ".incomplete" append ]
scp-remote [ { username "@" host ":" temp } concat ]
scp [ scp-command get ]
ssh [ ssh-command get ] |
- { scp local scp-remote } short-running-process
- { ssh host "-l" username "mv" temp remote } short-running-process
+ 5 [ { scp local scp-remote } short-running-process ] retry
+ 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry
] ;
: eval-file ( file -- obj )
: ?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"
IN: mason.email.tests
USING: mason.email mason.common mason.config namespaces tools.test ;
-[ "mason on linux-x86-64: error" ] [
+[ "mason on linux-x86-64: 12345 -- error" ] [
[
"linux" target-os set
"x86.64" target-cpu set
+ "12345" current-git-id set
status-error subject prefix-subject
] with-scope
] unit-test
! 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
-mason.common mason.platform mason.config ;
+prettyprint sequences io io.streams.string io.encodings.utf8 io.files
+io.sockets mason.common mason.platform mason.config ;
IN: mason.email
: prefix-subject ( str -- str' )
send-email ;
: subject ( status -- str )
- {
+ [ current-git-id get 7 short head " -- " ] dip {
{ status-clean [ "clean" ] }
{ status-dirty [ "dirty" ] }
{ status-error [ "error" ] }
- } case ;
+ } case 3append ;
: email-report ( report status -- )
[ "text/html" ] dip subject email-status ;
-! 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: io.directories io.files io.launcher kernel make
-mason.common mason.config mason.platform namespaces prettyprint
-sequences ;
+namespaces prettyprint sequences mason.common mason.config
+mason.platform ;
IN: mason.release.branch
: branch-name ( -- string ) "clean-" platform append ;
] { } make ;
: push-to-clean-branch ( -- )
- push-to-clean-branch-cmd short-running-process ;
+ 5 [ push-to-clean-branch-cmd short-running-process ] retry ;
: upload-clean-image-cmd ( -- args )
[
] { } make ;
: upload-clean-image ( -- )
- upload-clean-image-cmd short-running-process ;
+ 5 [ upload-clean-image-cmd short-running-process ] retry ;
: (update-clean-branch) ( -- )
"factor" [
target-cpu get
host-name
build-dir
- "git-id" eval-file
+ current-git-id get
[XML
<h1>Build report for <->/<-></h1>
<table>
timings-table
"Load failures"
- load-everything-vocabs-file
- load-everything-errors-file
+ load-all-vocabs-file
+ load-all-errors-file
error-dump
"Compiler errors"
: build-clean? ( -- ? )
{
- [ load-everything-vocabs-file eval-file empty? ]
+ [ 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? ]
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 system io tools.errors locals ;
+prettyprint sequences sets sorting tools.test tools.time
+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 )
--- /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
+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 ;
USING: arrays morse strings tools.test ;
IN: morse.tests
-[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test
+[ "?" ] [ CHAR: \\ ch>morse ] unit-test
[ "..." ] [ CHAR: s ch>morse ] unit-test
[ CHAR: s ] [ "..." morse>ch ] unit-test
[ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test
MORSE] ] unit-test
! [ ] [ "sos" 0.075 play-as-morse* ] unit-test
! [ ] [ "Factor rocks!" play-as-morse ] unit-test
+! [ ] [ "\n" play-as-morse ] unit-test
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: .
]
: ch>morse ( ch -- morse )
- ch>lower morse-code-table at [ unknown-char ] unless* ;
+ ch>lower morse-code-table at unknown-char 1string or ;
: morse>ch ( str -- ch )
- morse-code-table value-at [ char-gap-char ] unless* ;
+ morse-code-table value-at char-gap-char or ;
<PRIVATE
source get source-play
] with-scope ; inline
-: play-char ( ch -- )
+: play-char ( string -- )
[ intra-char-gap ] [
{
{ dot-char [ dot ] }
{ dash-char [ dash ] }
{ word-gap-char [ intra-char-gap ] }
+ { unknown-char [ intra-char-gap ] }
+ [ no-morse-ch ]
} case
] interleave ;
--- /dev/null
+USING: byte-arrays combinators fry images kernel locals math
+math.affine-transforms math.functions math.order
+math.polynomials math.vectors random random.mersenne-twister
+sequences sequences.product ;
+IN: noise
+
+: <perlin-noise-table> ( -- table )
+ 256 iota >byte-array randomize dup append ;
+
+: with-seed ( seed quot -- )
+ [ <mersenne-twister> ] dip with-random ; inline
+
+<PRIVATE
+
+: fade ( point -- point' )
+ { 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
+
+:: grad ( hash gradients -- gradient )
+ hash 8 bitand zero? [ gradients first ] [ gradients second ] if
+ :> u
+ hash 12 bitand zero?
+ [ gradients second ]
+ [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if
+ :> v
+
+ hash 1 bitand zero? [ u ] [ u neg ] if
+ hash 2 bitand zero? [ v ] [ v neg ] if + ;
+
+: unit-cube ( point -- cube )
+ [ floor >fixnum 256 mod ] map ;
+
+:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb )
+ cube first :> x
+ cube second :> y
+ cube third :> z
+ x table nth y + :> a
+ x 1 + table nth y + :> b
+
+ a table nth z + :> aa
+ b table nth z + :> ba
+ a 1 + table nth z + :> ab
+ b 1 + table nth z + :> bb
+
+ aa table nth
+ ba table nth
+ ab table nth
+ bb table nth
+ aa 1 + table nth
+ ba 1 + table nth
+ ab 1 + table nth
+ bb 1 + table nth ;
+
+:: 2tetra@ ( p q r s t u v w quot -- )
+ p q quot call
+ r s quot call
+ t u quot call
+ v w quot call
+ ; inline
+
+: >byte-map ( floats -- bytes )
+ [ 255.0 * >fixnum ] B{ } map-as ;
+
+: >image ( bytes dim -- image )
+ swap [ L f ] dip image boa ;
+
+PRIVATE>
+
+:: perlin-noise ( table point -- value )
+ point unit-cube :> cube
+ point dup vfloor v- :> gradients
+ gradients fade :> faded
+
+ table cube hashes {
+ [ gradients grad ]
+ [ gradients { -1.0 0.0 0.0 } v+ grad ]
+ [ gradients { 0.0 -1.0 0.0 } v+ grad ]
+ [ gradients { -1.0 -1.0 0.0 } v+ grad ]
+ [ gradients { 0.0 0.0 -1.0 } v+ grad ]
+ [ gradients { -1.0 0.0 -1.0 } v+ grad ]
+ [ gradients { 0.0 -1.0 -1.0 } v+ grad ]
+ [ gradients { -1.0 -1.0 -1.0 } v+ grad ]
+ } spread
+ [ faded first lerp ] 2tetra@
+ [ faded second lerp ] 2bi@
+ faded third lerp ;
+
+: normalize-0-1 ( sequence -- sequence' )
+ [ supremum ] [ infimum [ - ] keep ] [ ] tri
+ [ swap - ] with map [ swap / ] with map ;
+
+: clamp-0-1 ( sequence -- sequence' )
+ [ 0.0 max 1.0 min ] map ;
+
+: perlin-noise-map ( table transform dim -- map )
+ [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ;
+
+: perlin-noise-byte-map ( table transform dim -- map )
+ perlin-noise-map normalize-0-1 >byte-map ;
+
+: perlin-noise-image ( table transform dim -- image )
+ [ perlin-noise-byte-map ] [ >image ] bi ;
+
+: uniform-noise-map ( seed dim -- map )
+ [ product [ 0.0 1.0 uniform-random-float ] replicate ]
+ curry with-seed ;
+
+: uniform-noise-byte-map ( seed dim -- map )
+ uniform-noise-map >byte-map ;
+
+: uniform-noise-image ( seed dim -- image )
+ [ uniform-noise-byte-map ] [ >image ] bi ;
+
+: normal-noise-map ( seed sigma dim -- map )
+ swap '[ _ product [ 0.5 _ normal-random-float ] replicate ]
+ with-seed ;
+
+: normal-noise-byte-map ( seed sigma dim -- map )
+ normal-noise-map clamp-0-1 >byte-map ;
+
+: normal-noise-image ( seed sigma dim -- image )
+ [ normal-noise-byte-map ] [ >image ] bi ;
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 literals ;
IN: opengl.demo-support
-: FOV ( -- x ) 2.0 sqrt 1+ ; inline
+CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: MOUSE-MOTION-SCALE 0.5
CONSTANT: KEY-ROTATE-STEP 10.0
SYMBOL: last-drag-loc
-TUPLE: demo-gadget < gadget yaw pitch distance ;
+TUPLE: demo-world < world yaw pitch distance ;
-: new-demo-gadget ( yaw pitch distance class -- gadget )
- new
- swap >>distance
- swap >>pitch
- swap >>yaw ; inline
+: set-demo-orientation ( world yaw pitch distance -- world )
+ [ >>yaw ] [ >>pitch ] [ >>distance ] tri* ;
GENERIC: far-plane ( gadget -- z )
GENERIC: near-plane ( gadget -- z )
GENERIC: distance-step ( gadget -- dz )
-M: demo-gadget far-plane ( gadget -- z )
+M: demo-world far-plane ( gadget -- z )
drop 4.0 ;
-M: demo-gadget near-plane ( gadget -- z )
+M: demo-world near-plane ( gadget -- z )
drop 1.0 64.0 / ;
-M: demo-gadget distance-step ( gadget -- dz )
+M: demo-world distance-step ( gadget -- dz )
drop 1.0 64.0 / ;
: fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
-: yaw-demo-gadget ( yaw gadget -- )
+: yaw-demo-world ( yaw gadget -- )
[ + ] with change-yaw relayout-1 ;
-: pitch-demo-gadget ( pitch gadget -- )
+: pitch-demo-world ( pitch gadget -- )
[ + ] with change-pitch relayout-1 ;
-: zoom-demo-gadget ( distance gadget -- )
+: zoom-demo-world ( distance gadget -- )
[ + ] with change-distance relayout-1 ;
-M: demo-gadget pref-dim* ( gadget -- dim )
+M: demo-world focusable-child* ( world -- gadget )
+ drop t ;
+
+M: demo-world pref-dim* ( gadget -- dim )
drop { 640 480 } ;
: -+ ( x -- -x x )
[ neg ] keep ;
-: demo-gadget-frustum ( gadget -- -x x -y y near far )
+: demo-world-frustum ( world -- -x x -y y near far )
[ near-plane ] [ far-plane ] [ fov-ratio ] tri [
nip swap FOV / v*n
first2 [ -+ ] bi@
] 3keep drop ;
-: demo-gadget-set-matrices ( gadget -- )
+M: demo-world resize-world
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ [ [ 0 0 ] dip dim>> first2 glViewport ]
+ [ demo-world-frustum glFrustum ] bi ;
+
+: demo-world-set-matrix ( gadget -- )
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- [
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- demo-gadget-frustum glFrustum
- ] [
- GL_MODELVIEW glMatrixMode
- glLoadIdentity
- [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
- [ pitch>> 1.0 0.0 0.0 glRotatef ]
- [ yaw>> 0.0 1.0 0.0 glRotatef ]
- tri
- ] bi ;
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
+ [ pitch>> 1.0 0.0 0.0 glRotatef ]
+ [ yaw>> 0.0 1.0 0.0 glRotatef ]
+ tri ;
: reset-last-drag-rel ( -- )
{ 0 0 } last-drag-loc set-global ;
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
! 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
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( -- result ) [ error-stack get first throw ] unless* ] with-global-lexer
- ast>> ;
+ [ execute [ error-stack get first throw ] unless* ] with-global-lexer
+ 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
ERROR: role-slot-overlap class slots ;
ERROR: multiple-inheritance-attempted classes ;
-PREDICATE: role < class
- { [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ;
+PREDICATE: role < mixin-class
+ "role-slots" word-prop >boolean ;
: parse-role-definition ( -- class superroles slots )
CREATE-CLASS scan {
--- /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
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
--- /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
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 )
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
-ERROR: checksum-error ;
+ERROR: checksum-error header ;
: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
] if ;
: parse-tar-header ( seq -- obj )
- [ checksum-header ] keep over zero-checksum = [
+ dup checksum-header dup zero-checksum = [
2drop
\ tar-header new
0 >>size
0 >>checksum
] [
- binary [ read-tar-header ] with-byte-reader
- [ checksum>> = [ checksum-error ] unless ] keep
+ [
+ binary [ read-tar-header ] with-byte-reader
+ dup checksum>>
+ ] dip = [ checksum-error ] unless
] if ;
ERROR: unknown-typeflag ch ;
] if ;
! Hard link
-: typeflag-1 ( header -- ) unknown-typeflag ;
+: typeflag-1 ( header -- )
+ [ name>> ] [ linkname>> ] bi make-hard-link ;
! Symlink
: typeflag-2 ( header -- )
! Long file name
: typeflag-L ( header -- )
- drop ;
+ drop
+ ;
! <string-writer> [ read-data-blocks ] keep
! >string [ zero? ] trim-tail filename set
! filename get prepend-current-directory make-directories ;
! Vendor extended header type
: typeflag-X ( header -- ) unknown-typeflag ;
-: (parse-tar) ( -- )
+: 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 ;
: untar ( path -- )
- normalize-path [ ] [ parent-directory ] bi [
- binary [ (parse-tar) ] with-file-reader
+ normalize-path dup parent-directory [
+ binary [ parse-tar ] with-file-reader
] with-directory ;
--- /dev/null
+USING: accessors arrays byte-arrays combinators fry grouping
+images kernel math math.affine-transforms math.order
+math.vectors noise random sequences ;
+IN: terrain.generation
+
+CONSTANT: terrain-segment-size { 512 512 }
+CONSTANT: terrain-big-noise-scale { 0.002 0.002 }
+CONSTANT: terrain-small-noise-scale { 0.05 0.05 }
+
+TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ;
+
+: <terrain> ( -- terrain )
+ <perlin-noise-table> <perlin-noise-table>
+ 32 random-bits terrain boa ;
+
+: seed-at ( seed at -- seed' )
+ first2 [ + ] dip [ 32 random-bits + ] curry with-seed ;
+
+: big-noise-segment ( terrain at -- map )
+ [ big-noise-table>> terrain-big-noise-scale first2 <scale> ] dip
+ terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
+: small-noise-segment ( terrain at -- map )
+ [ small-noise-table>> terrain-small-noise-scale first2 <scale> ] dip
+ terrain-segment-size [ v* <translation> a. ] keep perlin-noise-byte-map ;
+: tiny-noise-segment ( terrain at -- map )
+ [ tiny-noise-seed>> ] dip seed-at 0.1
+ terrain-segment-size normal-noise-byte-map ;
+
+: padding ( terrain at -- padding )
+ 2drop terrain-segment-size product 255 <repetition> ;
+
+TUPLE: segment image ;
+
+: terrain-segment ( terrain at -- image )
+ {
+ [ big-noise-segment ]
+ [ small-noise-segment ]
+ [ tiny-noise-segment ]
+ [ padding ]
+ } 2cleave
+ 4array flip concat >byte-array
+ [ terrain-segment-size RGBA f ] dip image boa ;
+
+: 4max ( a b c d -- max )
+ max max max ; inline
+
+: mipmap ( {{pixels}} quot: ( aa ab ba bb -- c ) -- pixels' )
+ [ [ 2 <groups> ] map 2 <groups> ] dip
+ '[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline
+
+: group-pixels ( bitmap dim -- scanlines )
+ [ 4 <groups> ] [ first <groups> ] bi* ;
+
+: concat-pixels ( scanlines -- bitmap )
+ [ concat ] map concat ;
+
+: segment-mipmap ( image -- image' )
+ [ clone ] [ bitmap>> ] [ dim>> ] tri
+ group-pixels [ 4max ] mipmap concat-pixels >>bitmap
+ [ 2 v/n ] change-dim ;
--- /dev/null
+USING: multiline ;
+IN: terrain.shaders
+
+STRING: terrain-vertex-shader
+
+uniform sampler2D heightmap;
+
+varying vec2 heightcoords;
+
+const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
+
+float height(sampler2D map, vec2 coords)
+{
+ vec4 v = texture2D(map, coords);
+ return dot(v, COMPONENT_SCALE);
+}
+
+void main()
+{
+ gl_Position = gl_ModelViewProjectionMatrix
+ * (gl_Vertex + vec4(0, height(heightmap, gl_Vertex.xz), 0, 0));
+ heightcoords = gl_Vertex.xz;
+}
+
+;
+
+STRING: terrain-pixel-shader
+
+uniform sampler2D heightmap;
+
+varying vec2 heightcoords;
+
+const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
+
+float height(sampler2D map, vec2 coords)
+{
+ vec4 v = texture2D(map, coords);
+ return dot(v, COMPONENT_SCALE);
+}
+
+void main()
+{
+ gl_FragColor = texture2D(heightmap, heightcoords);
+}
+
+;
--- /dev/null
+USING: accessors arrays combinators game-input
+game-input.scancodes game-loop kernel literals locals math
+math.constants math.functions math.matrices math.order
+math.vectors opengl opengl.capabilities opengl.gl
+opengl.shaders opengl.textures opengl.textures.private
+sequences sequences.product specialized-arrays.float
+terrain.generation terrain.shaders ui ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ;
+IN: terrain
+
+CONSTANT: FOV $[ 2.0 sqrt 1+ ]
+CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
+CONSTANT: FAR-PLANE 1.0
+CONSTANT: EYE-START { 0.5 0.5 1.2 }
+CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
+CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
+CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ]
+
+CONSTANT: terrain-vertex-size { 512 512 }
+CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
+CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
+
+TUPLE: terrain-world < world
+ eye yaw pitch
+ terrain terrain-segment terrain-texture terrain-program
+ terrain-vertex-buffer
+ game-loop ;
+
+: frustum ( dim -- -x x -y y near far )
+ dup first2 min v/n
+ NEAR-PLANE FOV / v*n first2 [ [ neg ] keep ] bi@
+ NEAR-PLANE FAR-PLANE ;
+
+: set-modelview-matrix ( gadget -- )
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_MODELVIEW glMatrixMode
+ glLoadIdentity
+ [ pitch>> 1.0 0.0 0.0 glRotatef ]
+ [ yaw>> 0.0 1.0 0.0 glRotatef ]
+ [ eye>> vneg first3 glTranslatef ] tri ;
+
+: vertex-array-vertex ( x z -- vertex )
+ [ terrain-vertex-distance first * ]
+ [ terrain-vertex-distance second * ] bi*
+ [ 0 ] dip float-array{ } 3sequence ;
+
+: vertex-array-row ( z -- vertices )
+ dup 1 + 2array
+ terrain-vertex-size first 1 + iota
+ 2array [ first2 swap vertex-array-vertex ] product-map
+ concat ;
+
+: vertex-array ( -- vertices )
+ terrain-vertex-size second iota
+ [ vertex-array-row ] map concat ;
+
+: >vertex-buffer ( bytes -- buffer )
+ [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW <gl-buffer> ;
+
+: draw-vertex-buffer-row ( i -- )
+ [ GL_TRIANGLE_STRIP ] dip
+ terrain-vertex-row-length * terrain-vertex-row-length
+ glDrawArrays ;
+
+: draw-vertex-buffer ( buffer -- )
+ [ GL_ARRAY_BUFFER ] dip [
+ 3 GL_FLOAT 0 f glVertexPointer
+ terrain-vertex-size second iota [ draw-vertex-buffer-row ] each
+ ] with-gl-buffer ;
+
+: degrees ( deg -- rad )
+ pi 180.0 / * ;
+
+:: eye-rotate ( yaw pitch v -- v' )
+ yaw degrees neg :> y
+ pitch degrees neg :> p
+ y cos :> cosy
+ y sin :> siny
+ p cos :> cosp
+ p sin :> sinp
+
+ cosy 0.0 siny neg 3array
+ siny sinp * cosp cosy sinp * 3array
+ siny cosp * sinp neg cosy cosp * 3array 3array
+ v swap v.m ;
+
+: forward-vector ( world -- v )
+ [ yaw>> ] [ pitch>> ] bi
+ { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
+: rightward-vector ( world -- v )
+ [ yaw>> ] [ pitch>> ] bi
+ { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
+
+: move-forward ( world -- )
+ dup forward-vector [ v+ ] curry change-eye drop ;
+: move-backward ( world -- )
+ dup forward-vector [ v- ] curry change-eye drop ;
+: move-leftward ( world -- )
+ dup rightward-vector [ v- ] curry change-eye drop ;
+: move-rightward ( world -- )
+ dup rightward-vector [ v+ ] curry change-eye drop ;
+
+: rotate-with-mouse ( world mouse -- )
+ [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
+ [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi
+ drop ;
+
+:: handle-input ( world -- )
+ read-keyboard keys>> :> keys
+ key-w keys nth [ world move-forward ] when
+ key-s keys nth [ world move-backward ] when
+ key-a keys nth [ world move-leftward ] when
+ key-d keys nth [ world move-rightward ] when
+ world read-mouse rotate-with-mouse
+ reset-mouse ;
+
+M: terrain-world tick*
+ [ handle-input ] keep
+ ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug
+ drop ;
+
+M: terrain-world draw*
+ nip draw-world ;
+
+: set-heightmap-texture-parameters ( texture -- )
+ GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
+ GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ;
+
+M: terrain-world begin-world
+ "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
+ require-gl-version-or-extensions
+ GL_DEPTH_TEST glEnable
+ GL_TEXTURE_2D glEnable
+ GL_VERTEX_ARRAY glEnableClientState
+ 0.5 0.5 0.5 1.0 glClearColor
+ EYE-START >>eye
+ 0.0 >>yaw
+ 0.0 >>pitch
+ <terrain> [ >>terrain ] keep
+ { 0 0 } terrain-segment [ >>terrain-segment ] keep
+ make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture
+ terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
+ >>terrain-program
+ vertex-array >vertex-buffer >>terrain-vertex-buffer
+ TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
+ reset-mouse
+ drop ;
+
+M: terrain-world end-world
+ {
+ [ game-loop>> stop-loop ]
+ [ terrain-vertex-buffer>> delete-gl-buffer ]
+ [ terrain-program>> delete-gl-program ]
+ [ terrain-texture>> delete-texture ]
+ } cleave ;
+
+M: terrain-world resize-world
+ GL_PROJECTION glMatrixMode
+ glLoadIdentity
+ dim>> [ [ 0 0 ] dip first2 glViewport ]
+ [ frustum glFrustum ] bi ;
+
+M: terrain-world draw-world*
+ [ set-modelview-matrix ]
+ [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
+ [ dup terrain-program>> [
+ "heightmap" glGetUniformLocation 0 glUniform1i
+ terrain-vertex-buffer>> draw-vertex-buffer
+ ] with-gl-program ]
+ tri gl-error ;
+
+M: terrain-world focusable-child* drop t ;
+M: terrain-world pref-dim* drop { 640 480 } ;
+
+: terrain-window ( -- )
+ [
+ open-game-input
+ f T{ world-attributes
+ { world-class terrain-world }
+ { title "Terrain" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 24 } }
+ } }
+ } open-window
+ ] with-ui ;
--- /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
+++ /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
! 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
: random-url ( -- string )
1 6 [a,b] random [ letter-bank random ] "" replicate-as ;
+: retry ( quot: ( -- ? ) n -- )
+ swap [ drop ] prepose attempt-all ; inline
+
: insert-short-url ( short-url -- short-url )
'[ _ dup random-url >>short insert-tuple ] 10 retry ;
: subtract-overhead ( {oldtime,n} overhead -- {newtime,n} )
[ first2 ] dip
swap [ * - ] keep 2array ;
-
-: change-global ( variable quot -- )
- global swap change-at ; inline
: (correct-for-timing-overhead) ( timingshash -- timingshash )
time-dummy-word [ subtract-overhead ] curry assoc-map ;
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)
(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:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (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
--- /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
+! 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
endif
# CFLAGS += -fPIC
+FFI_TEST_CFLAGS = -fPIC
# LINKER = gcc -shared -o
# LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor
CONSOLE_EXTENSION=.com
DLL_EXTENSION=.dll
SHARED_DLL_EXTENSION=.dll
-LINKER = $(CC) -shared -mno-cygwin -o
+LINKER = $(CPP) -shared -mno-cygwin -o
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)
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()
+{
+ 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();
+
+ symbol_char *sym = name->data<symbol_char>();
+
+ 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()
+{
+ 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();
+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();
- 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();
- 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();
- 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()
+{
+ 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)->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_executing)
+{
+ dpush(frame_executing(innermost_stack_frame(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_executing);
+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->size);
+}
+
+static int number_of_parameters(relocation_type type)
+{
+ switch(type)
+ {
+ case RT_PRIMITIVE:
+ case RT_XT:
+ case RT_XT_PIC:
+ case RT_XT_PIC_TAIL:
+ case RT_IMMEDIATE:
+ case RT_HERE:
+ case RT_UNTAGGED:
+ return 1;
+ case RT_DLSYM:
+ return 2;
+ case RT_THIS:
+ case RT_STACK_CHAIN:
+ case RT_MEGAMORPHIC_CACHE_HITS:
+ return 0;
+ default:
+ critical_error("Bad rel type",type);
+ return -1; /* Can't happen */
+ }
+}
+
+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;
+ }
+}
+
+static void *xt_pic(word *w, cell tagged_quot)
+{
+ 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 *word_xt_pic(word *w)
+{
+ return xt_pic(w,w->pic_def);
+}
+
+void *word_xt_pic_tail(word *w)
+{
+ return xt_pic(w,w->pic_tail_def);
+}
+
+/* References to undefined symbols are patched up to call this function on
+image load */
+void undefined_symbol()
+{
+ 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
+ {
+ 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;
+ }
+}
+
+cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
+{
+ array *literals = untag<array>(compiled->literals);
+ cell offset = REL_OFFSET(rel) + (cell)compiled->xt();
+
+#define ARG array_nth(literals,index)
+
+ switch(REL_TYPE(rel))
+ {
+ case RT_PRIMITIVE:
+ return (cell)primitives[untag_fixnum(ARG)];
+ case RT_DLSYM:
+ return (cell)get_rel_symbol(literals,index);
+ case RT_IMMEDIATE:
+ return ARG;
+ case RT_XT:
+ return (cell)object_xt(ARG);
+ case RT_XT_PIC:
+ return (cell)word_xt_pic(untag<word>(ARG));
+ case RT_XT_PIC_TAIL:
+ return (cell)word_xt_pic_tail(untag<word>(ARG));
+ case RT_HERE:
+ return offset + (short)untag_fixnum(ARG);
+ case RT_THIS:
+ return (cell)(compiled + 1);
+ case RT_STACK_CHAIN:
+ return (cell)&stack_chain;
+ case RT_UNTAGGED:
+ return untag_fixnum(ARG);
+ case RT_MEGAMORPHIC_CACHE_HITS:
+ return (cell)&megamorphic_cache_hits;
+ default:
+ critical_error("Bad rel type",rel);
+ return 0; /* Can't happen */
+ }
+
+#undef ARG
+}
+
+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);
+ index += number_of_parameters(REL_TYPE(rel));
+ }
+ }
+}
+
+/* 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_ABSOLUTE_PPC_2:
+ store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0);
+ 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->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->last_scan)
+ {
+ if(collecting_accumulation_gen_p())
+ compiled->last_scan = collecting_gen;
+ else
+ compiled->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);
+ }
+}
+
+/* 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
+
+ store_address_in_code_block(REL_CLASS(rel),
+ REL_OFFSET(rel) + (cell)compiled->xt(),
+ compute_relocation(rel,index,compiled));
+}
+
+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_PIC || type == RT_XT_PIC_TAIL)
+ relocate_code_block_step(rel,index,compiled);
+}
+
+/* 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->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->type == PIC_TYPE)
+ heap_free(&code,compiled);
+ 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);
+
+ 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;
+ }
+ }
+}
+
+/* Perform all fixups on a code block */
+void relocate_code_block(code_block *compiled)
+{
+ compiled->last_scan = NURSERY;
+ compiled->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->type = type;
+ compiled->last_scan = NURSERY;
+ compiled->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 or quotation's general entry point */
+ RT_XT,
+ /* a word's PIC entry point */
+ RT_XT_PIC,
+ /* a word's tail-call PIC entry point */
+ RT_XT_PIC_TAIL,
+ /* 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,
+ /* address of megamorphic_cache_hits var */
+ RT_MEGAMORPHIC_CACHE_HITS,
+};
+
+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,
+ /* absolute address in a PowerPC LIS/ORI sequence */
+ RC_ABSOLUTE_PPC_2_2,
+ /* absolute address in a PowerPC LWZ instruction */
+ RC_ABSOLUTE_PPC_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_ABSOLUTE_PPC_2_MASK 0xffff
+#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()
+{
+ 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->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ {
+ int index = 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->status = B_FREE;
+ end->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->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->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->size != size )
+ {
+ /* split the block in two */
+ free_heap_block *split = (free_heap_block *)((cell)block + size);
+ split->status = B_FREE;
+ split->size = block->size - size;
+ split->next_free = block->next_free;
+ 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->status = B_ALLOCATED;
+ return 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, unordered_map<heap_block *,char *> &forwarding)
+{
+ heap_block *scan = first_block(heap);
+ char *address = (char *)first_block(heap);
+
+ while(scan)
+ {
+ if(scan->status == B_ALLOCATED)
+ {
+ forwarding[scan] = address;
+ address += scan->size;
+ }
+ else if(scan->status == B_MARKED)
+ critical_error("Why is the block marked?",0);
+
+ scan = next_block(heap,scan);
+ }
+
+ return (cell)address - heap->seg->start;
+}
+
+void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+{
+ heap_block *scan = first_block(heap);
+
+ while(scan)
+ {
+ heap_block *next = next_block(heap,scan);
+
+ if(scan->status == B_ALLOCATED)
+ memmove(forwarding[scan],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, unordered_map<heap_block *,char *> &forwarding);
+void compact_heap(heap *h, unordered_map<heap_block *,char *> &forwarding);
+
+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;
-}
-
-/* Compile a word definition with the non-optimizing compiler. Allocates memory */
-void jit_compile_word(F_WORD *word, CELL def, bool relocate)
-{
- REGISTER_ROOT(def);
- REGISTER_UNTAGGED(word);
- jit_compile(def,relocate);
- UNREGISTER_UNTAGGED(word);
- UNREGISTER_ROOT(def);
-
- word->code = untag_quotation(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(type_of(data) == QUOTATION_TYPE)
- {
- REGISTER_UNTAGGED(alist);
- REGISTER_UNTAGGED(word);
- jit_compile_word(word,data,false);
- UNREGISTER_UNTAGGED(word);
- UNREGISTER_UNTAGGED(alist);
- }
- else if(type_of(data) == ARRAY_TYPE)
- {
- 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);
- }
- else
- critical_error("Expected a quotation or an array",data);
-
- 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->pic_def != F) jit_compile(word->pic_def,relocate);
+ if(word->pic_tail_def != F) jit_compile(word->pic_tail_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()
+{
+ 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()
+{
+ 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));
+}
+
+static unordered_map<heap_block *,char *> forwarding;
+
+code_block *forward_xt(code_block *compiled)
+{
+ return (code_block *)forwarding[compiled];
+}
+
+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()
+{
+ 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()
+{
+ 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()
+{
+ /* Free all unreachable code blocks */
+ gc();
+
+ /* Figure out where the code heap blocks are going to end up */
+ cell size = compute_heap_forwarding(&code, forwarding);
+
+ /* Update word and quotation code pointers */
+ forward_object_xts();
+
+ /* Actually perform the compaction */
+ compact_heap(&code,forwarding);
+
+ /* 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 jit_compile_word(F_WORD *word, CELL def, 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();
+
+PRIMITIVE(modify_code_heap);
+
+PRIMITIVE(code_room);
+
+void compact_code_heap();
+
+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()
+{
+ ds = ds_bot - sizeof(cell);
+}
+
+void reset_retainstack()
+{
+ rs = rs_bot - sizeof(cell);
+}
+
+#define RESERVED (64 * sizeof(cell))
+
+void fix_stacks()
+{
+ 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()
+{
+ if(stack_chain)
+ {
+ stack_chain->datastack = ds;
+ stack_chain->retainstack = rs;
+ }
+}
+
+context *alloc_context()
+{
+ 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()
+{
+ 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()
+{
+ 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 reset_retainstack();
+void fix_stacks();
+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();
+VM_C_API void nest_stacks();
+VM_C_API void unnest_stacks();
+
+}
+
+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);
+
+}
in the public domain. */
#include "asm.h"
-#define DS_REG r29
+#define DS_REG r13
DEF(void,primitive_fixnum_add,(void)):
lwz r3,0(DS_REG)
/* 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,16(r3) /* load quotation-xt slot */ XX \
#define CALL_QUOT \
CALL_OR_JUMP_QUOT XX \
DEF(void,c_to_factor,(CELL quot)):
PROLOGUE
- SAVE_INT(r13,0) /* save GPRs */
- SAVE_INT(r14,1)
- SAVE_INT(r15,2)
- SAVE_INT(r16,3)
- SAVE_INT(r17,4)
- SAVE_INT(r18,5)
- SAVE_INT(r19,6)
- SAVE_INT(r20,7)
- SAVE_INT(r21,8)
- SAVE_INT(r22,9)
- SAVE_INT(r23,10)
- SAVE_INT(r24,11)
- SAVE_INT(r25,12)
- SAVE_INT(r26,13)
- SAVE_INT(r27,14)
- SAVE_INT(r28,15)
+ SAVE_INT(r15,0) /* save GPRs */
+ SAVE_INT(r16,1)
+ SAVE_INT(r17,2)
+ SAVE_INT(r18,3)
+ SAVE_INT(r19,4)
+ SAVE_INT(r20,5)
+ SAVE_INT(r21,6)
+ SAVE_INT(r22,7)
+ SAVE_INT(r23,8)
+ SAVE_INT(r24,9)
+ SAVE_INT(r25,10)
+ SAVE_INT(r26,11)
+ SAVE_INT(r27,12)
+ SAVE_INT(r28,13)
+ SAVE_INT(r29,14)
+ SAVE_INT(r30,15)
SAVE_INT(r31,16)
SAVE_FP(f14,20) /* save FPRs */
RESTORE_FP(f14,20) /* save FPRs */
RESTORE_INT(r31,16) /* restore GPRs */
- RESTORE_INT(r28,15)
- RESTORE_INT(r27,14)
- RESTORE_INT(r26,13)
- RESTORE_INT(r25,12)
- RESTORE_INT(r24,11)
- RESTORE_INT(r23,10)
- RESTORE_INT(r22,9)
- RESTORE_INT(r21,8)
- RESTORE_INT(r20,7)
- RESTORE_INT(r19,6)
- RESTORE_INT(r18,5)
- RESTORE_INT(r17,4)
- RESTORE_INT(r16,3)
- RESTORE_INT(r15,2)
- RESTORE_INT(r14,1)
- RESTORE_INT(r13,0)
+ RESTORE_INT(r30,15)
+ RESTORE_INT(r29,14)
+ RESTORE_INT(r28,13)
+ RESTORE_INT(r27,12)
+ RESTORE_INT(r26,11)
+ RESTORE_INT(r25,10)
+ RESTORE_INT(r24,9)
+ RESTORE_INT(r23,8)
+ RESTORE_INT(r22,7)
+ RESTORE_INT(r21,6)
+ RESTORE_INT(r20,5)
+ RESTORE_INT(r19,4)
+ RESTORE_INT(r18,3)
+ RESTORE_INT(r17,2)
+ RESTORE_INT(r16,1)
+ RESTORE_INT(r15,0)
EPILOGUE
blr
sync /* finish up */
isync
blr
+
+DEF(void,primitive_inline_cache_miss,(void)):
+ mflr r6
+DEF(void,primitive_inline_cache_miss_tail,(void)):
+ PROLOGUE
+ mr r3,r6
+ bl MANGLE(inline_cache_miss)
+ EPILOGUE
+ mtctr r3
+ bctr
+++ /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 VM_C_API
+
+register cell ds asm("r13");
+register cell rs asm("r14");
+
+/* In the instruction sequence:
+
+ LOAD32 r3,...
+ B blah
+
+ the offset from the immediate operand to LOAD32 to the instruction after
+ the branch is two instructions. */
+static const fixnum xt_tail_pic_offset = 4 * 2;
+
+inline static void check_call_site(cell return_address)
+{
+#ifdef FACTOR_DEBUG
+ cell insn = *(cell *)return_address;
+ /* Check that absolute bit is 0 */
+ assert((insn & 0x2) == 0x0);
+ /* Check that instruction is branch */
+ assert((insn >> 26) == 0x12);
+#endif
+}
+
+#define B_MASK 0x3fffffc
+
+inline static void *get_call_target(cell return_address)
+{
+ return_address -= sizeof(cell);
+ check_call_site(return_address);
+
+ cell insn = *(cell *)return_address;
+ cell unsigned_addr = (insn & B_MASK);
+ fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6;
+ return (void *)(signed_addr + return_address);
+}
+
+inline static void set_call_target(cell return_address, void *target)
+{
+ return_address -= sizeof(cell);
+ check_call_site(return_address);
+
+ cell insn = *(cell *)return_address;
+
+ fixnum relative_address = ((cell)target - return_address);
+ insn = ((insn & ~B_MASK) | (relative_address & B_MASK));
+ *(cell *)return_address = insn;
+
+ /* Flush the cache line containing the call we just patched */
+ __asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):);
+}
+
+inline static bool tail_call_site_p(cell return_address)
+{
+ return_address -= sizeof(cell);
+ cell insn = *(cell *)return_address;
+ return (insn & 0x1) == 0;
+}
+
+/* Defined in assembly */
+VM_ASM_API void c_to_factor(cell quot);
+VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);
+VM_ASM_API void lazy_jit_compile(cell quot);
+VM_ASM_API void flush_icache(cell start, cell len);
+
+VM_ASM_API void set_callstack(stack_frame *to,
+ stack_frame *from,
+ cell length,
+ void *(*memcpy)(void*,const void*, size_t));
+
+}
#include "asm.h"
-/* Note that primitive word definitions are compiled with
-__attribute__((regparm 2), so the pointer to the word object is passed in EAX,
-and the callstack top is passed in EDX */
-
#define ARG0 %eax
#define ARG1 %edx
#define STACK_REG %esp
pop %ebp ; \
pop %ebx
-#define QUOT_XT_OFFSET 17
+#define QUOT_XT_OFFSET 16
/* 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(void,primitive_inline_cache_miss,(void)):
+ mov (%esp),%ebx
+DEF(void,primitive_inline_cache_miss_tail,(void)):
+ sub $8,%esp
+ push %ebx
+ 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 VM_C_API __attribute__ ((regparm (2)))
+
+}
#endif
-#define QUOT_XT_OFFSET 37
+#define QUOT_XT_OFFSET 36
/* 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(void,primitive_inline_cache_miss,(void)):
+ mov (%rsp),%rbx
+DEF(void,primitive_inline_cache_miss_tail,(void)):
+ sub $STACK_PADDING,%rsp
+ mov %rbx,ARG0
+ 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 VM_C_API
+
+}
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) {}
+
+/* In the instruction sequence:
+
+ MOV EBX,...
+ JMP blah
+
+ the offset from the immediate operand to MOV to the instruction after
+ the jump is a cell for the immediate operand, 4 bytes for the JMP
+ destination, and one byte for the JMP opcode. */
+static const fixnum xt_tail_pic_offset = sizeof(cell) + 4 + 1;
+
+static const unsigned char call_opcode = 0xe8;
+static const unsigned char jmp_opcode = 0xe9;
+
+inline static unsigned char call_site_opcode(cell return_address)
+{
+ return *(unsigned char *)(return_address - 5);
+}
+
+inline static void check_call_site(cell return_address)
+{
+#ifdef FACTOR_DEBUG
+ unsigned char opcode = call_site_opcode(return_address);
+ assert(opcode == call_opcode || opcode == jmp_opcode);
+#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);
+}
+
+inline static bool tail_call_site_p(cell return_address)
+{
+ return call_site_opcode(return_address) == jmp_opcode;
+}
+
+/* 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)
-{
- u64 start = current_micros();
-
- int i;
- for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
- copy_gen_cards(i);
-
- card_scan_time += (current_micros() - start);
-}
-
-/* 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);
-
- if(!performing_compaction)
- {
- 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;
- }
-
- 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_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(ulong_long_to_bignum(total_gc_time)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(cards_scanned)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(decks_scanned)));
- GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(card_scan_time)));
- 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;
- card_scan_time = 0;
- code_heap_scans = 0;
-}
-
-void primitive_clear_gc_stats(void)
-{
- clear_gc_stats();
-}
-
-/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
- to coalesce equal but distinct quotations and wrappers. */
-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();
-
- /* 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();
-}
--- /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()
+{
+ 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()
+{
+ 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()
+{
+ cell scan = gc_locals_region->start;
+
+ for(; scan <= gc_locals; scan += sizeof(cell))
+ copy_handle(*(cell **)scan);
+}
+
+static void copy_registered_bignums()
+{
+ 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()
+{
+ 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()
+{
+ 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()
+{
+ 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()
+{
+ 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;
-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;
-
-/* 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;
-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;
-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 gc();
+
+inline static bool collecting_accumulation_gen_p()
+{
+ 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();
+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();
+
+}
+++ /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()
+{
+ 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 0; /* 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 0; /* 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()
+{
+ heap_scan_ptr = data->generations[TENURED].start;
+ gc_off = true;
+}
+
+PRIMITIVE(begin_scan)
+{
+ begin_scan();
+}
+
+cell next_object()
+{
+ 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()
+{
+ 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();
+
+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();
+cell next_object();
+
+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();
+
+/* 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()
+{
+ print_string("==== DATA STACK:\n");
+ print_objects((cell *)ds_bot,(cell *)ds);
+}
+
+void print_retainstack()
+{
+ 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()
+{
+ 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()
+{
+ 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()
+{
+ 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()
+{
+ 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 factorbug();
+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 0;
+ }
+ }
+}
+
+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
+{
+
+extern cell megamorphic_cache_hits;
+extern cell megamorphic_cache_misses;
+
+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(void)
-{
- general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
-}
-
-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);
-}
-
-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()
+{
+ 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()
+{
+ 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()
+{
+ 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()
+{
+ memory_protection_error(signal_fault_addr,signal_callstack_top);
+}
+
+void misc_signal_handler_impl()
+{
+ 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(void);
-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 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 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 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();
+
+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 misc_signal_handler_impl();
+
+}
+++ /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()
+{
+ 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 (*callback)() = (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();
+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;
}
{
return x + 2 * y;
}
+
+short ffi_test_48(struct bool_field_test x)
+{
+ return x.parents;
+}
-#if defined(FACTOR_X86)
+#include <stdbool.h>
+
+#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);
+
+F_EXPORT struct test_struct_14 ffi_test_44();
+
+F_EXPORT _Complex float ffi_test_45(int x);
-DLLEXPORT struct test_struct_14 ffi_test_44();
+F_EXPORT _Complex double ffi_test_46(int x);
-DLLEXPORT _Complex float ffi_test_45(int x);
+F_EXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
-DLLEXPORT _Complex double ffi_test_46(int x);
+struct bool_field_test {
+ char *name;
+ bool on;
+ short parents;
+};
-DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
+F_EXPORT short ffi_test_48(struct bool_field_test x);
+++ /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;
- if(fread(&h,sizeof(F_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] = 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];
- }
-
- bool ok = true;
-
- if(fwrite(&h,sizeof(F_HEADER),1,file) != 1) ok = false;
- if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
- if(fwrite(first_block(&code_heap),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;
-}
-
-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 */
- performing_compaction = true;
- compact_code_heap();
- performing_compaction = false;
-
- 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;
+
+ for(cell i = 0; i < USER_ENV; i++)
+ h.userenv[i] = (save_env_p(i) ? userenv[i] : F);
+
+ 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 */
+ for(cell i = 0; i < USER_ENV; i++)
+ {
+ if(!save_env_p(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);
+ check_code_pointer((cell)old_xt);
+
+ code_block *old_block = (code_block *)old_xt - 1;
+ cell old_type = old_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);
+}
+
+/* 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 0;
+}
+
+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_,
+ bool tail_call_p);
+};
+
+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_,
+ bool tail_call_p)
+{
+ 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_special(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]);
+}
+
+static code_block *compile_inline_cache(fixnum index,
+ cell generic_word_,
+ cell methods_,
+ cell cache_entries_,
+ bool tail_call_p)
+{
+ 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(),
+ tail_call_p);
+ 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(),
+ tail_call_site_p(return_address))->xt();
+ }
+
+ /* Install the new stub. */
+ set_call_target(return_address,xt);
+
+#ifdef PIC_DEBUG
+ printf("Updated %s call site 0x%lx with 0x%lx\n",
+ tail_call_site_p(return_address) ? "tail" : "non-tail",
+ 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);
+PRIMITIVE(inline_cache_miss_tail);
+
+VM_C_API 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()
+{
+ 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()
+{
+#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()
+{
+ return errno;
+}
+
+VM_C_API void clear_err_no()
+{
+ 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 io_error();
+
+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();
+VM_C_API void clear_err_no();
+
+}
--- /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());
+}
+
+void jit::emit_relocation(cell code_template_)
+{
+ gc_root<array> code_template(code_template_);
+ cell capacity = array_capacity(code_template.untagged());
+ for(cell i = 1; i < capacity; i += 3)
+ {
+ cell rel_class = array_nth(code_template.untagged(),i);
+ cell rel_type = array_nth(code_template.untagged(),i + 1);
+ cell offset = array_nth(code_template.untagged(),i + 2);
+
+ relocation_entry new_entry
+ = (untag_fixnum(rel_type) << 28)
+ | (untag_fixnum(rel_class) << 24)
+ | ((code.count + untag_fixnum(offset)));
+ relocation.append_bytes(&new_entry,sizeof(relocation_entry));
+ }
+}
+
+/* Allocates memory */
+void jit::emit(cell code_template_)
+{
+ gc_root<array> code_template(code_template_);
+
+ emit_relocation(code_template.value());
+
+ 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);
+
+ void emit_relocation(cell code_template);
+ 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) {
+ literal(tag_fixnum(xt_tail_pic_offset));
+ literal(word);
+ emit(userenv[JIT_WORD_JUMP]);
+ }
+
+ void word_call(cell word) {
+ emit_with(userenv[JIT_WORD_CALL],word);
+ }
+
+ void word_special(cell word) {
+ emit_with(userenv[JIT_WORD_SPECIAL],word);
+ }
+
+ void emit_subprimitive(cell word_) {
+ gc_root<word> word(word_);
+ gc_root<array> code_template(word->subprimitive);
+ if(array_capacity(code_template.untagged()) > 1) 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;
+
+ /* Default ctor to make gcc 3.x happy */
+ header() { abort(); }
+
+ 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 */
+ unsigned char needs_fixup; /* is this a new block that needs full fixup? */
+
+ /* In bytes, includes this header */
+ cell size;
+};
+
+struct free_heap_block : public heap_block
+{
+ free_heap_block *next_free;
+};
+
+struct code_block : public heap_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 pic_def;
+ /* TAGGED alternative entry point for direct tail calls. Used for inline caching */
+ cell pic_tail_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 ()
+{
+ 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 ();
+
+}
+++ /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
+
+/* C headers */
+#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>
+
+/* C++ headers */
+#if __GNUC__ == 4
+ #include <tr1/unordered_map>
+ #define unordered_map std::tr1::unordered_map
+#elif __GNUC__ == 3
+ #include <boost/unordered_map.hpp>
+ #define unordered_map boost::unordered_map
+#else
+ #error Factor requires GCC 3.x or later
+#endif
+
+/* Factor headers */
+#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()
+{
+ 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 0; /* 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 0;
+ }
+}
+
+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 0;
+ }
+}
+
+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();
+
+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()
+{
+ 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();
+
+#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()
+{
+ unix_init_signals();
+}
+
+void early_init() { }
+
+#define SUFFIX ".image"
+#define SUFFIX_LEN 6
+
+const char *default_image_path()
+{
+ 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 early_init();
+const char *vm_executable_path();
+const char *default_image_path();
+
+}
+++ /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()
+{
+ 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()
+{
+ 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()
+{
+ 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();
+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 early_init();
+
+const char *vm_executable_path();
+const char *default_image_path();
+
+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()
+{
+ 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()
+{
+ 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()
+{
+ 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()
+{
+ 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()
+{
+ /* 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()
+{
+ 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()
+{
+ 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()
+{
+ 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 ffi_dlopen(dll *dll);
+void *ffi_dlsym(dll *dll, symbol_char *symbol);
+void ffi_dlclose(dll *dll);
+
+void unix_init_signals();
+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 sleep_micros(cell usec);
+
+void open_console();
+
+}
+++ /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()
+{
+ 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() { }
+
+}
+++ /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 c_to_factor_toplevel(cell quot);
+void open_console();
+
+}
+++ /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;
- }
- /* 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
+#include "master.hpp"
+
+namespace factor
+{
+
+s64 current_micros()
+{
+ FILETIME t;
+ GetSystemTimeAsFileTime(&t);
+ return (((s64)t.dwLowDateTime | (s64)t.dwHighDateTime<<32)
+ - EPOCH_OFFSET) / 10;
+}
+
+FACTOR_STDCALL 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 = (stack_frame *)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, (PVECTORED_EXCEPTION_HANDLER)exception_handler))
+ fatal_error("AddVectoredExceptionHandler failed", 0);
+ c_to_factor(quot);
+ RemoveVectoredExceptionHandler((void *)exception_handler);
+}
+
+void open_console()
+{
+}
+
+}
+++ /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 <windows.h>
+#include <shellapi.h>
+
+namespace factor
+{
+
+typedef char symbol_char;
+
+#define FACTOR_OS_STRING "winnt"
+#define FACTOR_DLL L"factor.dll"
+#define FACTOR_DLL_NAME "factor.dll"
+
+#define FACTOR_STDCALL __attribute__((stdcall))
+
+void c_to_factor_toplevel(cell quot);
+FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
+void open_console();
+
+}
+++ /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()
+{
+ hFactorDll = GetModuleHandle(FACTOR_DLL);
+ if(!hFactorDll)
+ fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
+}
+
+void ffi_dlopen(dll *dll)
+{
+ dll->dll = LoadLibraryEx((WCHAR *)alien_offset(dll->path), NULL, 0);
+}
+
+void *ffi_dlsym(dll *dll, symbol_char *symbol)
+{
+ return (void *)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()
+{
+ 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()
+{
+ 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 = untag_check<byte_array>(dpop())->data<vm_char>();
+ 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 = (segment *)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()
+{
+ 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 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() {}
+inline static void early_init() {}
+const vm_char *vm_executable_path();
+const vm_char *default_image_path();
+long getpagesize ();
+
+s64 current_micros();
+
+}
+++ /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_executing,
+ 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_inline_cache_miss_tail,
+ 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()
+{
+ 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();
+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)
- jit_compile_word(word,word->def,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;
+ /* Inline cache misses are special-cased.
+ The calling convention for tail
+ calls stores the address of the next
+ instruction in a register. However,
+ PIC miss stubs themselves tail-call
+ the inline cache miss primitive, and
+ we don't want to clobber the saved
+ address. */
+ if(obj.value() == userenv[PIC_MISS_WORD]
+ || obj.value() == userenv[PIC_MISS_TAIL_WORD])
+ {
+ word_special(obj.value());
+ }
+ else
+ {
+ 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_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);
+ }
+
+ literal(array_nth(elements.untagged(),i));
+ literal(array_nth(elements.untagged(),i + 1));
+ emit(userenv[JIT_IF]);
+
+ 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->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()
+{
+ 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();
+
+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_WORD_SPECIAL,
+ JIT_IF_WORD,
+ JIT_IF,
+ JIT_EPILOG,
+ JIT_RETURN,
+ JIT_PROFILING,
+ JIT_PUSH_IMMEDIATE,
+ 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 = 47,
+ PIC_TAG,
+ PIC_HI_TAG,
+ PIC_TUPLE,
+ PIC_HI_TAG_TUPLE,
+ PIC_CHECK_TAG,
+ PIC_CHECK,
+ PIC_HIT,
+ PIC_MISS_WORD,
+ PIC_MISS_TAIL_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
+
+inline static bool save_env_p(cell i)
+{
+ return (i >= FIRST_SAVE_ENV && i <= LAST_SAVE_ENV) || i == STACK_TRACES_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() \
+ { \
+ 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);
- jit_compile_word(word,word->def,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()
+{
+ 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()
+{
+ 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 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();
+
+}
--- /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->pic_def = F;
+ new_word->pic_tail_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->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->type == WORD_TYPE;
+}
+
+PRIMITIVE(optimized_p);
+
+PRIMITIVE(wrapper);
+
+}
--- /dev/null
+#include "master.hpp"
+
+using namespace factor;
+
+cell cards_offset;
+cell decks_offset;
+
+namespace factor
+{
+ 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. */
+
+VM_C_API factor::cell cards_offset;
+VM_C_API factor::cell decks_offset;
+
+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)
+
+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)
+
+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
+
+extern 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);
+}
+
+}
projects / factor.git / commitdiff