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

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

db4
Sam Anklesaria 2009-05-09 08:44:53 -05:00
parent 3532a5f6c6 f40d5b0c03
commit 2747ac52f2
510 changed files with 12666 additions and 10093 deletions
basis
alien
bootstrap
cocoa
command-line
compiler
core-graphics
cpu
debugger
delegate
editors
formatting
functors
help
http/server
images/tiff
io
backend/windows/privileges
encodings/iana
files/unique
launcher/windows/nt
json/reader
literals
math
opengl
Show More

31
Makefile
View File

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

19
README.txt
View File

@ -20,25 +20,18 @@ implementation. It is not an introduction to the language itself.
* Compiling the Factor VM
The Factor runtime is written in GNU C99, and is built with GNU make and
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/>.
@ -97,7 +90,7 @@ When compiling Factor, pass the X11=1 parameter:
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.
@ -138,7 +131,7 @@ usage documentation, enter the following in the UI listener:
The Factor source tree is organized as follows:
build-support/ - scripts used for compiling Factor
vm/ - sources for the Factor VM, written in C
vm/ - Factor VM
core/ - Factor core library
basis/ - Factor basis library, compiler, tools
extra/ - more libraries and applications

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

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

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

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

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

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

8
basis/alien/libraries/libraries.factor Normal file → Executable file
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

2
basis/bootstrap/compiler/compiler.factor Normal file → Executable file
View File

@ -41,7 +41,7 @@ nl
! 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?

198
basis/bootstrap/image/image.factor
View File

@ -9,7 +9,7 @@ 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 ;
fry bootstrap.image.syntax ;
IN: bootstrap.image
: arch ( os cpu -- arch )
@ -93,24 +93,19 @@ CONSTANT: -1-offset 9
SYMBOL: sub-primitives
SYMBOL: jit-define-rc
SYMBOL: jit-define-rt
SYMBOL: jit-define-offset
SYMBOL: jit-relocations
: compute-offset ( -- offset )
building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
: compute-offset ( rc -- offset )
[ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ;
: jit-rel ( rc rt -- )
jit-define-rt set
jit-define-rc set
compute-offset jit-define-offset set ;
over compute-offset 3array jit-relocations get push-all ;
: make-jit ( quot -- quad )
: make-jit ( quot -- jit-data )
[
V{ } clone jit-relocations set
call( -- )
jit-define-rc get
jit-define-rt get
jit-define-offset get 3array
jit-relocations get >array
] B{ } make prefix ;
: jit-define ( quot name -- )
@ -128,98 +123,59 @@ SYMBOL: big-endian
! 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-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-dip-word
SYMBOL: jit-dip
SYMBOL: jit-2dip-word
SYMBOL: jit-2dip
SYMBOL: jit-3dip-word
SYMBOL: jit-3dip
SYMBOL: jit-execute-word
SYMBOL: jit-execute-jump
SYMBOL: jit-execute-call
SYMBOL: jit-epilog
SYMBOL: jit-return
SYMBOL: jit-profiling
SYMBOL: jit-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
SYMBOL: pic-load
SYMBOL: pic-tag
SYMBOL: pic-hi-tag
SYMBOL: pic-tuple
SYMBOL: pic-hi-tag-tuple
SYMBOL: pic-check-tag
SYMBOL: pic-check
SYMBOL: pic-hit
SYMBOL: pic-miss-word
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
SYMBOL: mega-lookup
SYMBOL: mega-lookup-word
SYMBOL: mega-miss-word
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-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-epilog 33 }
{ jit-return 34 }
{ jit-profiling 35 }
{ jit-push-immediate 36 }
{ jit-save-stack 38 }
{ jit-dip-word 39 }
{ jit-dip 40 }
{ jit-2dip-word 41 }
{ jit-2dip 42 }
{ jit-3dip-word 43 }
{ jit-3dip 44 }
{ jit-execute-word 45 }
{ jit-execute-jump 46 }
{ jit-execute-call 47 }
{ pic-load 48 }
{ pic-tag 49 }
{ pic-hi-tag 50 }
{ pic-tuple 51 }
{ pic-hi-tag-tuple 52 }
{ pic-check-tag 53 }
{ pic-check 54 }
{ pic-hit 55 }
{ pic-miss-word 56 }
{ mega-lookup 57 }
{ mega-lookup-word 58 }
{ mega-miss-word 59 }
{ undefined-quot 60 }
} ; inline
USERENV: undefined-quot 60
: userenv-offset ( symbol -- n )
userenvs at header-size + ;
userenvs get at header-size + ;
: emit ( cell -- ) image get push ;
@ -351,7 +307,8 @@ M: f '
[ vocabulary>> , ]
[ def>> , ]
[ props>> , ]
[ direct-entry-def>> , ] ! direct-entry-def
[ pic-def>> , ]
[ pic-tail-def>> , ]
[ drop 0 , ] ! count
[ word-sub-primitive , ]
[ drop 0 , ] ! xt
@ -510,11 +467,7 @@ M: quotation '
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
@ -524,46 +477,13 @@ M: quotation '
\ 3dip jit-3dip-word set
\ (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
{
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-dip-word
jit-dip
jit-2dip-word
jit-2dip
jit-3dip-word
jit-3dip
jit-execute-word
jit-execute-jump
jit-execute-call
jit-epilog
jit-return
jit-profiling
jit-save-stack
pic-load
pic-tag
pic-hi-tag
pic-tuple
pic-hi-tag-tuple
pic-check-tag
pic-check
pic-hit
pic-miss-word
mega-lookup
mega-lookup-word
mega-miss-word
undefined-quot
} [ emit-userenv ] each ;
[ undefined ] undefined-quot set ;
: emit-userenvs ( -- )
userenvs get keys [ emit-userenv ] each ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
@ -580,8 +500,8 @@ M: quotation '
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

1
basis/bootstrap/image/syntax/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

14
basis/bootstrap/image/syntax/syntax.factor Normal file
View File

@ -0,0 +1,14 @@
! 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 ;

1
basis/bootstrap/stage2.factor
View File

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

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

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

12
basis/cocoa/cocoa.factor
View File

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

11
basis/cocoa/plists/plists.factor
View File

@ -4,7 +4,7 @@
USING: strings arrays hashtables assocs sequences fry macros
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
combinators alien.c-types words core-foundation
combinators alien.c-types words core-foundation quotations
core-foundation.data core-foundation.utilities ;
IN: cocoa.plists
@ -41,10 +41,16 @@ DEFER: plist>
*void* [ -> release "read-plist failed" throw ] when* ;
MACRO: objc-class-case ( alist -- quot )
[ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
[
dup callable?
[ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
unless
] map '[ _ cond ] ;
PRIVATE>
ERROR: invalid-plist-object object ;
: plist> ( plist -- value )
{
{ NSString [ (plist-NSString>) ] }
@ -53,6 +59,7 @@ PRIVATE>
{ NSArray [ (plist-NSArray>) ] }
{ NSDictionary [ (plist-NSDictionary>) ] }
{ NSObject [ ] }
[ invalid-plist-object ]
} objc-class-case ;
: read-plist ( path -- assoc )

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

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

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

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

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

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

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

@ -3,7 +3,7 @@
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex sets libc alien.libraries
alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture
source-files.errors
compiler.errors
@ -88,7 +88,7 @@ M: ##call generate-insn
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 ;

7
basis/compiler/codegen/fixup/fixup.factor
View File

@ -56,8 +56,11 @@ SYMBOL: literal-table
: rel-word ( word class -- )
[ add-literal ] dip rt-xt rel-fixup ;
: rel-word-direct ( word class -- )
[ add-literal ] dip rt-xt-direct rel-fixup ;
: rel-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 ;

17
basis/compiler/compiler.factor
View File

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

54
basis/compiler/constants/constants.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math kernel layouts system strings words quotations byte-arrays
alien arrays ;
alien arrays literals sequences ;
IN: compiler.constants
! These constants must match vm/memory.h
@ -14,42 +14,42 @@ CONSTANT: deck-bits 18
: float-offset ( -- n ) 8 float 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 \ word 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
: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; 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 ) 10 bootstrap-cells \ word 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 ) 5 bootstrap-cells ; 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-xt-direct 4
CONSTANT: rt-here 5
CONSTANT: rt-this 6
CONSTANT: rt-immediate 7
CONSTANT: rt-stack-chain 8
CONSTANT: rt-untagged 9
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? ;

13
basis/compiler/tests/alien.factor
View File

@ -588,3 +588,16 @@ FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ;
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

8
basis/compiler/tests/optimizer.factor
View File

@ -389,4 +389,10 @@ DEFER: loop-bbb
[ f ] [ \ broken-declaration optimized? ] unit-test
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] 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

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

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

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

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

10
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
View File

@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ;
] { 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
@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ;
{ integer } declare [ 256 rem ] map
] { mod fixnum-mod rem } inlined?
] unit-test
[ [ >fixnum 255 fixnum-bitand ] ]
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test

8
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor
View File

@ -2,6 +2,7 @@
! 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
@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes )
: 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 ;
@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
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 ;

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

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

19
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
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 {
@ -217,6 +213,8 @@ generic-comparison-ops [
{ >float float }
{ fixnum>float float }
{ bignum>float float }
{ >integer integer }
} [
'[
_
@ -228,19 +226,26 @@ generic-comparison-ops [
] "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

5
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
! Mutable tuples with circularity should not cause problems
TUPLE: circle me ;
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
! Joe found an oversight
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test

9
basis/core-graphics/core-graphics.factor
View File

@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
<PRIVATE
: bitmap-flags ( -- flags )

5
basis/core-graphics/types/types.factor
View File

@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
TYPEDEF: uint CGBitmapInfo
TYPEDEF: int CGLError
TYPEDEF: int CGError
TYPEDEF: uint CGDirectDisplayID
TYPEDEF: int boolean_t
TYPEDEF: void* CGLContextObj
TYPEDEF: int CGLContextParameter
TYPEDEF: int CGLContextParameter

1
basis/cpu/architecture/architecture.factor
View File

@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- )
HOOK: stack-frame-size cpu ( stack-frame -- n )
HOOK: %call cpu ( word -- )
HOOK: %jump cpu ( word -- )
HOOK: %jump-label cpu ( label -- )
HOOK: %return cpu ( -- )

220
basis/cpu/ppc/assembler/assembler-tests.factor
View File

@ -3,114 +3,114 @@ USING: cpu.ppc.assembler tools.test arrays kernel namespaces
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

4
basis/cpu/ppc/assembler/assembler.factor
View File

@ -1,7 +1,7 @@
! 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

18
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -1,11 +1,10 @@
! 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 ;
@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
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 ;

163
basis/cpu/ppc/bootstrap.factor
View File

@ -9,8 +9,8 @@ IN: bootstrap.ppc
4 \ cell set
big-endian on
CONSTANT: ds-reg 29
CONSTANT: rs-reg 30
CONSTANT: ds-reg 13
CONSTANT: rs-reg 14
: factor-area-size ( -- n ) 4 bootstrap-cells ;
@ -21,46 +21,48 @@ CONSTANT: rs-reg 30
: xt-save ( -- n ) stack-frame 2 bootstrap-cells - ;
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
11 6 profile-count-offset LWZ
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
11 3 profile-count-offset LWZ
11 11 1 tag-fixnum ADDI
11 6 profile-count-offset STW
11 6 word-code-offset LWZ
11 3 profile-count-offset STW
11 3 word-code-offset LWZ
11 11 compiled-header-size ADDI
11 MTCTR
BCTR
] jit-profiling jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel
0 MFLR
1 1 stack-frame SUBI
6 1 xt-save STW
stack-frame 6 LI
6 1 next-save STW
3 1 xt-save STW
stack-frame 3 LI
3 1 next-save STW
0 1 lr-save stack-frame + STW
] jit-prolog jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
6 ds-reg 4 STWU
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
3 ds-reg 4 STWU
] jit-push-immediate jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
7 6 0 LWZ
1 7 0 STW
] jit-save-stack jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
6 MTCTR
0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel
4 3 0 LWZ
1 4 0 STW
0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel
3 MTCTR
BCTR
] jit-primitive jit-define
[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define
[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define
[
0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel
0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel
] jit-word-jump jit-define
[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define
[
3 ds-reg 0 LWZ
@ -68,11 +70,8 @@ CONSTANT: rs-reg 30
0 3 \ f tag-number CMPI
2 BEQ
0 B rc-relative-ppc-3 rt-xt jit-rel
] jit-if-1 jit-define
[
0 B rc-relative-ppc-3 rt-xt jit-rel
] jit-if-2 jit-define
] jit-if jit-define
: jit->r ( -- )
4 ds-reg 0 LWZ
@ -138,6 +137,16 @@ CONSTANT: rs-reg 30
jit-3r>
] jit-3dip jit-define
: prepare-(execute) ( -- operand )
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 3 word-xt-offset LWZ
4 ;
[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define
[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define
[
0 1 lr-save stack-frame + LWZ
1 1 stack-frame ADDI
@ -146,7 +155,99 @@ CONSTANT: rs-reg 30
[ BLR ] jit-return jit-define
! Sub-primitives
! ! ! Polymorphic inline caches
! Don't touch r6 here; it's used to pass the tail call site
! address for tail PICs
! Load a value from a stack position
[
4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel
] pic-load jit-define
! Tag
: load-tag ( -- )
4 4 tag-mask get ANDI
4 4 tag-bits get SLWI ;
[ load-tag ] pic-tag jit-define
! Hi-tag
[
3 4 MR
load-tag
0 4 object tag-number tag-fixnum CMPI
2 BNE
4 3 object tag-number neg LWZ
] pic-hi-tag jit-define
! Tuple
[
3 4 MR
load-tag
0 4 tuple tag-number tag-fixnum CMPI
2 BNE
4 3 tuple tag-number neg bootstrap-cell + LWZ
] pic-tuple jit-define
! Hi-tag and tuple
[
3 4 MR
load-tag
! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple)
0 4 BIN: 110 tag-fixnum CMPI
5 BLT
! Untag r3
3 3 0 0 31 tag-bits get - RLWINM
! Set r4 to 0 for objects, and bootstrap-cell for tuples
4 4 1 tag-fixnum ANDI
4 4 1 SRAWI
! Load header cell or tuple layout cell
4 4 3 LWZX
] pic-hi-tag-tuple jit-define
[
0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel
] pic-check-tag jit-define
[
0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
4 0 5 CMP
] pic-check jit-define
[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define
! ! ! Megamorphic caches
[
! cache = ...
0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel
! key = class
5 4 MR
! key &= cache.length - 1
5 5 mega-cache-size get 1- bootstrap-cell * ANDI
! cache += array-start-offset
3 3 array-start-offset ADDI
! cache += key
3 3 5 ADD
! if(get(cache) == class)
6 3 0 LWZ
6 0 4 CMP
10 BNE
! megamorphic_cache_hits++
0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel
5 4 0 LWZ
5 5 1 ADDI
5 4 0 STW
! ... goto get(cache + bootstrap-cell)
3 3 4 LWZ
3 3 word-xt-offset LWZ
3 MTCTR
BCTR
! fall-through on miss
] mega-lookup jit-define
! ! ! Sub-primitives
! Quotations and words
[
@ -157,14 +258,6 @@ CONSTANT: rs-reg 30
BCTR
] \ (call) define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg dup 4 SUBI
4 3 word-xt-offset LWZ
4 MTCTR
BCTR
] \ (execute) define-sub-primitive
! Objects
[
3 ds-reg 0 LWZ

54
basis/cpu/ppc/ppc.factor
View File

@ -1,33 +1,39 @@
! 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 ;
@ -40,8 +46,8 @@ M: ppc %load-reference ( reg obj -- )
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 )
@ -108,7 +114,12 @@ M: ppc stack-frame-size ( stack-frame -- i )
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 ;
@ -120,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- )
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
@ -641,10 +652,10 @@ M: ppc %alien-callback ( quot -- )
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
@ -702,3 +713,4 @@ USE: vocabs.loader
} cond
"complex-double" c-type t >>return-in-registers? drop
"bool" c-type 4 >>size 4 >>align drop

6
basis/cpu/x86/32/32.factor
View File

@ -42,11 +42,13 @@ M:: x86.32 %dispatch ( src temp offset -- )
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

8
basis/cpu/x86/32/bootstrap.factor
View File

@ -1,4 +1,4 @@
! 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 ;
@ -26,10 +26,8 @@ IN: bootstrap.x86
temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel
! save stack pointer
temp0 [] stack-reg MOV
] jit-save-stack jit-define
[
(JMP) drop rc-relative rt-primitive jit-rel
! call the primitive
0 JMP rc-relative rt-primitive jit-rel
] jit-primitive jit-define
<< "vocab:cpu/x86/bootstrap.factor" parse-file parsed >>

2
basis/cpu/x86/64/64.factor
View File

@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ;
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 ;

5
basis/cpu/x86/64/bootstrap.factor
View File

@ -1,4 +1,4 @@
! 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 ;
@ -25,9 +25,6 @@ IN: bootstrap.x86
temp0 temp0 [] MOV
! save stack pointer
temp0 [] stack-reg MOV
] jit-save-stack jit-define
[
! load XT
temp1 0 MOV rc-absolute-cell rt-primitive jit-rel
! go

30
basis/cpu/x86/assembler/assembler.factor
View File

@ -1,12 +1,11 @@
! 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.
@ -296,36 +295,23 @@ M: operand (MOV-I)
{ 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-direct ;
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) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ;
M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ;
M: integer JUMPcc (JUMPcc) drop ;
M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ;
M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ;
M: integer JUMPcc extended-opcode, 4, ;
: JO ( dst -- ) HEX: 80 JUMPcc ;
: JNO ( dst -- ) HEX: 81 JUMPcc ;

44
basis/cpu/x86/bootstrap.factor
View File

@ -42,13 +42,18 @@ big-endian off
] jit-push-immediate jit-define
[
f JMP rc-relative rt-xt jit-rel
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 CALL rc-relative rt-xt-direct jit-rel
0 CALL rc-relative rt-xt-pic jit-rel
] jit-word-call jit-define
[
0 JMP rc-relative rt-xt jit-rel
] jit-word-special jit-define
[
! load boolean
temp0 ds-reg [] MOV
@ -57,13 +62,10 @@ big-endian off
! compare boolean with f
temp0 \ f tag-number CMP
! jump to true branch if not equal
f JNE rc-relative rt-xt jit-rel
] 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 jit-rel
] jit-if-2 jit-define
0 JMP rc-relative rt-xt jit-rel
] jit-if jit-define
: jit->r ( -- )
rs-reg bootstrap-cell ADD
@ -115,19 +117,19 @@ big-endian off
[
jit->r
f CALL rc-relative rt-xt jit-rel
0 CALL rc-relative rt-xt jit-rel
jit-r>
] jit-dip jit-define
[
jit-2>r
f CALL rc-relative rt-xt jit-rel
0 CALL rc-relative rt-xt jit-rel
jit-2r>
] jit-2dip jit-define
[
jit-3>r
f CALL rc-relative rt-xt jit-rel
0 CALL rc-relative rt-xt jit-rel
jit-3r>
] jit-3dip jit-define
@ -152,8 +154,7 @@ big-endian off
! ! ! Polymorphic inline caches
! temp0 contains the object being dispatched on
! temp1 contains its class
! The PIC and megamorphic code stubs are not permitted to touch temp3.
! Load a value from a stack position
[
@ -197,7 +198,7 @@ big-endian off
[
! Untag temp0
temp0 tag-mask get bitnot AND
! Set temp1 to 0 for objects, and 8 for tuples
! 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
@ -214,7 +215,7 @@ big-endian off
temp1 temp2 CMP
] pic-check jit-define
[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define
[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define
! ! ! Megamorphic caches
@ -232,12 +233,13 @@ big-endian off
temp0 temp2 ADD
! if(get(cache) == class)
temp0 [] temp1 CMP
! ... goto get(cache + bootstrap-cell)
[
temp0 temp0 bootstrap-cell [+] MOV
temp0 word-xt-offset [+] JMP
] [ ] make
[ length JNE ] [ % ] bi
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

20
basis/cpu/x86/x86.factor
View File

@ -11,6 +11,10 @@ IN: cpu.x86
<< 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 )
@ -19,6 +23,8 @@ HOOK: temp-reg-2 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 ;
@ -53,8 +59,18 @@ M: x86 stack-frame-size ( stack-frame -- i )
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 )

24
basis/debugger/debugger.factor
View File

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

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

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

10
basis/editors/editors.factor
View File

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

20
basis/formatting/formatting.factor
View File

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

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

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

20
basis/functors/functors.factor
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

69
basis/images/tiff/tiff.factor
View File

@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io
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 ;
@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation
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
@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ;
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 )
@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ;
{ 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 ] }
@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ;
{ 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 ] }
@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ;
[ 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 ;
@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ;
] 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 )

4
basis/io/backend/windows/privileges/privileges-tests.factor Executable file
View File

@ -0,0 +1,4 @@
IN: io.backend.windows.privileges.tests
USING: io.backend.windows.privileges tools.test ;
[ [ ] with-privileges ] must-infer

9
basis/io/backend/windows/privileges/privileges.factor Normal file → Executable file
View File

@ -1,12 +1,13 @@
USING: io.backend kernel continuations sequences
system vocabs.loader combinators ;
system vocabs.loader combinators fry ;
IN: io.backend.windows.privileges
HOOK: set-privilege io-backend ( name ? -- ) inline
HOOK: set-privilege io-backend ( name ? -- )
: with-privileges ( seq quot -- )
over [ [ t set-privilege ] each ] curry compose
swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline
[ '[ _ [ t set-privilege ] each @ ] ]
[ drop '[ _ [ f set-privilege ] each ] ]
2bi [ ] cleanup ; inline
{
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }

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

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

3
basis/io/files/unique/unique.factor
View File

@ -35,6 +35,9 @@ SYMBOL: unique-retries
: 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

12
basis/io/launcher/windows/nt/nt-tests.factor
View File

@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests
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 )
@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests
<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
@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests
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 =
@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests
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 =
@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests
<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
@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests
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" =

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

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

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

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

@ -21,7 +21,7 @@ CONSTANT: five 5
USING: kernel literals prettyprint ;
IN: scratchpad
<< : seven-eleven ( -- a b ) 7 11 ; >>
: seven-eleven ( -- a b ) 7 11 ;
{ $ seven-eleven } .
"> "{ 7 11 }" }
@ -43,7 +43,24 @@ IN: scratchpad
} ;
{ POSTPONE: $ POSTPONE: $[ } related-words
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."
@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values"
USING: kernel literals math prettyprint ;
IN: scratchpad
<< CONSTANT: five 5 >>
CONSTANT: five 5
{ $ five $[ five dup 1+ dup 2 + ] } .
"> "{ 5 5 6 8 }" }
{ $subsection POSTPONE: $ }
{ $subsection POSTPONE: $[ }
{ $subsection POSTPONE: ${ }
;
ABOUT: "literals"

8
extra/literals/literals-tests.factor → basis/literals/literals-tests.factor Normal file → Executable file
View File

@ -19,3 +19,11 @@ IN: literals.tests
[ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
CONSTANT: constant-a 3
[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test
: sixty-nine ( -- a b ) 6 9 ;
[ { 6 9 } ] [ ${ sixty-nine } ] unit-test

21
basis/literals/literals.factor Executable file
View File

@ -0,0 +1,21 @@
! (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 ;

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

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

2
basis/math/bits/bits.factor
View File

@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ;
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>> ;

12
basis/math/bitwise/bitwise.factor
View File

@ -13,10 +13,10 @@ IN: math.bitwise
: 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 )
@ -64,8 +64,8 @@ DEFER: byte-bit-count
<<
\ 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
@ -97,12 +97,12 @@ PRIVATE>
! 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 ;

2
basis/math/blas/vectors/vectors.factor
View File

@ -164,7 +164,7 @@ M: VECTOR element-type
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> ;

70
basis/math/combinatorics/combinatorics-docs.factor
View File

@ -1,37 +1,93 @@
USING: help.markup help.syntax kernel math math.order sequences ;
USING: help.markup help.syntax kernel math math.order multiline sequences ;
IN: math.combinatorics
HELP: factorial
{ $values { "n" "a non-negative integer" } { "n!" integer } }
{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"4 factorial ." "24" }
} ;
HELP: nPk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"10 4 nPk ." "5040" }
} ;
HELP: nCk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"10 4 nCk ." "210" }
} ;
HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"1 3 permutation ." "{ 0 2 1 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" }
} ;
HELP: all-permutations
{ $values { "seq" sequence } { "seq" sequence } }
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
} ;
HELP: each-permutation
{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } }
{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ;
HELP: inverse-permutation
{ $values { "seq" sequence } { "permutation" sequence } }
{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" }
} ;
HELP: combination
{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." }
{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." }
{ $examples
{ $example "USING: math.combinatorics sequences prettyprint ;"
"6 7 iota 4 combination ." "{ 0 1 3 6 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" }
} ;
HELP: all-combinations
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." }
{ $examples
{ $example "USING: math.combinatorics prettyprint ;"
"{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ."
<" {
{ "a" "b" }
{ "a" "c" }
{ "a" "d" }
{ "b" "c" }
{ "b" "d" }
{ "c" "d" }
}"> } } ;
HELP: each-combination
{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } }
{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ;
IN: math.combinatorics.private

53
basis/math/combinatorics/combinatorics-tests.factor
View File

@ -1,18 +1,6 @@
USING: math.combinatorics math.combinatorics.private tools.test ;
USING: math.combinatorics math.combinatorics.private tools.test sequences ;
IN: math.combinatorics.tests
[ { } ] [ 0 factoradic ] unit-test
[ { 1 0 } ] [ 1 factoradic ] unit-test
[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
[ 1 ] [ 0 factorial ] unit-test
[ 1 ] [ 1 factorial ] unit-test
[ 3628800 ] [ 10 factorial ] unit-test
@ -31,6 +19,19 @@ IN: math.combinatorics.tests
[ 2598960 ] [ 52 5 nCk ] unit-test
[ 2598960 ] [ 52 47 nCk ] unit-test
[ { } ] [ 0 factoradic ] unit-test
[ { 1 0 } ] [ 1 factoradic ] unit-test
[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test
[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test
[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
@ -43,3 +44,29 @@ IN: math.combinatorics.tests
[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
[ 2598960 ] [ 52 iota 5 <combo> choose ] unit-test
[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test
[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test
[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test
[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test
[ 9 ] [ 0 5 iota 3 <combo> dual-index ] unit-test
[ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
[ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
[ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
[ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
[ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test
[ { 0 1 2 } ] [ 0 5 iota 3 <combo> combination-indices ] unit-test
[ { 2 3 4 } ] [ 9 5 iota 3 <combo> combination-indices ] unit-test
[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
[ { { "a" "b" } { "a" "c" }
{ "a" "d" } { "b" "c" }
{ "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test

106
basis/math/combinatorics/combinatorics.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math math.order math.ranges mirrors
namespaces sequences sorting fry ;
USING: accessors assocs binary-search fry kernel locals math math.order
math.ranges mirrors namespaces sequences sorting ;
IN: math.combinatorics
<PRIVATE
@ -12,14 +12,27 @@ IN: math.combinatorics
: twiddle ( n k -- n k )
2dup - dupd > [ dupd - ] when ; inline
! See this article for explanation of the factoradic-based permutation methodology:
! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
PRIVATE>
: factorial ( n -- n! )
1 [ 1 + * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
: nCk ( n k -- nCk )
twiddle [ nPk ] keep factorial / ;
! Factoradic-based permutation methodology
<PRIVATE
: factoradic ( n -- factoradic )
0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ;
0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
[ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
[ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
@ -29,27 +42,84 @@ IN: math.combinatorics
PRIVATE>
: factorial ( n -- n! )
1 [ 1+ * ] reduce ;
: nPk ( n k -- nPk )
2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
: nCk ( n k -- nCk )
twiddle [ nPk ] keep factorial / ;
: permutation ( n seq -- seq )
[ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq )
[ length factorial ] keep '[ _ permutation ] map ;
[ length factorial ] keep
'[ _ permutation ] map ;
: each-permutation ( seq quot -- )
[ [ length factorial ] keep ] dip
'[ _ permutation @ ] each ; inline
: reduce-permutations ( seq initial quot -- result )
: reduce-permutations ( seq identity quot -- result )
swapd each-permutation ; inline
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;
! Combinadic-based combination methodology
<PRIVATE
TUPLE: combo
{ seq sequence }
{ k integer } ;
C: <combo> combo
: choose ( combo -- nCk )
[ seq>> length ] [ k>> ] bi nCk ;
: largest-value ( a b x -- v )
dup 0 = [
drop 1 - nip
] [
[ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip
] if ;
:: next-values ( a b x -- a' b' x' v )
a b x largest-value dup :> v ! a'
b 1 - ! b'
x v b nCk - ! x'
v ; ! v == a'
: dual-index ( m combo -- m' )
choose 1 - swap - ;
: initial-values ( combo m -- n k m )
[ [ seq>> length ] [ k>> ] bi ] dip ;
: combinadic ( combo m -- combinadic )
initial-values [ over 0 > ] [ next-values ] produce
[ 3drop ] dip ;
: combination-indices ( m combo -- seq )
[ tuck dual-index combinadic ] keep
seq>> length 1 - swap [ - ] with map ;
: apply-combination ( m combo -- seq )
[ combination-indices ] keep seq>> nths ;
PRIVATE>
: combination ( m seq k -- seq )
<combo> apply-combination ;
: all-combinations ( seq k -- seq )
<combo> [ choose [0,b) ] keep
'[ _ apply-combination ] map ;
: each-combination ( seq k quot -- )
[ <combo> [ choose [0,b) ] keep ] dip
'[ _ apply-combination @ ] each ; inline
: map-combinations ( seq k quot -- )
[ <combo> [ choose [0,b) ] keep ] dip
'[ _ apply-combination @ ] map ; inline
: reduce-combinations ( seq k identity quot -- result )
[ -rot ] dip each-combination ; inline

1
basis/math/constants/constants.factor
View File

@ -7,6 +7,7 @@ IN: math.constants
: 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

5
basis/math/functions/functions-tests.factor
View File

@ -157,3 +157,8 @@ IN: math.functions.tests
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

15
basis/math/functions/functions.factor
View File

@ -18,12 +18,12 @@ M: real sqrt
: 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
@ -216,17 +216,17 @@ M: real tanh ftanh ;
: 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
@ -259,6 +259,9 @@ M: real atan fatan ;
: 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

12
basis/math/intervals/intervals.factor
View File

@ -48,6 +48,8 @@ TUPLE: interval { from read-only } { to read-only } ;
: (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 -- ? )
@ -262,7 +264,7 @@ TUPLE: interval { from read-only } { to read-only } ;
: 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 ;
@ -376,11 +378,11 @@ SYMBOL: incomparable
: 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 ;
@ -407,7 +409,7 @@ SYMBOL: incomparable
: 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 ;

100
basis/math/miller-rabin/miller-rabin-docs.factor Normal file
View File

@ -0,0 +1,100 @@
! 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"

22
basis/math/miller-rabin/miller-rabin-tests.factor
View File

@ -1,4 +1,5 @@
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
@ -6,6 +7,23 @@ IN: math.miller-rabin.tests
[ 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
[ 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

90
basis/math/miller-rabin/miller-rabin.factor
View File

@ -1,37 +1,38 @@
! Copyright (C) 2008 Doug Coleman.
! Copyright (c) 2008-2009 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
: >odd ( n -- int ) 0 set-bit ; foldable
: >even ( n -- int ) 0 clear-bit ; foldable
: next-even ( m -- n ) >even 2 + ;
: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
<PRIVATE
: >odd ( n -- int ) dup even? [ 1+ ] when ; foldable
TUPLE: positive-even-expected n ;
:: (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 ] }
@ -42,11 +43,21 @@ PRIVATE>
: 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 ;
@ -74,3 +85,30 @@ ERROR: too-few-primes ;
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 ;

6
basis/math/polynomials/polynomials.factor
View File

@ -16,7 +16,7 @@ IN: math.polynomials
PRIVATE>
: powers ( n x -- seq )
<array> 1 [ * ] accumulate nip ;
<repetition> 1 [ * ] accumulate nip ;
: p= ( p q -- ? ) pextend = ;
@ -29,7 +29,7 @@ PRIVATE>
: 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
@ -44,7 +44,7 @@ PRIVATE>
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

2
basis/math/ranges/ranges.factor
View File

@ -10,7 +10,7 @@ TUPLE: range
{ 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>> ;

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

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

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

@ -1,12 +1,18 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays sequences math math.vectors accessors ;
USING: kernel arrays sequences math math.vectors accessors
parser prettyprint.custom prettyprint.backend ;
IN: math.rectangles
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
: <rect> ( loc dim -- rect ) rect boa ; inline
SYNTAX: RECT: scan-object scan-object <rect> parsed ;
M: rect pprint*
\ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
: <zero-rect> ( -- rect ) rect new ; inline
: point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
@ -15,6 +21,8 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
: with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
[ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
@ -55,4 +63,4 @@ M: rect contains-point?
: set-rect-bounds ( rect1 rect -- )
[ [ loc>> ] dip (>>loc) ]
[ [ dim>> ] dip (>>dim) ]
2bi ; inline
2bi ; inline

6
basis/math/statistics/statistics.factor
View File

@ -15,7 +15,7 @@ IN: math.statistics
: 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 ;
@ -33,7 +33,7 @@ IN: math.statistics
drop 0
] [
[ [ mean ] keep [ - sq ] with sigma ] keep
length 1- /
length 1 - /
] if ;
: std ( seq -- x )
@ -47,7 +47,7 @@ IN: math.statistics
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
basis/math/vectors/vectors-tests.factor
View File

@ -9,3 +9,8 @@ USING: math.vectors tools.test ;
[ 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

18
basis/math/vectors/vectors.factor
View File

@ -6,6 +6,11 @@ IN: math.vectors
: 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 ;
@ -19,6 +24,10 @@ IN: math.vectors
: 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 ;
@ -32,6 +41,12 @@ IN: math.vectors
: 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 } ;
@ -50,3 +65,6 @@ HINTS: v/ { array array } ;
HINTS: vmax { array array } ;
HINTS: vmin { array array } ;
HINTS: v. { array array } ;
HINTS: vlerp { array array array } ;
HINTS: vnlerp { array array object } ;

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

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

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

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

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