Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
35575972e3
|
|
@ -25,3 +25,5 @@ build-support/wordsize
|
|||
.#*
|
||||
*.swo
|
||||
checksums.txt
|
||||
*.so
|
||||
a.out
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
CC = gcc
|
||||
CPP = g++
|
||||
AR = ar
|
||||
LD = ld
|
||||
|
||||
|
|
@ -7,18 +8,18 @@ CONSOLE_EXECUTABLE = factor-console
|
|||
TEST_LIBRARY = factor-ffi-test
|
||||
VERSION = 0.92
|
||||
|
||||
IMAGE = factor.image
|
||||
BUNDLE = Factor.app
|
||||
LIBPATH = -L/usr/X11R6/lib
|
||||
CFLAGS = -Wall
|
||||
FFI_TEST_CFLAGS = -fPIC
|
||||
|
||||
ifdef DEBUG
|
||||
CFLAGS += -g
|
||||
CFLAGS += -g -DFACTOR_DEBUG
|
||||
else
|
||||
CFLAGS += -O3 $(SITE_CFLAGS)
|
||||
CFLAGS += -O3
|
||||
endif
|
||||
|
||||
CFLAGS += $(SITE_CFLAGS)
|
||||
|
||||
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
|
||||
|
||||
ifdef CONFIG
|
||||
|
|
@ -27,25 +28,36 @@ endif
|
|||
|
||||
DLL_OBJS = $(PLAF_DLL_OBJS) \
|
||||
vm/alien.o \
|
||||
vm/arrays.o \
|
||||
vm/bignum.o \
|
||||
vm/booleans.o \
|
||||
vm/byte_arrays.o \
|
||||
vm/callstack.o \
|
||||
vm/code_block.o \
|
||||
vm/code_gc.o \
|
||||
vm/code_heap.o \
|
||||
vm/contexts.o \
|
||||
vm/data_gc.o \
|
||||
vm/data_heap.o \
|
||||
vm/debug.o \
|
||||
vm/dispatch.o \
|
||||
vm/errors.o \
|
||||
vm/factor.o \
|
||||
vm/image.o \
|
||||
vm/inline_cache.o \
|
||||
vm/io.o \
|
||||
vm/jit.o \
|
||||
vm/local_roots.o \
|
||||
vm/math.o \
|
||||
vm/primitives.o \
|
||||
vm/profiler.o \
|
||||
vm/quotations.o \
|
||||
vm/run.o \
|
||||
vm/types.o \
|
||||
vm/utilities.o
|
||||
vm/strings.o \
|
||||
vm/tuples.o \
|
||||
vm/utilities.o \
|
||||
vm/words.o \
|
||||
vm/write_barrier.o
|
||||
|
||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||
|
||||
|
|
@ -151,22 +163,28 @@ macosx.app: factor
|
|||
@executable_path/../Frameworks/libfactor.dylib \
|
||||
Factor.app/Contents/MacOS/factor
|
||||
|
||||
factor: $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
factor-console: $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
factor-ffi-test: vm/ffi_test.o
|
||||
$(TEST_LIBRARY): vm/ffi_test.o
|
||||
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
|
||||
|
||||
clean:
|
||||
rm -f vm/*.o
|
||||
rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib}
|
||||
rm -f factor.dll
|
||||
rm -f libfactor.*
|
||||
rm -f libfactor-ffi-test.*
|
||||
rm -f Factor.app/Contents/Frameworks/libfactor.dylib
|
||||
|
||||
tags:
|
||||
etags vm/*.{cpp,hpp,mm,S,c}
|
||||
|
||||
vm/resources.o:
|
||||
$(WINDRES) vm/factor.rs vm/resources.o
|
||||
|
|
@ -177,10 +195,15 @@ vm/ffi_test.o: vm/ffi_test.c
|
|||
.c.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.cpp.o:
|
||||
$(CPP) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.S.o:
|
||||
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.m.o:
|
||||
$(CC) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.PHONY: factor
|
||||
.mm.o:
|
||||
$(CPP) -c $(CFLAGS) -o $@ $<
|
||||
|
||||
.PHONY: factor tags clean
|
||||
|
||||
.SUFFIXES: .mm
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ implementation. It is not an introduction to the language itself.
|
|||
|
||||
* Compiling the Factor VM
|
||||
|
||||
The Factor runtime is written in GNU C99, and is built with GNU make and
|
||||
The Factor runtime is written in GNU C++, and is built with GNU make and
|
||||
gcc.
|
||||
|
||||
Factor supports various platforms. For an up-to-date list, see
|
||||
|
|
@ -59,10 +59,10 @@ On Unix, Factor can either run a graphical user interface using X11, or
|
|||
a terminal listener.
|
||||
|
||||
For X11 support, you need recent development libraries for libc,
|
||||
Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
|
||||
Pango, X11, and OpenGL. On a Debian-derived Linux distribution
|
||||
(like Ubuntu), you can use the following line to grab everything:
|
||||
|
||||
sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
|
||||
sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev
|
||||
|
||||
If your DISPLAY environment variable is set, the UI will start
|
||||
automatically:
|
||||
|
|
@ -138,7 +138,7 @@ usage documentation, enter the following in the UI listener:
|
|||
The Factor source tree is organized as follows:
|
||||
|
||||
build-support/ - scripts used for compiling Factor
|
||||
vm/ - sources for the Factor VM, written in C
|
||||
vm/ - sources for the Factor VM, written in C++
|
||||
core/ - Factor core library
|
||||
basis/ - Factor basis library, compiler, tools
|
||||
extra/ - more libraries and applications
|
||||
|
|
|
|||
|
|
@ -15,5 +15,3 @@ tools.test threads concurrency.count-downs ;
|
|||
[ resume ] curry instant later drop
|
||||
] "test" suspend drop
|
||||
] unit-test
|
||||
|
||||
\ alarm-thread-loop must-infer
|
||||
|
|
|
|||
|
|
@ -71,7 +71,7 @@ ERROR: bad-alarm-frequency frequency ;
|
|||
] when* ;
|
||||
|
||||
: init-alarms ( -- )
|
||||
alarms global [ cancel-alarms <min-heap> ] change-at
|
||||
alarms [ cancel-alarms <min-heap> ] change-global
|
||||
[ alarm-thread-loop t ] "Alarms" spawn-server
|
||||
alarm-thread set-global ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -2,8 +2,6 @@ IN: alien.c-types.tests
|
|||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc alien.strings io.encodings.utf8 ;
|
||||
|
||||
\ expand-constants must-infer
|
||||
|
||||
CONSTANT: xyz 123
|
||||
|
||||
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,9 +2,10 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays arrays assocs kernel kernel.private libc math
|
||||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations fry classes ;
|
||||
math.parser cpu.architecture alien alien.accessors alien.strings
|
||||
quotations layouts system compiler.units io io.files
|
||||
io.encodings.binary io.streams.memory accessors combinators effects
|
||||
continuations fry classes ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -213,6 +214,15 @@ M: f byte-length drop 0 ;
|
|||
: memory>byte-array ( alien len -- byte-array )
|
||||
[ nip (byte-array) dup ] 2keep memcpy ;
|
||||
|
||||
: malloc-string ( string encoding -- alien )
|
||||
string>alien malloc-byte-array ;
|
||||
|
||||
M: memory-stream stream-read
|
||||
[
|
||||
[ index>> ] [ alien>> ] bi <displaced-alien>
|
||||
swap memory>byte-array
|
||||
] [ [ + ] change-index drop ] 2bi ;
|
||||
|
||||
: byte-array>memory ( byte-array base -- )
|
||||
swap dup byte-length memcpy ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ io.encodings.ascii io.encodings.string shuffle effects math.ranges
|
|||
math.order sorting strings system alien.libraries ;
|
||||
IN: alien.fortran
|
||||
|
||||
SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;
|
||||
SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
|
||||
|
||||
<<
|
||||
: add-f2c-libraries ( -- )
|
||||
|
|
@ -42,30 +42,35 @@ library-fortran-abis [ H{ } clone ] initialize
|
|||
|
||||
HOOK: fortran-c-abi fortran-abi ( -- abi )
|
||||
M: f2c-abi fortran-c-abi "cdecl" ;
|
||||
M: g95-abi fortran-c-abi "cdecl" ;
|
||||
M: gfortran-abi fortran-c-abi "cdecl" ;
|
||||
M: intel-unix-abi fortran-c-abi "cdecl" ;
|
||||
M: intel-windows-abi fortran-c-abi "cdecl" ;
|
||||
|
||||
HOOK: real-functions-return-double? fortran-abi ( -- ? )
|
||||
M: f2c-abi real-functions-return-double? t ;
|
||||
M: g95-abi real-functions-return-double? f ;
|
||||
M: gfortran-abi real-functions-return-double? f ;
|
||||
M: intel-unix-abi real-functions-return-double? f ;
|
||||
M: intel-windows-abi real-functions-return-double? f ;
|
||||
|
||||
HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
|
||||
M: f2c-abi complex-functions-return-by-value? f ;
|
||||
M: g95-abi complex-functions-return-by-value? f ;
|
||||
M: gfortran-abi complex-functions-return-by-value? t ;
|
||||
M: intel-unix-abi complex-functions-return-by-value? f ;
|
||||
M: intel-windows-abi complex-functions-return-by-value? f ;
|
||||
|
||||
HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
|
||||
M: f2c-abi character(1)-maps-to-char? f ;
|
||||
M: g95-abi character(1)-maps-to-char? f ;
|
||||
M: gfortran-abi character(1)-maps-to-char? f ;
|
||||
M: intel-unix-abi character(1)-maps-to-char? t ;
|
||||
M: intel-windows-abi character(1)-maps-to-char? t ;
|
||||
|
||||
HOOK: mangle-name fortran-abi ( name -- name' )
|
||||
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
|
||||
M: g95-abi mangle-name lowercase-name-with-extra-underscore ;
|
||||
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
|
||||
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
|
||||
M: intel-windows-abi mangle-name >upper ;
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ HELP: libraries
|
|||
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
|
||||
|
||||
HELP: library
|
||||
{ $values { "name" "a string" } { "library" "a hashtable" } }
|
||||
{ $values { "name" "a string" } { "library" assoc } }
|
||||
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
|
||||
{ $list
|
||||
{ { $snippet "name" } " - the full path of the C library binary" }
|
||||
|
|
@ -58,3 +58,10 @@ $nl
|
|||
"} cond >>"
|
||||
}
|
||||
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
|
||||
|
||||
ARTICLE: "loading-libs" "Loading native libraries"
|
||||
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
|
||||
{ $subsection add-library }
|
||||
"Once a library has been defined, you can try loading it to see if the path name is correct:"
|
||||
{ $subsection load-library }
|
||||
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,12 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien assocs io.backend kernel namespaces ;
|
||||
USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
|
||||
IN: alien.libraries
|
||||
|
||||
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
|
||||
|
||||
: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
|
||||
|
||||
SYMBOL: libraries
|
||||
|
||||
libraries [ H{ } clone ] initialize
|
||||
|
|
@ -18,4 +22,4 @@ TUPLE: library path abi dll ;
|
|||
library dup [ dll>> ] when ;
|
||||
|
||||
: add-library ( name path abi -- )
|
||||
<library> swap libraries get set-at ;
|
||||
<library> swap libraries get set-at ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays assocs effects grouping kernel
|
||||
parser sequences splitting words fry locals ;
|
||||
parser sequences splitting words fry locals lexer namespaces ;
|
||||
IN: alien.parser
|
||||
|
||||
: parse-arglist ( parameters return -- types effect )
|
||||
|
|
@ -12,8 +12,15 @@ IN: alien.parser
|
|||
: function-quot ( return library function types -- quot )
|
||||
'[ _ _ _ _ alien-invoke ] ;
|
||||
|
||||
:: define-function ( return library function parameters -- )
|
||||
:: make-function ( return library function parameters -- word quot effect )
|
||||
function create-in dup reset-generic
|
||||
return library function
|
||||
parameters return parse-arglist [ function-quot ] dip
|
||||
define-declared ;
|
||||
parameters return parse-arglist [ function-quot ] dip ;
|
||||
|
||||
: (FUNCTION:) ( -- word quot effect )
|
||||
scan "c-library" get scan ";" parse-tokens
|
||||
[ "()" subseq? not ] filter
|
||||
make-function ;
|
||||
|
||||
: define-function ( return library function parameters -- )
|
||||
make-function define-declared ;
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ IN: alien.remote-control
|
|||
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
||||
|
||||
: ?callback ( word -- alien )
|
||||
dup optimized>> [ execute ] [ drop f ] if ; inline
|
||||
dup optimized? [ execute ] [ drop f ] if ; inline
|
||||
|
||||
: init-remote-control ( -- )
|
||||
\ eval-callback ?callback 16 setenv
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
@ -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 +0,0 @@
|
|||
Default string encoding on Unix
|
||||
|
|
@ -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 +0,0 @@
|
|||
Default string encoding on Windows
|
||||
|
|
@ -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
|
||||
|
|
@ -16,9 +16,7 @@ SYNTAX: BAD-ALIEN <bad-alien> parsed ;
|
|||
SYNTAX: LIBRARY: scan "c-library" set ;
|
||||
|
||||
SYNTAX: FUNCTION:
|
||||
scan "c-library" get scan ";" parse-tokens
|
||||
[ "()" subseq? not ] filter
|
||||
define-function ;
|
||||
(FUNCTION:) define-declared ;
|
||||
|
||||
SYNTAX: TYPEDEF:
|
||||
scan scan typedef ;
|
||||
|
|
|
|||
|
|
@ -23,5 +23,5 @@ IN: base64.tests
|
|||
ascii encode >base64-lines >string
|
||||
] unit-test
|
||||
|
||||
\ >base64 must-infer
|
||||
\ base64> must-infer
|
||||
[ { 33 52 17 40 12 51 33 43 18 33 23 } base64> ]
|
||||
[ malformed-base64? ] must-fail-with
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ io.streams.byte-array kernel math namespaces
|
|||
sequences strings io.crlf ;
|
||||
IN: base64
|
||||
|
||||
ERROR: malformed-base64 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: read1-ignoring ( ignoring -- ch )
|
||||
|
|
@ -25,7 +27,7 @@ IN: base64
|
|||
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
|
||||
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
|
||||
40 41 42 43 44 45 46 47 48 49 50 51
|
||||
} nth ; inline
|
||||
} nth [ malformed-base64 ] unless* ; inline
|
||||
|
||||
SYMBOL: column
|
||||
|
||||
|
|
@ -48,8 +50,6 @@ SYMBOL: column
|
|||
[ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
|
||||
[ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
|
||||
|
||||
ERROR: malformed-base64 ;
|
||||
|
||||
: decode4 ( seq -- )
|
||||
[ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
|
||||
[ [ CHAR: = = ] count ] bi head-slice*
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ $nl
|
|||
|
||||
HELP: sorted-index
|
||||
{ $values { "obj" object } { "seq" "a sorted sequence" } { "i" "an index, or " { $link f } } }
|
||||
{ $description "Outputs the index and value of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
|
||||
{ $description "Outputs the index of the element closest to " { $snippet "elt" } " in the sequence. See " { $link search } " for details." }
|
||||
{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link index } "." } ;
|
||||
|
||||
{ index index-from last-index last-index-from sorted-index } related-words
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
IN: binary-search.tests
|
||||
USING: binary-search math.order vectors kernel tools.test ;
|
||||
|
||||
\ sorted-member? must-infer
|
||||
|
||||
[ f ] [ 3 { } [ <=> ] with search drop ] unit-test
|
||||
[ 0 ] [ 3 { 3 } [ <=> ] with search drop ] unit-test
|
||||
[ 1 ] [ 2 { 1 2 3 } [ <=> ] with search drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ sequences namespaces parser kernel kernel.private classes
|
|||
classes.private arrays hashtables vectors classes.tuple sbufs
|
||||
hashtables.private sequences.private math classes.tuple.private
|
||||
growable namespaces.private assocs words command-line vocabs io
|
||||
io.encodings.string libc splitting math.parser
|
||||
io.encodings.string libc splitting math.parser memory
|
||||
compiler.units math.order compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.optimizer ;
|
||||
IN: bootstrap.compiler
|
||||
|
|
@ -23,10 +23,13 @@ IN: bootstrap.compiler
|
|||
|
||||
"cpu." cpu name>> append require
|
||||
|
||||
enable-compiler
|
||||
enable-optimizer
|
||||
|
||||
! Push all tuple layouts to tenured space to improve method caching
|
||||
gc
|
||||
|
||||
: compile-unoptimized ( words -- )
|
||||
[ optimized>> not ] filter compile ;
|
||||
[ optimized? not ] filter compile ;
|
||||
|
||||
nl
|
||||
"Compiling..." write flush
|
||||
|
|
@ -108,7 +111,7 @@ nl
|
|||
|
||||
"." write flush
|
||||
|
||||
{ (compile) } compile-unoptimized
|
||||
{ compile-word } compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ;
|
|||
(command-line) parse-command-line
|
||||
load-vocab-roots
|
||||
run-user-init
|
||||
"e" get [ eval ] when*
|
||||
"e" get [ eval( -- ) ] when*
|
||||
ignore-cli-args? not script get and
|
||||
[ run-script ] [ "run" get run ] if*
|
||||
output-stream get [ stream-flush ] when*
|
||||
|
|
|
|||
|
|
@ -2,9 +2,6 @@ IN: bootstrap.image.tests
|
|||
USING: bootstrap.image bootstrap.image.private tools.test
|
||||
kernel math ;
|
||||
|
||||
\ ' must-infer
|
||||
\ write-image must-infer
|
||||
|
||||
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
|
||||
|
||||
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,14 +3,13 @@
|
|||
USING: alien arrays byte-arrays generic assocs hashtables assocs
|
||||
hashtables.private io io.binary io.files io.encodings.binary
|
||||
io.pathnames kernel kernel.private math namespaces make parser
|
||||
prettyprint sequences sequences.private strings sbufs
|
||||
vectors words quotations assocs system layouts splitting
|
||||
grouping growable classes classes.builtin classes.tuple
|
||||
classes.tuple.private words.private vocabs
|
||||
vocabs.loader source-files definitions debugger
|
||||
quotations.private sequences.private combinators
|
||||
math.order math.private accessors
|
||||
slots.private compiler.units fry ;
|
||||
prettyprint sequences sequences.private strings sbufs vectors words
|
||||
quotations assocs system layouts splitting grouping growable classes
|
||||
classes.builtin classes.tuple classes.tuple.private vocabs
|
||||
vocabs.loader source-files definitions debugger quotations.private
|
||||
sequences.private combinators math.order math.private accessors
|
||||
slots.private generic.single.private compiler.units compiler.constants
|
||||
fry ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: arch ( os cpu -- arch )
|
||||
|
|
@ -94,13 +93,30 @@ CONSTANT: -1-offset 9
|
|||
|
||||
SYMBOL: sub-primitives
|
||||
|
||||
: make-jit ( quot rc rt offset -- quad )
|
||||
[ [ call( -- ) ] { } make ] 3dip 4array ;
|
||||
SYMBOL: jit-define-rc
|
||||
SYMBOL: jit-define-rt
|
||||
SYMBOL: jit-define-offset
|
||||
|
||||
: jit-define ( quot rc rt offset name -- )
|
||||
: compute-offset ( -- offset )
|
||||
building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ;
|
||||
|
||||
: jit-rel ( rc rt -- )
|
||||
jit-define-rt set
|
||||
jit-define-rc set
|
||||
compute-offset jit-define-offset set ;
|
||||
|
||||
: make-jit ( quot -- quad )
|
||||
[
|
||||
call( -- )
|
||||
jit-define-rc get
|
||||
jit-define-rt get
|
||||
jit-define-offset get 3array
|
||||
] B{ } make prefix ;
|
||||
|
||||
: jit-define ( quot name -- )
|
||||
[ make-jit ] dip set ;
|
||||
|
||||
: define-sub-primitive ( quot rc rt offset word -- )
|
||||
: define-sub-primitive ( quot word -- )
|
||||
[ make-jit ] dip sub-primitives get set-at ;
|
||||
|
||||
! The image being constructed; a vector of word-size integers
|
||||
|
|
@ -119,7 +135,6 @@ SYMBOL: bootstrap-global
|
|||
SYMBOL: bootstrap-boot-quot
|
||||
|
||||
! JIT parameters
|
||||
SYMBOL: jit-code-format
|
||||
SYMBOL: jit-prolog
|
||||
SYMBOL: jit-primitive-word
|
||||
SYMBOL: jit-primitive
|
||||
|
|
@ -129,20 +144,36 @@ SYMBOL: jit-push-immediate
|
|||
SYMBOL: jit-if-word
|
||||
SYMBOL: jit-if-1
|
||||
SYMBOL: jit-if-2
|
||||
SYMBOL: jit-dispatch-word
|
||||
SYMBOL: jit-dispatch
|
||||
SYMBOL: jit-dip-word
|
||||
SYMBOL: jit-dip
|
||||
SYMBOL: jit-2dip-word
|
||||
SYMBOL: jit-2dip
|
||||
SYMBOL: jit-3dip-word
|
||||
SYMBOL: jit-3dip
|
||||
SYMBOL: jit-execute-word
|
||||
SYMBOL: jit-execute-jump
|
||||
SYMBOL: jit-execute-call
|
||||
SYMBOL: jit-epilog
|
||||
SYMBOL: jit-return
|
||||
SYMBOL: jit-profiling
|
||||
SYMBOL: jit-declare-word
|
||||
SYMBOL: jit-save-stack
|
||||
|
||||
! PIC stubs
|
||||
SYMBOL: pic-load
|
||||
SYMBOL: pic-tag
|
||||
SYMBOL: pic-hi-tag
|
||||
SYMBOL: pic-tuple
|
||||
SYMBOL: pic-hi-tag-tuple
|
||||
SYMBOL: pic-check-tag
|
||||
SYMBOL: pic-check
|
||||
SYMBOL: pic-hit
|
||||
SYMBOL: pic-miss-word
|
||||
|
||||
! Megamorphic dispatch
|
||||
SYMBOL: mega-lookup
|
||||
SYMBOL: mega-lookup-word
|
||||
SYMBOL: mega-miss-word
|
||||
|
||||
! Default definition for undefined words
|
||||
SYMBOL: undefined-quot
|
||||
|
||||
|
|
@ -150,7 +181,6 @@ SYMBOL: undefined-quot
|
|||
H{
|
||||
{ bootstrap-boot-quot 20 }
|
||||
{ bootstrap-global 21 }
|
||||
{ jit-code-format 22 }
|
||||
{ jit-prolog 23 }
|
||||
{ jit-primitive-word 24 }
|
||||
{ jit-primitive 25 }
|
||||
|
|
@ -159,20 +189,32 @@ SYMBOL: undefined-quot
|
|||
{ jit-if-word 28 }
|
||||
{ jit-if-1 29 }
|
||||
{ jit-if-2 30 }
|
||||
{ jit-dispatch-word 31 }
|
||||
{ jit-dispatch 32 }
|
||||
{ jit-epilog 33 }
|
||||
{ jit-return 34 }
|
||||
{ jit-profiling 35 }
|
||||
{ jit-push-immediate 36 }
|
||||
{ jit-declare-word 42 }
|
||||
{ jit-save-stack 43 }
|
||||
{ jit-dip-word 44 }
|
||||
{ jit-dip 45 }
|
||||
{ jit-2dip-word 46 }
|
||||
{ jit-2dip 47 }
|
||||
{ jit-3dip-word 48 }
|
||||
{ jit-3dip 49 }
|
||||
{ jit-save-stack 38 }
|
||||
{ jit-dip-word 39 }
|
||||
{ jit-dip 40 }
|
||||
{ jit-2dip-word 41 }
|
||||
{ jit-2dip 42 }
|
||||
{ jit-3dip-word 43 }
|
||||
{ jit-3dip 44 }
|
||||
{ jit-execute-word 45 }
|
||||
{ jit-execute-jump 46 }
|
||||
{ jit-execute-call 47 }
|
||||
{ pic-load 48 }
|
||||
{ pic-tag 49 }
|
||||
{ pic-hi-tag 50 }
|
||||
{ pic-tuple 51 }
|
||||
{ pic-hi-tag-tuple 52 }
|
||||
{ pic-check-tag 53 }
|
||||
{ pic-check 54 }
|
||||
{ pic-hit 55 }
|
||||
{ pic-miss-word 56 }
|
||||
{ mega-lookup 57 }
|
||||
{ mega-lookup-word 58 }
|
||||
{ mega-miss-word 59 }
|
||||
{ undefined-quot 60 }
|
||||
} ; inline
|
||||
|
||||
|
|
@ -205,8 +247,8 @@ SYMBOL: undefined-quot
|
|||
|
||||
: emit-fixnum ( n -- ) tag-fixnum emit ;
|
||||
|
||||
: emit-object ( header tag quot -- addr )
|
||||
swap here-as [ swap tag-fixnum emit call align-here ] dip ;
|
||||
: emit-object ( class quot -- addr )
|
||||
over tag-number here-as [ swap type-number tag-fixnum emit call align-here ] dip ;
|
||||
inline
|
||||
|
||||
! Write an object to the image.
|
||||
|
|
@ -251,7 +293,7 @@ GENERIC: ' ( obj -- ptr )
|
|||
|
||||
M: bignum '
|
||||
[
|
||||
bignum tag-number dup [ emit-bignum ] emit-object
|
||||
bignum [ emit-bignum ] emit-object
|
||||
] cache-object ;
|
||||
|
||||
! Fixnums
|
||||
|
|
@ -274,7 +316,7 @@ M: fake-bignum ' n>> tag-fixnum ;
|
|||
|
||||
M: float '
|
||||
[
|
||||
float tag-number dup [
|
||||
float [
|
||||
align-here double>bits emit-64
|
||||
] emit-object
|
||||
] cache-object ;
|
||||
|
|
@ -309,7 +351,7 @@ M: f '
|
|||
[ vocabulary>> , ]
|
||||
[ def>> , ]
|
||||
[ props>> , ]
|
||||
[ drop f , ]
|
||||
[ direct-entry-def>> , ] ! direct-entry-def
|
||||
[ drop 0 , ] ! count
|
||||
[ word-sub-primitive , ]
|
||||
[ drop 0 , ] ! xt
|
||||
|
|
@ -318,8 +360,7 @@ M: f '
|
|||
} cleave
|
||||
] { } make [ ' ] map
|
||||
] bi
|
||||
\ word type-number object tag-number
|
||||
[ emit-seq ] emit-object
|
||||
\ word [ emit-seq ] emit-object
|
||||
] keep put-object ;
|
||||
|
||||
: word-error ( word msg -- * )
|
||||
|
|
@ -340,8 +381,7 @@ M: word ' ;
|
|||
! Wrappers
|
||||
|
||||
M: wrapper '
|
||||
wrapped>> ' wrapper type-number object tag-number
|
||||
[ emit ] emit-object ;
|
||||
wrapped>> ' wrapper [ emit ] emit-object ;
|
||||
|
||||
! Strings
|
||||
: native> ( object -- object )
|
||||
|
|
@ -370,7 +410,7 @@ M: wrapper '
|
|||
|
||||
: emit-string ( string -- ptr )
|
||||
[ length ] [ extended-part ' ] [ ] tri
|
||||
string type-number object tag-number [
|
||||
string [
|
||||
[ emit-fixnum ]
|
||||
[ emit ]
|
||||
[ f ' emit ascii-part pad-bytes emit-bytes ]
|
||||
|
|
@ -387,12 +427,11 @@ M: string '
|
|||
|
||||
: emit-dummy-array ( obj type -- ptr )
|
||||
[ assert-empty ] [
|
||||
type-number object tag-number
|
||||
[ 0 emit-fixnum ] emit-object
|
||||
] bi* ;
|
||||
|
||||
M: byte-array '
|
||||
byte-array type-number object tag-number [
|
||||
byte-array [
|
||||
dup length emit-fixnum
|
||||
pad-bytes emit-bytes
|
||||
] emit-object ;
|
||||
|
|
@ -406,7 +445,7 @@ ERROR: tuple-removed class ;
|
|||
: (emit-tuple) ( tuple -- pointer )
|
||||
[ tuple-slots ]
|
||||
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map
|
||||
tuple type-number dup [ emit-seq ] emit-object ;
|
||||
tuple [ emit-seq ] emit-object ;
|
||||
|
||||
: emit-tuple ( tuple -- pointer )
|
||||
dup class name>> "tombstone" =
|
||||
|
|
@ -421,8 +460,7 @@ M: tombstone '
|
|||
|
||||
! Arrays
|
||||
: emit-array ( array -- offset )
|
||||
[ ' ] map array type-number object tag-number
|
||||
[ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
|
||||
[ ' ] map array [ [ length emit-fixnum ] [ emit-seq ] bi ] emit-object ;
|
||||
|
||||
M: array ' emit-array ;
|
||||
|
||||
|
|
@ -448,7 +486,7 @@ M: tuple-layout-array '
|
|||
M: quotation '
|
||||
[
|
||||
array>> '
|
||||
quotation type-number object tag-number [
|
||||
quotation [
|
||||
emit ! array
|
||||
f ' emit ! compiled
|
||||
f ' emit ! cached-effect
|
||||
|
|
@ -480,15 +518,16 @@ M: quotation '
|
|||
|
||||
: emit-jit-data ( -- )
|
||||
\ if jit-if-word set
|
||||
\ dispatch jit-dispatch-word set
|
||||
\ do-primitive jit-primitive-word set
|
||||
\ declare jit-declare-word set
|
||||
\ dip jit-dip-word set
|
||||
\ 2dip jit-2dip-word set
|
||||
\ 3dip jit-3dip-word set
|
||||
\ (execute) jit-execute-word set
|
||||
\ inline-cache-miss \ pic-miss-word set
|
||||
\ mega-cache-lookup \ mega-lookup-word set
|
||||
\ mega-cache-miss \ mega-miss-word set
|
||||
[ undefined ] undefined-quot set
|
||||
{
|
||||
jit-code-format
|
||||
jit-prolog
|
||||
jit-primitive-word
|
||||
jit-primitive
|
||||
|
|
@ -498,19 +537,31 @@ M: quotation '
|
|||
jit-if-word
|
||||
jit-if-1
|
||||
jit-if-2
|
||||
jit-dispatch-word
|
||||
jit-dispatch
|
||||
jit-dip-word
|
||||
jit-dip
|
||||
jit-2dip-word
|
||||
jit-2dip
|
||||
jit-3dip-word
|
||||
jit-3dip
|
||||
jit-execute-word
|
||||
jit-execute-jump
|
||||
jit-execute-call
|
||||
jit-epilog
|
||||
jit-return
|
||||
jit-profiling
|
||||
jit-declare-word
|
||||
jit-save-stack
|
||||
pic-load
|
||||
pic-tag
|
||||
pic-hi-tag
|
||||
pic-tuple
|
||||
pic-hi-tag-tuple
|
||||
pic-check-tag
|
||||
pic-check
|
||||
pic-hit
|
||||
pic-miss-word
|
||||
mega-lookup
|
||||
mega-lookup-word
|
||||
mega-miss-word
|
||||
undefined-quot
|
||||
} [ emit-userenv ] each ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors init namespaces words words.symbol io
|
|||
kernel.private math memory continuations kernel io.files
|
||||
io.pathnames io.backend system parser vocabs sequences
|
||||
vocabs.loader combinators splitting source-files strings
|
||||
definitions assocs compiler.errors compiler.units math.parser
|
||||
definitions assocs compiler.units math.parser
|
||||
generic sets command-line ;
|
||||
IN: bootstrap.stage2
|
||||
|
||||
|
|
@ -16,13 +16,6 @@ SYMBOL: bootstrap-time
|
|||
vm file-name os windows? [ "." split1-last drop ] when
|
||||
".image" append resource-path ;
|
||||
|
||||
: do-crossref ( -- )
|
||||
"Cross-referencing..." print flush
|
||||
H{ } clone crossref set-global
|
||||
xref-words
|
||||
xref-generics
|
||||
xref-sources ;
|
||||
|
||||
: load-components ( -- )
|
||||
"include" "exclude"
|
||||
[ get-global " " split harvest ] bi@
|
||||
|
|
@ -42,14 +35,17 @@ SYMBOL: bootstrap-time
|
|||
"Core bootstrap completed in " write core-bootstrap-time get print-time
|
||||
"Bootstrap completed in " write bootstrap-time get print-time
|
||||
|
||||
[ optimized>> ] count-words " compiled words" print
|
||||
[ symbol? ] count-words " symbol words" print
|
||||
[ ] count-words " words total" print
|
||||
|
||||
"Bootstrapping is complete." print
|
||||
"Now, you can run Factor:" print
|
||||
vm write " -i=" write "output-image" get print flush ;
|
||||
|
||||
: save/restore-error ( quot -- )
|
||||
error get-global
|
||||
error-continuation get-global
|
||||
[ call ] 2dip
|
||||
error-continuation set-global
|
||||
error set-global ; inline
|
||||
|
||||
[
|
||||
! We time bootstrap
|
||||
millis
|
||||
|
|
@ -61,8 +57,6 @@ SYMBOL: bootstrap-time
|
|||
|
||||
(command-line) parse-command-line
|
||||
|
||||
do-crossref
|
||||
|
||||
! Set dll paths
|
||||
os wince? [ "windows.ce" require ] when
|
||||
os winnt? [ "windows.nt" require ] when
|
||||
|
|
@ -70,18 +64,18 @@ SYMBOL: bootstrap-time
|
|||
"staging" get "deploy-vocab" get or [
|
||||
"stage2: deployment mode" print
|
||||
] [
|
||||
"debugger" require
|
||||
"inspector" require
|
||||
"tools.errors" require
|
||||
"listener" require
|
||||
"none" require
|
||||
] if
|
||||
|
||||
[
|
||||
load-components
|
||||
load-components
|
||||
|
||||
millis over - core-bootstrap-time set-global
|
||||
millis over - core-bootstrap-time set-global
|
||||
|
||||
run-bootstrap-init
|
||||
] with-compiler-errors
|
||||
:errors
|
||||
run-bootstrap-init
|
||||
|
||||
f error set-global
|
||||
f error-continuation set-global
|
||||
|
|
@ -104,6 +98,7 @@ SYMBOL: bootstrap-time
|
|||
drop
|
||||
[
|
||||
load-help? off
|
||||
"vocab:bootstrap/bootstrap-error.factor" run-file
|
||||
[ "vocab:bootstrap/bootstrap-error.factor" parse-file ] save/restore-error
|
||||
call
|
||||
] with-scope
|
||||
] recover
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ IN: bootstrap.tools
|
|||
"bootstrap.image"
|
||||
"tools.annotations"
|
||||
"tools.crossref"
|
||||
"tools.errors"
|
||||
"tools.deploy"
|
||||
"tools.disassembler"
|
||||
"tools.memory"
|
||||
|
|
@ -13,7 +14,8 @@ IN: bootstrap.tools
|
|||
"tools.test"
|
||||
"tools.time"
|
||||
"tools.threads"
|
||||
"tools.vocabs"
|
||||
"tools.vocabs.monitor"
|
||||
"vocabs.hierarchy"
|
||||
"vocabs.refresh"
|
||||
"vocabs.refresh.monitor"
|
||||
"editors"
|
||||
} [ require ] each
|
||||
|
|
|
|||
|
|
@ -1,11 +1,7 @@
|
|||
USING: arrays calendar kernel math sequences tools.test
|
||||
continuations system math.order threads ;
|
||||
continuations system math.order threads accessors ;
|
||||
IN: calendar.tests
|
||||
|
||||
\ time+ must-infer
|
||||
\ time* must-infer
|
||||
\ time- must-infer
|
||||
|
||||
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
[ f ] [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
|
||||
|
|
@ -167,3 +163,10 @@ IN: calendar.tests
|
|||
[ t ] [ now 50 milliseconds sleep now before? ] unit-test
|
||||
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
|
||||
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
|
||||
|
||||
[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
|
||||
[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
|
||||
|
||||
[ f ] [ now dup midnight eq? ] unit-test
|
||||
[ f ] [ now dup easter eq? ] unit-test
|
||||
[ f ] [ now dup beginning-of-year eq? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays classes.tuple combinators combinators.short-circuit
|
||||
kernel locals math math.functions math.order namespaces sequences strings
|
||||
summary system threads vocabs.loader ;
|
||||
USING: accessors arrays classes.tuple combinators
|
||||
combinators.short-circuit kernel locals math math.functions
|
||||
math.order sequences summary system threads vocabs.loader ;
|
||||
IN: calendar
|
||||
|
||||
HOOK: gmt-offset os ( -- hours minutes seconds )
|
||||
|
|
@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
|
|||
:: julian-day-number ( year month day -- n )
|
||||
#! Returns a composite date number
|
||||
#! Not valid before year -4800
|
||||
[let* | a [ 14 month - 12 /i ]
|
||||
y [ year 4800 + a - ]
|
||||
m [ month 12 a * + 3 - ] |
|
||||
day 153 m * 2 + 5 /i + 365 y * +
|
||||
y 4 /i + y 100 /i - y 400 /i + 32045 -
|
||||
] ;
|
||||
14 month - 12 /i :> a
|
||||
year 4800 + a - :> y
|
||||
month 12 a * + 3 - :> m
|
||||
|
||||
day 153 m * 2 + 5 /i + 365 y * +
|
||||
y 4 /i + y 100 /i - y 400 /i + 32045 - ;
|
||||
|
||||
:: julian-day-number>date ( n -- year month day )
|
||||
#! Inverse of julian-day-number
|
||||
[let* | a [ n 32044 + ]
|
||||
b [ 4 a * 3 + 146097 /i ]
|
||||
c [ a 146097 b * 4 /i - ]
|
||||
d [ 4 c * 3 + 1461 /i ]
|
||||
e [ c 1461 d * 4 /i - ]
|
||||
m [ 5 e * 2 + 153 /i ] |
|
||||
100 b * d + 4800 -
|
||||
m 10 /i + m 3 +
|
||||
12 m 10 /i * -
|
||||
e 153 m * 2 + 5 /i - 1+
|
||||
] ;
|
||||
n 32044 + :> a
|
||||
4 a * 3 + 146097 /i :> b
|
||||
a 146097 b * 4 /i - :> c
|
||||
4 c * 3 + 1461 /i :> d
|
||||
c 1461 d * 4 /i - :> e
|
||||
5 e * 2 + 153 /i :> m
|
||||
|
||||
100 b * d + 4800 -
|
||||
m 10 /i + m 3 +
|
||||
12 m 10 /i * -
|
||||
e 153 m * 2 + 5 /i - 1+ ;
|
||||
|
||||
GENERIC: easter ( obj -- obj' )
|
||||
|
||||
:: easter-month-day ( year -- month day )
|
||||
year 19 mod :> a
|
||||
year 100 /mod :> c :> b
|
||||
b 4 /mod :> e :> d
|
||||
b 8 + 25 /i :> f
|
||||
b f - 1 + 3 /i :> g
|
||||
19 a * b + d - g - 15 + 30 mod :> h
|
||||
c 4 /mod :> k :> i
|
||||
32 2 e * + 2 i * + h - k - 7 mod :> l
|
||||
a 11 h * + 22 l * + 451 /i :> m
|
||||
|
||||
h l + 7 m * - 114 + 31 /mod 1 + :> day :> month
|
||||
month day ;
|
||||
|
||||
M: integer easter ( year -- timestamp )
|
||||
dup easter-month-day <date> ;
|
||||
|
||||
M: timestamp easter ( timestamp -- timestamp )
|
||||
clone
|
||||
dup year>> easter-month-day
|
||||
swapd >>day swap >>month ;
|
||||
|
||||
: >date< ( timestamp -- year month day )
|
||||
[ year>> ] [ month>> ] [ day>> ] tri ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: tools.test kernel ;
|
||||
USING: tools.test kernel accessors ;
|
||||
IN: calendar.format.macros
|
||||
|
||||
[ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test
|
||||
|
|
@ -10,6 +10,6 @@ IN: calendar.format.macros
|
|||
: compiled-test-1 ( -- n )
|
||||
{ [ 1 throw ] [ 2 ] } attempt-all-quots ;
|
||||
|
||||
\ compiled-test-1 must-infer
|
||||
\ compiled-test-1 def>> must-infer
|
||||
|
||||
[ 2 ] [ compiled-test-1 ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: calendar namespaces alien.c-types system windows
|
||||
windows.kernel32 kernel math combinators ;
|
||||
USING: calendar namespaces alien.c-types system
|
||||
windows.kernel32 kernel math combinators windows.errors ;
|
||||
IN: calendar.windows
|
||||
|
||||
M: windows gmt-offset ( -- hours minutes seconds )
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ IN: checksums.md5
|
|||
SYMBOLS: a b c d old-a old-b old-c old-d ;
|
||||
|
||||
: T ( N -- Y )
|
||||
sin abs 4294967296 * >integer ; foldable
|
||||
sin abs 32 2^ * >integer ; foldable
|
||||
|
||||
: initialize-md5 ( -- )
|
||||
0 bytes-read set
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ compiler.units lexer init ;
|
|||
IN: cocoa
|
||||
|
||||
: (remember-send) ( selector variable -- )
|
||||
global [ dupd ?set-at ] change-at ;
|
||||
[ dupd ?set-at ] change-global ;
|
||||
|
||||
SYMBOL: sent-messages
|
||||
|
||||
|
|
|
|||
|
|
@ -12,6 +12,9 @@ IN: cocoa.dialogs
|
|||
dup 1 -> setResolvesAliases:
|
||||
dup 1 -> setAllowsMultipleSelection: ;
|
||||
|
||||
: <NSDirPanel> ( -- panel ) <NSOpenPanel>
|
||||
dup 1 -> setCanChooseDirectories: ;
|
||||
|
||||
: <NSSavePanel> ( -- panel )
|
||||
NSSavePanel -> savePanel
|
||||
dup 1 -> setCanChooseFiles:
|
||||
|
|
@ -21,10 +24,12 @@ IN: cocoa.dialogs
|
|||
CONSTANT: NSOKButton 1
|
||||
CONSTANT: NSCancelButton 0
|
||||
|
||||
: open-panel ( -- paths )
|
||||
<NSOpenPanel>
|
||||
: (open-panel) ( panel -- paths )
|
||||
dup -> runModal NSOKButton =
|
||||
[ -> filenames CF>string-array ] [ drop f ] if ;
|
||||
|
||||
: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
|
||||
: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
|
||||
|
||||
: split-path ( path -- dir file )
|
||||
"/" split1-last [ <NSString> ] bi@ ;
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
|
|
|||
|
|
@ -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: ;
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ $nl
|
|||
ARTICLE: "colors" "Colors"
|
||||
"The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them."
|
||||
$nl
|
||||
"RGBA colors:"
|
||||
"RGBA colors with floating point components in the range " { $snippet "[0,1]" } ":"
|
||||
{ $subsection rgba }
|
||||
{ $subsection <rgba> }
|
||||
"Converting a color to RGBA:"
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
extensions
|
||||
|
|
@ -0,0 +1 @@
|
|||
extensions
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations math sequences
|
||||
multiline ;
|
||||
multiline stack-checker ;
|
||||
IN: combinators.smart
|
||||
|
||||
HELP: input<sequence
|
||||
|
|
@ -108,18 +108,21 @@ HELP: append-outputs-as
|
|||
|
||||
|
||||
ARTICLE: "combinators.smart" "Smart combinators"
|
||||
"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl
|
||||
"Smart inputs from a sequence:"
|
||||
"A " { $emphasis "smart combinator" } " is a macro which reflects on the stack effect of an input quotation. The " { $vocab-link "combinators.smart" } " vocabulary implements a few simple smart combinators which look at the static stack effects of input quotations and generate code which produces or consumes the relevant number of stack values." $nl
|
||||
"Call a quotation and discard all output values:"
|
||||
{ $subsection drop-outputs }
|
||||
"Take all input values from a sequence:"
|
||||
{ $subsection input<sequence }
|
||||
"Smart outputs to a sequence:"
|
||||
"Store all output values to a sequence:"
|
||||
{ $subsection output>sequence }
|
||||
{ $subsection output>array }
|
||||
"Reducing the output of a quotation:"
|
||||
"Reducing the set of output values:"
|
||||
{ $subsection reduce-outputs }
|
||||
"Summing the output of a quotation:"
|
||||
"Summing output values:"
|
||||
{ $subsection sum-outputs }
|
||||
"Appending the results of a quotation:"
|
||||
"Concatenating output values:"
|
||||
{ $subsection append-outputs }
|
||||
{ $subsection append-outputs-as } ;
|
||||
{ $subsection append-outputs-as }
|
||||
"New smart combinators can be created by defining " { $link "macros" } " which call " { $link infer } "." ;
|
||||
|
||||
ABOUT: "combinators.smart"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test combinators.smart math kernel ;
|
||||
USING: tools.test combinators.smart math kernel accessors ;
|
||||
IN: combinators.smart.tests
|
||||
|
||||
: test-bi ( -- 9 11 )
|
||||
|
|
@ -42,7 +42,7 @@ IN: combinators.smart.tests
|
|||
: nested-smart-combo-test ( -- array )
|
||||
[ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ;
|
||||
|
||||
\ nested-smart-combo-test must-infer
|
||||
\ nested-smart-combo-test def>> must-infer
|
||||
|
||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -18,6 +18,10 @@ MACRO: input<sequence ( quot -- newquot )
|
|||
[ infer in>> ] keep
|
||||
'[ _ firstn @ ] ;
|
||||
|
||||
MACRO: input<sequence-unsafe ( quot -- newquot )
|
||||
[ infer in>> ] keep
|
||||
'[ _ firstn-unsafe @ ] ;
|
||||
|
||||
MACRO: reduce-outputs ( quot operation -- newquot )
|
||||
[ dup infer out>> 1 [-] ] dip n*quot compose ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
extensions
|
||||
|
|
@ -1,5 +1,4 @@
|
|||
USING: help.markup help.syntax parser vocabs.loader strings
|
||||
command-line.private ;
|
||||
USING: help.markup help.syntax parser vocabs.loader strings ;
|
||||
IN: command-line
|
||||
|
||||
HELP: run-bootstrap-init
|
||||
|
|
@ -53,6 +52,7 @@ ARTICLE: "runtime-cli-args" "Command line switches for the VM"
|
|||
{ { $snippet "-aging=" { $emphasis "n" } } "Size of aging generation (1), megabytes" }
|
||||
{ { $snippet "-tenured=" { $emphasis "n" } } "Size of oldest generation (2), megabytes" }
|
||||
{ { $snippet "-codeheap=" { $emphasis "n" } } "Code heap size, megabytes" }
|
||||
{ { $snippet "-pic=" { $emphasis "n" } } "Maximum inline cache size. Setting of 0 disables inline caching, > 1 enables polymorphic inline caching" }
|
||||
{ { $snippet "-securegc" } "If specified, unused portions of the data heap will be zeroed out after every garbage collection" }
|
||||
}
|
||||
"If an " { $snippet "-i=" } " switch is not present, the default image file is used, which is usually a file named " { $snippet "factor.image" } " in the same directory as the runtime executable (on Windows and Mac OS X) or the current directory (on Unix)." ;
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2003, 2008 Slava Pestov.
|
||||
! Copyright (C) 2003, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: init continuations hashtables io io.encodings.utf8
|
||||
io.files io.pathnames kernel kernel.private namespaces parser
|
||||
sequences strings system splitting vocabs.loader ;
|
||||
sequences strings system splitting vocabs.loader alien.strings ;
|
||||
IN: command-line
|
||||
|
||||
SYMBOL: script
|
||||
SYMBOL: command-line
|
||||
|
||||
: (command-line) ( -- args ) 10 getenv sift ;
|
||||
: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
|
||||
|
||||
: rc-path ( name -- path )
|
||||
os windows? [ "." prepend ] unless
|
||||
|
|
@ -60,7 +60,6 @@ SYMBOL: main-vocab-hook
|
|||
: default-cli-args ( -- )
|
||||
global [
|
||||
"quiet" off
|
||||
"script" off
|
||||
"e" off
|
||||
"user-init" on
|
||||
embedded? "quiet" set
|
||||
|
|
|
|||
|
|
@ -5,8 +5,6 @@ math.private compiler.tree.builder compiler.tree.optimizer
|
|||
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
|
||||
kernel.private math ;
|
||||
|
||||
\ build-cfg must-infer
|
||||
|
||||
! Just ensure that various CFGs build correctly.
|
||||
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ M: callable test-cfg
|
|||
build-tree optimize-tree gensym build-cfg ;
|
||||
|
||||
M: word test-cfg
|
||||
[ build-tree-from-word optimize-tree ] keep build-cfg ;
|
||||
[ build-tree optimize-tree ] keep build-cfg ;
|
||||
|
||||
SYMBOL: allocate-registers?
|
||||
|
||||
|
|
|
|||
|
|
@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot
|
|||
[ tuple ##set-slots ] [ ds-push drop ] 2bi
|
||||
] [ drop emit-primitive ] if ;
|
||||
|
||||
: store-length ( len reg -- )
|
||||
[ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ;
|
||||
: store-length ( len reg class -- )
|
||||
[ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ;
|
||||
|
||||
: store-initial-element ( elt reg len -- )
|
||||
[ 2 + object tag-number ##set-slot-imm ] with with each ;
|
||||
:: store-initial-element ( len reg elt class -- )
|
||||
len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ;
|
||||
|
||||
: expand-<array>? ( obj -- ? )
|
||||
dup integer? [ 0 8 between? ] [ drop f ] if ;
|
||||
|
|
@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot
|
|||
[let | elt [ ds-pop ]
|
||||
reg [ len ^^allot-array ] |
|
||||
ds-drop
|
||||
len reg store-length
|
||||
elt reg len store-initial-element
|
||||
len reg array store-length
|
||||
len reg elt array store-initial-element
|
||||
reg ds-push
|
||||
]
|
||||
] [ node emit-primitive ] if
|
||||
|
|
@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot
|
|||
: emit-allot-byte-array ( len -- dst )
|
||||
ds-drop
|
||||
dup ^^allot-byte-array
|
||||
[ store-length ] [ ds-push ] [ ] tri ;
|
||||
[ byte-array store-length ] [ ds-push ] [ ] tri ;
|
||||
|
||||
: emit-(byte-array) ( node -- )
|
||||
dup node-input-infos first literal>> dup expand-<byte-array>?
|
||||
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
|
||||
|
||||
: emit-<byte-array> ( node -- )
|
||||
dup node-input-infos first literal>> dup expand-<byte-array>? [
|
||||
nip
|
||||
[ 0 ^^load-literal ] dip
|
||||
[ emit-allot-byte-array ] keep
|
||||
bytes>cells store-initial-element
|
||||
] [ drop emit-primitive ] if ;
|
||||
:: emit-<byte-array> ( node -- )
|
||||
node node-input-infos first literal>> dup expand-<byte-array>? [
|
||||
:> len
|
||||
0 ^^load-literal :> elt
|
||||
len emit-allot-byte-array :> reg
|
||||
len reg elt byte-array store-initial-element
|
||||
] [ drop node emit-primitive ] if ;
|
||||
|
|
|
|||
|
|
@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics
|
|||
arrays:<array>
|
||||
byte-arrays:<byte-array>
|
||||
byte-arrays:(byte-array)
|
||||
math.private:<complex>
|
||||
math.private:<ratio>
|
||||
kernel:<wrapper>
|
||||
alien.accessors:alien-unsigned-1
|
||||
alien.accessors:set-alien-unsigned-1
|
||||
|
|
@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ arrays:<array> [ emit-<array> iterate-next ] }
|
||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
|
||||
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
|
||||
{ \ math.private:<complex> [ emit-simple-allot iterate-next ] }
|
||||
{ \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
|
||||
{ \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
|
||||
{ \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
|
||||
{ \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
|
||||
|
|
|
|||
|
|
@ -99,7 +99,7 @@ SYMBOL: spill-counts
|
|||
: interval-to-spill ( active-intervals current -- live-interval )
|
||||
#! We spill the interval with the most distant use location.
|
||||
start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
|
||||
unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
|
||||
[ ] [ [ [ second ] bi@ > ] most ] map-reduce first ;
|
||||
|
||||
: assign-spill ( before after -- before after )
|
||||
#! If it has been spilled already, reuse spill location.
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: compiler.cfg.linear-scan.assignment tools.test ;
|
||||
IN: compiler.cfg.linear-scan.assignment.tests
|
||||
|
||||
\ assign-registers must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.cfg.linearization.tests
|
||||
USING: compiler.cfg.linearization tools.test ;
|
||||
|
||||
\ build-mr must-infer
|
||||
|
||||
|
|
|
|||
|
|
@ -92,7 +92,7 @@ sequences ;
|
|||
T{ ##load-reference f V int-regs 1 + }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
} value-numbering trim-temps
|
||||
] unit-test
|
||||
|
|
@ -110,7 +110,7 @@ sequences ;
|
|||
T{ ##load-reference f V int-regs 1 + }
|
||||
T{ ##peek f V int-regs 2 D 0 }
|
||||
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
|
||||
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
|
||||
T{ ##replace f V int-regs 6 D 0 }
|
||||
} value-numbering trim-temps
|
||||
] unit-test
|
||||
|
|
@ -132,7 +132,7 @@ sequences ;
|
|||
T{ ##unbox-float f V double-float-regs 10 V int-regs 8 }
|
||||
T{ ##unbox-float f V double-float-regs 11 V int-regs 9 }
|
||||
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
|
||||
T{ ##compare-imm f V int-regs 14 V int-regs 12 7 cc= }
|
||||
T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
|
||||
T{ ##replace f V int-regs 14 D 0 }
|
||||
} value-numbering trim-temps
|
||||
] unit-test
|
||||
|
|
@ -149,6 +149,6 @@ sequences ;
|
|||
T{ ##peek f V int-regs 29 D -1 }
|
||||
T{ ##peek f V int-regs 30 D -2 }
|
||||
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
|
||||
T{ ##compare-imm-branch f V int-regs 33 7 cc/= }
|
||||
T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
|
||||
} value-numbering trim-temps
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -3,8 +3,9 @@
|
|||
USING: namespaces make math math.order math.parser sequences accessors
|
||||
kernel kernel.private layouts assocs words summary arrays
|
||||
combinators classes.algebra alien alien.c-types alien.structs
|
||||
alien.strings alien.arrays alien.complex sets libc alien.libraries
|
||||
alien.strings alien.arrays alien.complex alien.libraries sets libc
|
||||
continuations.private fry cpu.architecture
|
||||
source-files.errors
|
||||
compiler.errors
|
||||
compiler.alien
|
||||
compiler.cfg
|
||||
|
|
@ -43,7 +44,7 @@ SYMBOL: calls
|
|||
|
||||
SYMBOL: compiling-word
|
||||
|
||||
: compiled-stack-traces? ( -- ? ) 59 getenv ;
|
||||
: compiled-stack-traces? ( -- ? ) 67 getenv ;
|
||||
|
||||
! Mapping _label IDs to label instances
|
||||
SYMBOL: labels
|
||||
|
|
@ -374,47 +375,21 @@ M: long-long-type flatten-value-type ( type -- types )
|
|||
: box-return* ( node -- )
|
||||
return>> [ ] [ box-return ] if-void ;
|
||||
|
||||
TUPLE: no-such-library name ;
|
||||
|
||||
M: no-such-library summary
|
||||
drop "Library not found" ;
|
||||
|
||||
M: no-such-library compiler-error-type
|
||||
drop +linkage+ ;
|
||||
|
||||
: no-such-library ( name -- )
|
||||
\ no-such-library boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
TUPLE: no-such-symbol name ;
|
||||
|
||||
M: no-such-symbol summary
|
||||
drop "Symbol not found" ;
|
||||
|
||||
M: no-such-symbol compiler-error-type
|
||||
drop +linkage+ ;
|
||||
|
||||
: no-such-symbol ( name -- )
|
||||
\ no-such-symbol boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
dup dll-valid? [
|
||||
dupd '[ _ dlsym ] any?
|
||||
[ drop ] [ no-such-symbol ] if
|
||||
[ drop ] [ compiling-word get no-such-symbol ] if
|
||||
] [
|
||||
dll-path no-such-library drop
|
||||
dll-path compiling-word get no-such-library drop
|
||||
] if ;
|
||||
|
||||
: stdcall-mangle ( symbol node -- symbol )
|
||||
"@"
|
||||
swap parameters>> parameter-sizes drop
|
||||
number>string 3append ;
|
||||
: stdcall-mangle ( symbol params -- symbol )
|
||||
parameters>> parameter-sizes drop number>string "@" glue ;
|
||||
|
||||
: alien-invoke-dlsym ( params -- symbols dll )
|
||||
dup function>> dup pick stdcall-mangle 2array
|
||||
swap library>> library dup [ dll>> ] when
|
||||
2dup check-dlsym ;
|
||||
[ [ function>> dup ] keep stdcall-mangle 2array ]
|
||||
[ library>> library dup [ dll>> ] when ]
|
||||
bi 2dup check-dlsym ;
|
||||
|
||||
M: ##alien-invoke generate-insn
|
||||
params>>
|
||||
|
|
|
|||
|
|
@ -3,15 +3,13 @@
|
|||
USING: arrays byte-arrays byte-vectors generic assocs hashtables
|
||||
io.binary kernel kernel.private math namespaces make sequences
|
||||
words quotations strings alien.accessors alien.strings layouts
|
||||
system combinators math.bitwise words.private math.order
|
||||
system combinators math.bitwise math.order
|
||||
accessors growable cpu.architecture compiler.constants ;
|
||||
IN: compiler.codegen.fixup
|
||||
|
||||
GENERIC: fixup* ( obj -- )
|
||||
|
||||
: code-format ( -- n ) 22 getenv ;
|
||||
|
||||
: compiled-offset ( -- n ) building get length code-format * ;
|
||||
: compiled-offset ( -- n ) building get length ;
|
||||
|
||||
SYMBOL: relocation-table
|
||||
SYMBOL: label-table
|
||||
|
|
@ -25,7 +23,7 @@ TUPLE: label-fixup label class ;
|
|||
M: label-fixup fixup*
|
||||
dup class>> rc-absolute?
|
||||
[ "Absolute labels not supported" throw ] when
|
||||
[ label>> ] [ class>> ] bi compiled-offset 4 - rot
|
||||
[ class>> ] [ label>> ] bi compiled-offset 4 - swap
|
||||
3array label-table get push ;
|
||||
|
||||
TUPLE: rel-fixup class type ;
|
||||
|
|
@ -58,6 +56,9 @@ SYMBOL: literal-table
|
|||
: rel-word ( word class -- )
|
||||
[ add-literal ] dip rt-xt rel-fixup ;
|
||||
|
||||
: rel-word-direct ( word class -- )
|
||||
[ add-literal ] dip rt-xt-direct rel-fixup ;
|
||||
|
||||
: rel-primitive ( word class -- )
|
||||
[ def>> first add-literal ] dip rt-primitive rel-fixup ;
|
||||
|
||||
|
|
@ -88,4 +89,4 @@ SYMBOL: literal-table
|
|||
literal-table get >array
|
||||
relocation-table get >byte-array
|
||||
label-table get resolve-labels
|
||||
] { } make 4array ;
|
||||
] B{ } make 4array ;
|
||||
|
|
|
|||
|
|
@ -1,23 +1,43 @@
|
|||
USING: help.markup help.syntax words io parser
|
||||
assocs words.private sequences compiler.units quotations ;
|
||||
USING: assocs compiler.cfg.builder compiler.cfg.optimizer
|
||||
compiler.errors compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.units help.markup help.syntax io parser quotations
|
||||
sequences words ;
|
||||
IN: compiler
|
||||
|
||||
HELP: enable-compiler
|
||||
HELP: enable-optimizer
|
||||
{ $description "Enables the optimizing compiler." } ;
|
||||
|
||||
HELP: disable-compiler
|
||||
HELP: disable-optimizer
|
||||
{ $description "Disable the optimizing compiler." } ;
|
||||
|
||||
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
||||
"Normally, new word definitions are recompiled automatically. This can be changed:"
|
||||
{ $subsection disable-compiler }
|
||||
{ $subsection enable-compiler }
|
||||
{ $subsection disable-optimizer }
|
||||
{ $subsection enable-optimizer }
|
||||
"Removing a word's optimized definition:"
|
||||
{ $subsection decompile }
|
||||
"Compiling a single quotation:"
|
||||
{ $subsection compile-call }
|
||||
"Higher-level words can be found in " { $link "compilation-units" } "." ;
|
||||
|
||||
ARTICLE: "compiler-impl" "Compiler implementation"
|
||||
"The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop."
|
||||
$nl
|
||||
"Words are added to the " { $link compile-queue } " variable as needed and compiled."
|
||||
{ $subsection compile-queue }
|
||||
"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
|
||||
$nl
|
||||
"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
|
||||
{ $list
|
||||
{ "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring certain compile errors generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
|
||||
{ "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
|
||||
{ "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
|
||||
{ "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." }
|
||||
}
|
||||
"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
|
||||
$nl
|
||||
"Calling " { $link modify-code-heap } " is handled not by the " { $vocab-link "compiler" } " vocabulary, but rather " { $vocab-link "compiler.units" } ". The optimizing compiler merely provides an implementation of the " { $link recompile } " generic word." ;
|
||||
|
||||
ARTICLE: "compiler" "Optimizing compiler"
|
||||
"Factor includes two compilers which work behind the scenes. Words are always compiled, and the compilers do not have to be invoked explicitly. For the most part, compilation is fully transparent. However, there are a few things worth knowing about the compilation process."
|
||||
$nl
|
||||
|
|
@ -26,12 +46,13 @@ $nl
|
|||
{ "The " { $emphasis "non-optimizing quotation compiler" } " compiles quotations to naive machine code very quickly. The non-optimizing quotation compiler is part of the VM." }
|
||||
{ "The " { $emphasis "optimizing word compiler" } " compiles whole words at a time while performing extensive data and control flow analysis. This provides greater performance for generated code, but incurs a much longer compile time. The optimizing compiler is written in Factor." }
|
||||
}
|
||||
"The optimizing compiler only compiles words which have a static stack effect. This means that methods defined on fundamental generic words such as " { $link nth } " should have a static stack effect. See " { $link "inference" } " and " { $link "cookbook-pitfalls" } "."
|
||||
$nl
|
||||
"The optimizing compiler also trades off compile time for performance of generated code, so loading certain vocabularies might take a while. Saving the image after loading vocabularies can save you a lot of time that you would spend waiting for the same code to load in every coding session; see " { $link "images" } " for information."
|
||||
$nl
|
||||
"Most code you write will run with the optimizing compiler. Sometimes, the non-optimizing compiler is used, for example for listener interactions, or for running the quotation passed to " { $link POSTPONE: call( } "."
|
||||
{ $subsection "compiler-errors" }
|
||||
{ $subsection "hints" }
|
||||
{ $subsection "compiler-usage" } ;
|
||||
{ $subsection "compiler-usage" }
|
||||
{ $subsection "compiler-impl" } ;
|
||||
|
||||
ABOUT: "compiler"
|
||||
|
||||
|
|
@ -39,7 +60,7 @@ HELP: decompile
|
|||
{ $values { "word" word } }
|
||||
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
|
||||
|
||||
HELP: (compile)
|
||||
HELP: compile-word
|
||||
{ $values { "word" word } }
|
||||
{ $description "Compile a single word." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
|
|
|||
|
|
@ -2,8 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces arrays sequences io words fry
|
||||
continuations vocabs assocs dlists definitions math graphs generic
|
||||
combinators deques search-deques macros io stack-checker
|
||||
stack-checker.state stack-checker.inlining combinators.short-circuit
|
||||
generic.single combinators deques search-deques macros io
|
||||
source-files.errors stack-checker stack-checker.state
|
||||
stack-checker.inlining stack-checker.errors combinators.short-circuit
|
||||
compiler.errors compiler.units compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||
compiler.cfg.linearization compiler.cfg.two-operand
|
||||
|
|
@ -14,7 +15,8 @@ IN: compiler
|
|||
SYMBOL: compile-queue
|
||||
SYMBOL: compiled
|
||||
|
||||
: queue-compile? ( word -- ? )
|
||||
: compile? ( word -- ? )
|
||||
#! Don't attempt to compile certain words.
|
||||
{
|
||||
[ "forgotten" word-prop ]
|
||||
[ compiled get key? ]
|
||||
|
|
@ -23,61 +25,123 @@ SYMBOL: compiled
|
|||
} 1|| not ;
|
||||
|
||||
: queue-compile ( word -- )
|
||||
dup queue-compile? [ compile-queue get push-front ] [ drop ] if ;
|
||||
dup compile? [ compile-queue get push-front ] [ drop ] if ;
|
||||
|
||||
: maybe-compile ( word -- )
|
||||
dup optimized>> [ drop ] [ queue-compile ] if ;
|
||||
: recompile-callers? ( word -- ? )
|
||||
changed-effects get key? ;
|
||||
|
||||
SYMBOLS: +optimized+ +unoptimized+ ;
|
||||
|
||||
: ripple-up ( words -- )
|
||||
dup "compiled-status" word-prop +unoptimized+ eq?
|
||||
[ usage [ word? ] filter ] [ compiled-usage keys ] if
|
||||
[ queue-compile ] each ;
|
||||
|
||||
: ripple-up? ( status word -- ? )
|
||||
[
|
||||
[ nip changed-effects get key? ]
|
||||
[ "compiled-status" word-prop eq? not ] 2bi or
|
||||
] keep "compiled-status" word-prop and ;
|
||||
|
||||
: save-compiled-status ( word status -- )
|
||||
[ over ripple-up? [ ripple-up ] [ drop ] if ]
|
||||
[ "compiled-status" set-word-prop ]
|
||||
2bi ;
|
||||
: recompile-callers ( words -- )
|
||||
#! If a word's stack effect changed, recompile all words that
|
||||
#! have compiled calls to it.
|
||||
dup recompile-callers?
|
||||
[ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
|
||||
|
||||
: start ( word -- )
|
||||
"trace-compilation" get [ dup name>> print flush ] when
|
||||
H{ } clone dependencies set
|
||||
H{ } clone generic-dependencies set
|
||||
f swap compiler-error ;
|
||||
clear-compiler-error ;
|
||||
|
||||
GENERIC: no-compile? ( word -- ? )
|
||||
|
||||
M: word no-compile? "no-compile" word-prop ;
|
||||
|
||||
M: method-body no-compile? "method-generic" word-prop no-compile? ;
|
||||
|
||||
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
|
||||
|
||||
: ignore-error? ( word error -- ? )
|
||||
[ [ inline? ] [ macro? ] bi or ]
|
||||
[ compiler-error-type +warning+ eq? ] bi* and ;
|
||||
|
||||
: fail ( word error -- * )
|
||||
[ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ]
|
||||
#! Ignore some errors on inline combinators, macros, and special
|
||||
#! words such as 'call'.
|
||||
[
|
||||
drop
|
||||
[ compiled-unxref ]
|
||||
[ f swap compiled get set-at ]
|
||||
[ +unoptimized+ save-compiled-status ]
|
||||
tri
|
||||
] 2bi
|
||||
return ;
|
||||
{
|
||||
[ macro? ]
|
||||
[ inline? ]
|
||||
[ no-compile? ]
|
||||
[ "special" word-prop ]
|
||||
} 1||
|
||||
] [
|
||||
{
|
||||
[ do-not-compile? ]
|
||||
[ literal-expected? ]
|
||||
} 1||
|
||||
] bi* and ;
|
||||
|
||||
: finish ( word -- )
|
||||
#! Recompile callers if the word's stack effect changed, then
|
||||
#! save the word's dependencies so that if they change, the
|
||||
#! word can get recompiled too.
|
||||
[ recompile-callers ]
|
||||
[ compiled-unxref ]
|
||||
[
|
||||
dup crossref? [
|
||||
dependencies get
|
||||
generic-dependencies get
|
||||
compiled-xref
|
||||
] [ drop ] if
|
||||
] tri ;
|
||||
|
||||
: deoptimize-with ( word def -- * )
|
||||
#! If the word failed to infer, compile it with the
|
||||
#! non-optimizing compiler.
|
||||
swap [ finish ] [ compiled get set-at ] bi return ;
|
||||
|
||||
: not-compiled-def ( word error -- def )
|
||||
'[ _ _ not-compiled ] [ ] like ;
|
||||
|
||||
: ignore-error ( word error -- * )
|
||||
drop
|
||||
[ clear-compiler-error ]
|
||||
[ dup def>> deoptimize-with ]
|
||||
bi ;
|
||||
|
||||
: remember-error ( word error -- * )
|
||||
[ swap <compiler-error> compiler-error ]
|
||||
[ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
|
||||
2bi ;
|
||||
|
||||
: deoptimize ( word error -- * )
|
||||
#! If the error is ignorable, compile the word with the
|
||||
#! non-optimizing compiler, using its definition. Otherwise,
|
||||
#! if the compiler error is not ignorable, use a dummy
|
||||
#! definition from 'not-compiled-def' which throws an error.
|
||||
{
|
||||
{ [ dup inference-error? not ] [ rethrow ] }
|
||||
{ [ 2dup ignore-error? ] [ ignore-error ] }
|
||||
[ remember-error ]
|
||||
} cond ;
|
||||
|
||||
: optimize? ( word -- ? )
|
||||
{
|
||||
[ predicate-engine-word? ]
|
||||
[ contains-breakpoints? ]
|
||||
[ single-generic? ]
|
||||
} 1|| not ;
|
||||
|
||||
: frontend ( word -- nodes )
|
||||
[ build-tree-from-word ] [ fail ] recover optimize-tree ;
|
||||
#! If the word contains breakpoints, don't optimize it, since
|
||||
#! the walker does not support this.
|
||||
dup optimize?
|
||||
[ [ build-tree ] [ deoptimize ] recover optimize-tree ]
|
||||
[ dup def>> deoptimize-with ]
|
||||
if ;
|
||||
|
||||
: compile-dependency ( word -- )
|
||||
#! If a word calls an unoptimized word, try to compile the callee.
|
||||
dup optimized? [ drop ] [ queue-compile ] if ;
|
||||
|
||||
! Only switch this off for debugging.
|
||||
SYMBOL: compile-dependencies?
|
||||
|
||||
t compile-dependencies? set-global
|
||||
|
||||
: compile-dependencies ( asm -- )
|
||||
compile-dependencies? get
|
||||
[ calls>> [ compile-dependency ] each ] [ drop ] if ;
|
||||
|
||||
: save-asm ( asm -- )
|
||||
[ [ code>> ] [ label>> ] bi compiled get set-at ]
|
||||
[ compile-dependencies? get [ calls>> [ maybe-compile ] each ] [ drop ] if ]
|
||||
[ compile-dependencies ]
|
||||
bi ;
|
||||
|
||||
: backend ( nodes word -- )
|
||||
|
|
@ -91,19 +155,9 @@ t compile-dependencies? set-global
|
|||
save-asm
|
||||
] each ;
|
||||
|
||||
: finish ( word -- )
|
||||
[ +optimized+ save-compiled-status ]
|
||||
[ compiled-unxref ]
|
||||
[
|
||||
dup crossref?
|
||||
[
|
||||
dependencies get
|
||||
generic-dependencies get
|
||||
compiled-xref
|
||||
] [ drop ] if
|
||||
] tri ;
|
||||
|
||||
: (compile) ( word -- )
|
||||
: compile-word ( word -- )
|
||||
#! We return early if the word has breakpoints or if it
|
||||
#! failed to infer.
|
||||
'[
|
||||
_ {
|
||||
[ start ]
|
||||
|
|
@ -114,30 +168,38 @@ t compile-dependencies? set-global
|
|||
] with-return ;
|
||||
|
||||
: compile-loop ( deque -- )
|
||||
[ (compile) yield-hook get call( -- ) ] slurp-deque ;
|
||||
[ compile-word yield-hook get call( -- ) ] slurp-deque ;
|
||||
|
||||
: decompile ( word -- )
|
||||
f 2array 1array modify-code-heap ;
|
||||
dup def>> 2array 1array modify-code-heap ;
|
||||
|
||||
: compile-call ( quot -- )
|
||||
[ dup infer define-temp ] with-compilation-unit execute ;
|
||||
|
||||
\ compile-call t "no-compile" set-word-prop
|
||||
|
||||
SINGLETON: optimizing-compiler
|
||||
|
||||
M: optimizing-compiler recompile ( words -- alist )
|
||||
[
|
||||
<hashed-dlist> compile-queue set
|
||||
H{ } clone compiled set
|
||||
[ queue-compile ] each
|
||||
[
|
||||
[ queue-compile ]
|
||||
[ subwords [ compile-dependency ] each ] bi
|
||||
] each
|
||||
compile-queue get compile-loop
|
||||
compiled get >alist
|
||||
] with-scope ;
|
||||
|
||||
: enable-compiler ( -- )
|
||||
: with-optimizer ( quot -- )
|
||||
[ optimizing-compiler compiler-impl ] dip with-variable ; inline
|
||||
|
||||
: enable-optimizer ( -- )
|
||||
optimizing-compiler compiler-impl set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
: disable-optimizer ( -- )
|
||||
f compiler-impl set-global ;
|
||||
|
||||
: recompile-all ( -- )
|
||||
forget-errors all-words compile ;
|
||||
all-words compile ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel layouts system strings ;
|
||||
USING: math kernel layouts system strings words quotations byte-arrays
|
||||
alien arrays ;
|
||||
IN: compiler.constants
|
||||
|
||||
! These constants must match vm/memory.h
|
||||
|
|
@ -11,18 +12,17 @@ CONSTANT: deck-bits 18
|
|||
! These constants must match vm/layouts.h
|
||||
: header-offset ( -- n ) object tag-number neg ; inline
|
||||
: float-offset ( -- n ) 8 float tag-number - ; inline
|
||||
: string-offset ( -- n ) 4 bootstrap-cells object tag-number - ; inline
|
||||
: string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline
|
||||
: string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 7 bootstrap-cells object tag-number - ; inline
|
||||
: byte-array-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||
: alien-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline
|
||||
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||
: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline
|
||||
: byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline
|
||||
: alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline
|
||||
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
|
||||
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
|
||||
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline
|
||||
: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline
|
||||
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
|
||||
: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
|
||||
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
|
||||
: compiled-header-size ( -- n ) 5 bootstrap-cells ; inline
|
||||
|
||||
! Relocation classes
|
||||
|
|
@ -41,10 +41,12 @@ CONSTANT: rt-primitive 0
|
|||
CONSTANT: rt-dlsym 1
|
||||
CONSTANT: rt-dispatch 2
|
||||
CONSTANT: rt-xt 3
|
||||
CONSTANT: rt-here 4
|
||||
CONSTANT: rt-this 5
|
||||
CONSTANT: rt-immediate 6
|
||||
CONSTANT: rt-stack-chain 7
|
||||
CONSTANT: rt-xt-direct 4
|
||||
CONSTANT: rt-here 5
|
||||
CONSTANT: rt-this 6
|
||||
CONSTANT: rt-immediate 7
|
||||
CONSTANT: rt-stack-chain 8
|
||||
CONSTANT: rt-untagged 9
|
||||
|
||||
: rc-absolute? ( n -- ? )
|
||||
[ rc-absolute-ppc-2/2 = ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
IN: compiler.errors
|
||||
USING: help.markup help.syntax vocabs.loader words io
|
||||
quotations words.symbol ;
|
||||
|
||||
ABOUT: "compiler-errors"
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors source-files.errors kernel namespaces assocs fry
|
||||
summary ;
|
||||
IN: compiler.errors
|
||||
|
||||
SYMBOL: +compiler-error+
|
||||
SYMBOL: compiler-errors
|
||||
|
||||
compiler-errors [ H{ } clone ] initialize
|
||||
|
||||
TUPLE: compiler-error < source-file-error ;
|
||||
|
||||
M: compiler-error error-type drop +compiler-error+ ;
|
||||
|
||||
SYMBOL: +linkage-error+
|
||||
SYMBOL: linkage-errors
|
||||
|
||||
linkage-errors [ H{ } clone ] initialize
|
||||
|
||||
TUPLE: linkage-error < source-file-error ;
|
||||
|
||||
M: linkage-error error-type drop +linkage-error+ ;
|
||||
|
||||
: clear-compiler-error ( word -- )
|
||||
compiler-errors linkage-errors
|
||||
[ get-global delete-at ] bi-curry@ bi ;
|
||||
|
||||
: compiler-error ( error -- )
|
||||
dup asset>> compiler-errors get-global set-at ;
|
||||
|
||||
T{ error-type
|
||||
{ type +compiler-error+ }
|
||||
{ word ":errors" }
|
||||
{ plural "compiler errors" }
|
||||
{ icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" }
|
||||
{ quot [ compiler-errors get values ] }
|
||||
{ forget-quot [ compiler-errors get delete-at ] }
|
||||
} define-error-type
|
||||
|
||||
: <compiler-error> ( error word -- compiler-error )
|
||||
\ compiler-error <definition-error> ;
|
||||
|
||||
: <linkage-error> ( error word -- linkage-error )
|
||||
\ linkage-error <definition-error> ;
|
||||
|
||||
: linkage-error ( error word class -- )
|
||||
'[ _ boa ] dip <linkage-error> dup asset>> linkage-errors get set-at ; inline
|
||||
|
||||
T{ error-type
|
||||
{ type +linkage-error+ }
|
||||
{ word ":linkage" }
|
||||
{ plural "linkage errors" }
|
||||
{ icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
|
||||
{ quot [ linkage-errors get values ] }
|
||||
{ forget-quot [ linkage-errors get delete-at ] }
|
||||
{ fatal? f }
|
||||
} define-error-type
|
||||
|
||||
TUPLE: no-such-library name ;
|
||||
|
||||
M: no-such-library summary drop "Library not found" ;
|
||||
|
||||
: no-such-library ( name word -- ) \ no-such-library linkage-error ;
|
||||
|
||||
TUPLE: no-such-symbol name ;
|
||||
|
||||
M: no-such-symbol summary drop "Symbol not found" ;
|
||||
|
||||
: no-such-symbol ( name word -- ) \ no-such-symbol linkage-error ;
|
||||
|
||||
ERROR: not-compiled word error ;
|
||||
|
|
@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string
|
|||
memory system threads tools.test math accessors combinators
|
||||
specialized-arrays.float alien.libraries io.pathnames
|
||||
io.backend ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.alien
|
||||
|
||||
<<
|
||||
: libfactor-ffi-tests-path ( -- string )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
IN: compiler.tests.call-effect
|
||||
USING: tools.test combinators generic.single sequences kernel ;
|
||||
|
||||
: execute-ic-test ( a b -- c ) execute( a -- c ) ;
|
||||
|
||||
! VM type check error
|
||||
[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
|
||||
|
||||
: call-test ( q -- ) call( -- ) ;
|
||||
|
||||
[ ] [ [ ] call-test ] unit-test
|
||||
[ ] [ f [ drop ] curry call-test ] unit-test
|
||||
[ ] [ [ ] [ ] compose call-test ] unit-test
|
||||
[ [ 1 2 3 ] call-test ] [ wrong-values? ] must-fail-with
|
||||
|
|
@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private
|
|||
slots.private sequences.private byte-arrays alien
|
||||
alien.accessors layouts words definitions compiler.units io
|
||||
combinators vectors grouping make ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.codegen
|
||||
|
||||
! Originally, this file did black box testing of templating
|
||||
! optimization. We now have a different codegen, but the tests
|
||||
|
|
@ -26,7 +26,7 @@ IN: compiler.tests
|
|||
|
||||
[ 2 3 4 ] [ 3 [ 2 swap 4 ] compile-call ] unit-test
|
||||
|
||||
[ { 1 2 3 } { 1 4 3 } 3 3 ]
|
||||
[ { 1 2 3 } { 1 4 3 } 2 2 ]
|
||||
[ { 1 2 3 } { 1 4 3 } [ over tag over tag ] compile-call ]
|
||||
unit-test
|
||||
|
||||
|
|
@ -37,7 +37,7 @@ unit-test
|
|||
|
||||
: foo ( -- ) ;
|
||||
|
||||
[ 5 5 ]
|
||||
[ 3 3 ]
|
||||
[ 1.2 [ tag [ foo ] keep ] compile-call ]
|
||||
unit-test
|
||||
|
||||
|
|
@ -211,7 +211,7 @@ TUPLE: my-tuple ;
|
|||
{ tuple vector } 3 slot { word } declare
|
||||
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
|
||||
|
||||
[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
|
||||
[ t ] [ \ dispatch-alignment-regression optimized? ] unit-test
|
||||
|
||||
[ vector ] [ dispatch-alignment-regression ] unit-test
|
||||
|
||||
|
|
@ -281,4 +281,4 @@ TUPLE: cucumber ;
|
|||
|
||||
M: cucumber equal? "The cucumber has no equal" throw ;
|
||||
|
||||
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
|
||||
[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: tools.test quotations math kernel sequences
|
||||
assocs namespaces make compiler.units compiler ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.curry
|
||||
|
||||
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
|
||||
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.tests
|
||||
IN: compiler.tests.float
|
||||
USING: compiler.units compiler kernel kernel.private memory math
|
||||
math.private tools.test math.floats.private ;
|
||||
|
||||
|
|
@ -9,7 +9,7 @@ math.private tools.test math.floats.private ;
|
|||
|
||||
[ 3.0 1 2 3 ] [ 1.0 2.0 [ float+ 1 2 3 ] compile-call ] unit-test
|
||||
|
||||
[ 5 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
|
||||
[ 3 ] [ 1.0 [ 2.0 float+ tag ] compile-call ] unit-test
|
||||
|
||||
[ 3.0 ] [ 1.0 [ 2.0 float+ ] compile-call ] unit-test
|
||||
[ 3.0 ] [ 1.0 [ 2.0 swap float+ ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: eval tools.test compiler.units vocabs multiline words
|
||||
kernel classes.mixin arrays ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.folding
|
||||
|
||||
! Calls to generic words were not folded away.
|
||||
|
||||
|
|
@ -12,7 +12,7 @@ IN: compiler.tests
|
|||
IN: compiler.tests.folding
|
||||
GENERIC: foldable-generic ( a -- b ) foldable
|
||||
M: integer foldable-generic f <array> ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -20,7 +20,7 @@ IN: compiler.tests
|
|||
USING: math arrays ;
|
||||
IN: compiler.tests.folding
|
||||
: fold-test ( -- x ) 10 foldable-generic ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
IN: compiler.tests.generic
|
||||
USING: tools.test math kernel compiler.units definitions ;
|
||||
|
||||
GENERIC: bad ( -- )
|
||||
M: integer bad ;
|
||||
M: object bad ;
|
||||
|
||||
[ 0 bad ] must-fail
|
||||
[ "" bad ] must-fail
|
||||
|
||||
[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
IN: compiler.tests
|
||||
USING: words kernel stack-checker alien.strings tools.test
|
||||
compiler.units ;
|
||||
|
||||
[ ] [ [ \ if redefined ] with-compilation-unit [ string>alien ] infer. ] unit-test
|
||||
|
|
@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order
|
|||
alien.accessors alien.c-types alien.syntax alien.strings
|
||||
namespaces libc sequences.private io.encodings.ascii
|
||||
classes compiler ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.intrinsics
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
[ ] [ 1 [ drop ] compile-call ] unit-test
|
||||
|
|
@ -342,12 +342,12 @@ cell 8 = [
|
|||
] unit-test
|
||||
|
||||
[ 1 2 ] [
|
||||
1 2 [ <complex> ] compile-call
|
||||
1 2 [ complex boa ] compile-call
|
||||
dup real-part swap imaginary-part
|
||||
] unit-test
|
||||
|
||||
[ 1 2 ] [
|
||||
1 2 [ <ratio> ] compile-call dup numerator swap denominator
|
||||
1 2 [ ratio boa ] compile-call dup numerator swap denominator
|
||||
] unit-test
|
||||
|
||||
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@ sbufs strings tools.test vectors words sequences.private
|
|||
quotations classes classes.algebra classes.tuple.private
|
||||
continuations growable namespaces hints alien.accessors
|
||||
compiler.tree.builder compiler.tree.optimizer sequences.deep
|
||||
compiler ;
|
||||
IN: optimizer.tests
|
||||
compiler definitions ;
|
||||
IN: compiler.tests.optimizer
|
||||
|
||||
GENERIC: xyz ( obj -- obj )
|
||||
M: array xyz xyz ;
|
||||
|
||||
[ t ] [ \ xyz optimized>> ] unit-test
|
||||
[ t ] [ M\ array xyz optimized? ] unit-test
|
||||
|
||||
! Test predicate inlining
|
||||
: pred-test-1 ( a -- b c )
|
||||
|
|
@ -95,7 +95,7 @@ TUPLE: pred-test ;
|
|||
! regression
|
||||
GENERIC: void-generic ( obj -- * )
|
||||
: breakage ( -- * ) "hi" void-generic ;
|
||||
[ t ] [ \ breakage optimized>> ] unit-test
|
||||
[ t ] [ \ breakage optimized? ] unit-test
|
||||
[ breakage ] must-fail
|
||||
|
||||
! regression
|
||||
|
|
@ -120,7 +120,7 @@ GENERIC: void-generic ( obj -- * )
|
|||
! compiling <tuple> with a non-literal class failed
|
||||
: <tuple>-regression ( class -- tuple ) <tuple> ;
|
||||
|
||||
[ t ] [ \ <tuple>-regression optimized>> ] unit-test
|
||||
[ t ] [ \ <tuple>-regression optimized? ] unit-test
|
||||
|
||||
GENERIC: foozul ( a -- b )
|
||||
M: reversed foozul ;
|
||||
|
|
@ -229,7 +229,7 @@ USE: binary-search.private
|
|||
: node-successor-f-bug ( x -- * )
|
||||
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
|
||||
|
||||
[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
|
||||
[ t ] [ \ node-successor-f-bug optimized? ] unit-test
|
||||
|
||||
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
|
||||
|
||||
|
|
@ -243,7 +243,7 @@ USE: binary-search.private
|
|||
] if
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
|
||||
[ t ] [ \ lift-throw-tail-regression optimized? ] unit-test
|
||||
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
|
||||
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
|
||||
|
||||
|
|
@ -261,7 +261,7 @@ USE: binary-search.private
|
|||
: lift-loop-tail-test-2 ( -- a b c )
|
||||
10 [ ] lift-loop-tail-test-1 1 2 3 ;
|
||||
|
||||
\ lift-loop-tail-test-2 must-infer
|
||||
\ lift-loop-tail-test-2 def>> must-infer
|
||||
|
||||
[ 1 2 3 ] [ lift-loop-tail-test-2 ] unit-test
|
||||
|
||||
|
|
@ -274,7 +274,7 @@ HINTS: recursive-inline-hang array ;
|
|||
: recursive-inline-hang-1 ( -- a )
|
||||
{ } recursive-inline-hang ;
|
||||
|
||||
[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
|
||||
[ t ] [ \ recursive-inline-hang-1 optimized? ] unit-test
|
||||
|
||||
DEFER: recursive-inline-hang-3
|
||||
|
||||
|
|
@ -302,8 +302,8 @@ HINTS: recursive-inline-hang-3 array ;
|
|||
|
||||
: member-test ( obj -- ? ) { + - * / /i } member? ;
|
||||
|
||||
\ member-test must-infer
|
||||
[ ] [ \ member-test build-tree-from-word optimize-tree drop ] unit-test
|
||||
\ member-test def>> must-infer
|
||||
[ ] [ \ member-test build-tree optimize-tree drop ] unit-test
|
||||
[ t ] [ \ + member-test ] unit-test
|
||||
[ f ] [ \ append member-test ] unit-test
|
||||
|
||||
|
|
@ -325,7 +325,7 @@ PREDICATE: list < improper-list
|
|||
dup "a" get { array-capacity } declare >=
|
||||
[ dup "b" get { array-capacity } declare >= [ 3 ] [ 4 ] if ] [ 5 ] if ;
|
||||
|
||||
\ interval-inference-bug must-infer
|
||||
[ t ] [ \ interval-inference-bug optimized? ] unit-test
|
||||
|
||||
[ ] [ 1 "a" set 2 "b" set ] unit-test
|
||||
[ 2 3 ] [ 2 interval-inference-bug ] unit-test
|
||||
|
|
@ -384,3 +384,9 @@ DEFER: loop-bbb
|
|||
1 >bignum 2 >bignum
|
||||
[ { bignum integer } declare [ shift ] keep 1+ ] compile-call
|
||||
] unit-test
|
||||
|
||||
: broken-declaration ( -- ) \ + declare ;
|
||||
|
||||
[ f ] [ \ broken-declaration optimized? ] unit-test
|
||||
|
||||
[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.tests
|
||||
IN: compiler.tests.peg-regression-2
|
||||
USING: peg.ebnf strings tools.test ;
|
||||
|
||||
GENERIC: <times> ( times -- term' )
|
||||
|
|
@ -12,4 +12,4 @@ Regexp = Times:t => [[ t <times> ]]
|
|||
|
||||
;EBNF
|
||||
|
||||
[ "foo" ] [ "a" parse-regexp ] unit-test
|
||||
[ "foo" ] [ "a" parse-regexp ] unit-test
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@
|
|||
! optimization, which would batch generic word updates at the
|
||||
! end of a compilation unit.
|
||||
|
||||
USING: kernel accessors peg.ebnf ;
|
||||
IN: compiler.tests
|
||||
USING: kernel accessors peg.ebnf words ;
|
||||
IN: compiler.tests.peg-regression
|
||||
|
||||
TUPLE: pipeline-expr background ;
|
||||
|
||||
|
|
@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
|
|||
|
||||
USE: tools.test
|
||||
|
||||
[ t ] [ \ expr optimized>> ] unit-test
|
||||
[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
|
||||
[ t ] [ \ expr optimized? ] unit-test
|
||||
[ t ] [ \ ast>pipeline-expr optimized? ] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,14 @@
|
|||
IN: compiler.tests.pic-problem-1
|
||||
USING: kernel sequences prettyprint memory tools.test ;
|
||||
|
||||
TUPLE: x ;
|
||||
|
||||
M: x length drop 0 ;
|
||||
|
||||
INSTANCE: x sequence
|
||||
|
||||
<< gc >>
|
||||
|
||||
CONSTANT: blah T{ x }
|
||||
|
||||
[ T{ x } ] [ blah ] unit-test
|
||||
|
|
@ -0,0 +1,107 @@
|
|||
IN: compiler.tests.redefine0
|
||||
USING: tools.test eval compiler compiler.errors compiler.units definitions kernel math
|
||||
namespaces macros assocs ;
|
||||
|
||||
! Test ripple-up behavior
|
||||
: test-1 ( -- a ) 3 ;
|
||||
: test-2 ( -- ) test-1 ;
|
||||
|
||||
[ test-2 ] [ not-compiled? ] must-fail-with
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine0 : test-1 ( -- ) ;" eval( -- ) ] unit-test
|
||||
|
||||
{ 0 0 } [ test-1 ] must-infer-as
|
||||
|
||||
[ ] [ test-2 ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ test-1 forget
|
||||
\ test-2 forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
: test-3 ( a -- ) drop ;
|
||||
: test-4 ( -- ) [ 1 2 3 ] test-3 ;
|
||||
|
||||
[ ] [ test-4 ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine0 USE: kernel : test-3 ( a -- ) call ; inline" eval( -- ) ] unit-test
|
||||
|
||||
[ test-4 ] [ not-compiled? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ test-3 forget
|
||||
\ test-4 forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
: test-5 ( a -- quot ) ;
|
||||
: test-6 ( a -- b ) test-5 ;
|
||||
|
||||
[ 31337 ] [ 31337 test-6 ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine0 USING: macros kernel ; MACRO: test-5 ( a -- quot ) drop [ ] ;" eval( -- ) ] unit-test
|
||||
|
||||
[ 31337 test-6 ] [ not-compiled? ] must-fail-with
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ test-5 forget
|
||||
\ test-6 forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
GENERIC: test-7 ( a -- b )
|
||||
|
||||
M: integer test-7 + ;
|
||||
|
||||
: test-8 ( a -- b ) 255 bitand test-7 ;
|
||||
|
||||
[ 1 test-7 ] [ not-compiled? ] must-fail-with
|
||||
[ 1 test-8 ] [ not-compiled? ] must-fail-with
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine0 USING: macros math kernel ; GENERIC: test-7 ( x y -- z ) : test-8 ( a b -- c ) 255 bitand test-7 ;" eval( -- ) ] unit-test
|
||||
|
||||
[ 4 ] [ 1 3 test-7 ] unit-test
|
||||
[ 4 ] [ 1 259 test-8 ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ test-7 forget
|
||||
\ test-8 forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
! Indirect dependency on an unoptimized word
|
||||
: test-9 ( -- ) ;
|
||||
<< SYMBOL: quot
|
||||
[ test-9 ] quot set-global >>
|
||||
MACRO: test-10 ( -- quot ) quot get ;
|
||||
: test-11 ( -- ) test-10 ;
|
||||
|
||||
[ ] [ test-11 ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) 1 ;" eval( -- ) ] unit-test
|
||||
|
||||
! test-11 should get recompiled now
|
||||
|
||||
[ test-11 ] [ not-compiled? ] must-fail-with
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- a ) 1 ;" eval( -- ) ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine0 : test-9 ( -- ) ;" eval( -- ) ] unit-test
|
||||
|
||||
[ ] [ test-11 ] unit-test
|
||||
|
||||
quot global delete-at
|
||||
|
||||
[ ] [
|
||||
[
|
||||
\ test-9 forget
|
||||
\ test-10 forget
|
||||
\ test-11 forget
|
||||
\ quot forget
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
USING: accessors compiler compiler.units tools.test math parser
|
||||
kernel sequences sequences.private classes.mixin generic
|
||||
definitions arrays words assocs eval strings ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine1
|
||||
|
||||
GENERIC: method-redefine-generic-1 ( a -- b )
|
||||
|
||||
|
|
@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
|
|||
|
||||
[ 6 ] [ method-redefine-test-1 ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
|
||||
|
||||
[ 7 ] [ method-redefine-test-1 ] unit-test
|
||||
|
||||
|
|
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
|
|||
|
||||
[ 6 ] [ method-redefine-test-2 ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
|
||||
|
||||
[ 7 ] [ method-redefine-test-2 ] unit-test
|
||||
|
||||
|
|
@ -36,41 +36,3 @@ M: integer method-redefine-generic-2 3 + ;
|
|||
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
! Test ripple-up behavior
|
||||
: hey ( -- ) ;
|
||||
: there ( -- ) hey ;
|
||||
|
||||
[ t ] [ \ hey optimized>> ] unit-test
|
||||
[ t ] [ \ there optimized>> ] unit-test
|
||||
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
|
||||
[ f ] [ \ hey optimized>> ] unit-test
|
||||
[ f ] [ \ there optimized>> ] unit-test
|
||||
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
|
||||
[ t ] [ \ there optimized>> ] unit-test
|
||||
|
||||
: good ( -- ) ;
|
||||
: bad ( -- ) good ;
|
||||
: ugly ( -- ) bad ;
|
||||
|
||||
[ t ] [ \ good optimized>> ] unit-test
|
||||
[ t ] [ \ bad optimized>> ] unit-test
|
||||
[ t ] [ \ ugly optimized>> ] unit-test
|
||||
|
||||
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
|
||||
|
||||
[ f ] [ \ good optimized>> ] unit-test
|
||||
[ f ] [ \ bad optimized>> ] unit-test
|
||||
[ f ] [ \ ugly optimized>> ] unit-test
|
||||
|
||||
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
|
||||
|
||||
[ t ] [ \ good optimized>> ] unit-test
|
||||
[ t ] [ \ bad optimized>> ] unit-test
|
||||
[ t ] [ \ ugly optimized>> ] unit-test
|
||||
|
||||
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: eval tools.test compiler.units vocabs multiline words
|
||||
kernel ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine10
|
||||
|
||||
! Mixin redefinition did not recompile all necessary words.
|
||||
|
||||
|
|
@ -13,7 +13,7 @@ IN: compiler.tests
|
|||
MIXIN: my-mixin
|
||||
INSTANCE: fixnum my-mixin
|
||||
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -21,7 +21,7 @@ IN: compiler.tests
|
|||
USE: math
|
||||
IN: compiler.tests.redefine10
|
||||
INSTANCE: float my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 2.0 ] [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: eval tools.test compiler.units vocabs multiline words
|
||||
kernel classes.mixin arrays ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine11
|
||||
|
||||
! Mixin redefinition did not recompile all necessary words.
|
||||
|
||||
|
|
@ -17,7 +17,7 @@ IN: compiler.tests
|
|||
M: my-mixin my-generic drop 0 ;
|
||||
M: object my-generic drop 1 ;
|
||||
: my-inline ( -- b ) { } my-generic ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
|
|||
|
|
@ -15,6 +15,6 @@ M: object g drop t ;
|
|||
|
||||
TUPLE: jeah ;
|
||||
|
||||
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test
|
||||
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test
|
||||
|
||||
[ f ] [ T{ jeah } h ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
USING: compiler.units definitions tools.test sequences ;
|
||||
IN: compiler.tests.redefine14
|
||||
|
||||
! TUPLE: bad ;
|
||||
!
|
||||
! M: bad length 1 2 3 ;
|
||||
!
|
||||
! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test
|
||||
TUPLE: bad ;
|
||||
|
||||
M: bad length 1 2 3 ;
|
||||
|
||||
[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test
|
||||
|
|
|
|||
|
|
@ -17,4 +17,4 @@ DEFER: word-1
|
|||
|
||||
[ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit
|
||||
|
||||
[ 2 3 ] [ 0 word-4 ] unit-test
|
||||
[ 2 3 ] [ 0 word-4 ] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
IN: compiler.tests.redefine16
|
||||
USING: eval tools.test definitions words compiler.units
|
||||
quotations stack-checker ;
|
||||
|
||||
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- )" eval( -- ) ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine16 USING: strings math arrays prettyprint ; M: string blah 1 + 3array . ;" eval( -- ) ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine16 GENERIC# blah 2 ( foo bar baz -- x )" eval( -- ) ] unit-test
|
||||
|
||||
[ ] [ [ "blah" "compiler.tests.redefine16" lookup forget ] with-compilation-unit ] unit-test
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
IN: compiler.tests.redefine17
|
||||
USING: tools.test classes.mixin compiler.units arrays kernel.private
|
||||
strings sequences vocabs definitions kernel ;
|
||||
|
||||
<< "compiler.tests.redefine17" words forget-all >>
|
||||
|
||||
GENERIC: bong ( a -- b )
|
||||
|
||||
M: array bong ;
|
||||
|
||||
M: string bong length ;
|
||||
|
||||
MIXIN: mixin
|
||||
|
||||
INSTANCE: array mixin
|
||||
|
||||
: blah ( a -- b ) { mixin } declare bong ;
|
||||
|
||||
[ { } ] [ { } blah ] unit-test
|
||||
|
||||
[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ 0 ] [ "" blah ] unit-test
|
||||
|
||||
MIXIN: mixin1
|
||||
|
||||
INSTANCE: string mixin1
|
||||
|
||||
MIXIN: mixin2
|
||||
|
||||
GENERIC: billy ( a -- b )
|
||||
|
||||
M: mixin2 billy ;
|
||||
|
||||
M: array billy drop "BILLY" ;
|
||||
|
||||
INSTANCE: string mixin2
|
||||
|
||||
: bully ( a -- b ) { mixin1 } declare billy ;
|
||||
|
||||
[ "" ] [ "" bully ] unit-test
|
||||
|
||||
[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ "BILLY" ] [ { } bully ] unit-test
|
||||
|
|
@ -1,11 +1,11 @@
|
|||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine2
|
||||
USING: compiler compiler.units tools.test math parser kernel
|
||||
sequences sequences.private classes.mixin generic definitions
|
||||
arrays words assocs eval words.symbol ;
|
||||
|
||||
DEFER: redefine2-test
|
||||
|
||||
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test
|
||||
[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
|
||||
|
||||
[ t ] [ \ redefine2-test symbol? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine3
|
||||
USING: accessors compiler compiler.units tools.test math parser
|
||||
kernel sequences sequences.private classes.mixin generic
|
||||
definitions arrays words assocs eval ;
|
||||
|
|
@ -14,11 +14,11 @@ M: empty-mixin sheeple drop "wake up" ;
|
|||
: sheeple-test ( -- string ) { } sheeple ;
|
||||
|
||||
[ "sheeple" ] [ sheeple-test ] unit-test
|
||||
[ t ] [ \ sheeple-test optimized>> ] unit-test
|
||||
[ t ] [ \ sheeple-test optimized? ] unit-test
|
||||
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
|
||||
|
||||
[ "wake up" ] [ sheeple-test ] unit-test
|
||||
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||
|
|
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
|
|||
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
|
||||
|
||||
[ "sheeple" ] [ sheeple-test ] unit-test
|
||||
[ t ] [ \ sheeple-test optimized>> ] unit-test
|
||||
[ t ] [ \ sheeple-test optimized? ] unit-test
|
||||
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine4
|
||||
USING: io.streams.string kernel tools.test eval ;
|
||||
|
||||
: declaration-test-1 ( -- a ) 3 ; flushable
|
||||
|
|
@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
|
|||
|
||||
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
|
||||
|
||||
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test
|
||||
[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
|
||||
|
||||
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: eval tools.test compiler.units vocabs multiline words
|
||||
kernel ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine5
|
||||
|
||||
! Regression: if dispatch was eliminated but method was not inlined,
|
||||
! compiled usage information was not recorded.
|
||||
|
|
@ -14,7 +14,7 @@ IN: compiler.tests
|
|||
GENERIC: my-generic ( a -- b )
|
||||
M: object my-generic [ <=> ] sort ;
|
||||
: my-inline ( a -- b ) my-generic ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -23,7 +23,7 @@ IN: compiler.tests
|
|||
IN: compiler.tests.redefine5
|
||||
TUPLE: my-tuple ;
|
||||
M: my-tuple my-generic drop 0 ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 0 ] [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: eval tools.test compiler.units vocabs multiline words
|
||||
kernel ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine6
|
||||
|
||||
! Mixin redefinition did not recompile all necessary words.
|
||||
|
||||
|
|
@ -14,7 +14,7 @@ IN: compiler.tests
|
|||
MIXIN: my-mixin
|
||||
M: my-mixin my-generic drop 0 ;
|
||||
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -24,7 +24,7 @@ IN: compiler.tests
|
|||
TUPLE: my-tuple ;
|
||||
M: my-tuple my-generic drop 1 ;
|
||||
INSTANCE: my-tuple my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 1 ] [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: eval tools.test compiler.units vocabs multiline words
|
||||
kernel ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine7
|
||||
|
||||
! Mixin redefinition did not recompile all necessary words.
|
||||
|
||||
|
|
@ -13,7 +13,7 @@ IN: compiler.tests
|
|||
MIXIN: my-mixin
|
||||
INSTANCE: fixnum my-mixin
|
||||
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -21,7 +21,7 @@ IN: compiler.tests
|
|||
USE: math
|
||||
IN: compiler.tests.redefine7
|
||||
INSTANCE: float my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 2.0 ] [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: eval tools.test compiler.units vocabs multiline words
|
||||
kernel ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine8
|
||||
|
||||
! Mixin redefinition did not recompile all necessary words.
|
||||
|
||||
|
|
@ -16,7 +16,7 @@ IN: compiler.tests
|
|||
! We add the bogus quotation here to hinder inlining
|
||||
! since otherwise we cannot trigger this bug.
|
||||
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -24,7 +24,7 @@ IN: compiler.tests
|
|||
USE: math
|
||||
IN: compiler.tests.redefine8
|
||||
INSTANCE: float my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ 2.0 ] [
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: eval tools.test compiler.units vocabs multiline words
|
||||
kernel generic.math ;
|
||||
IN: compiler.tests
|
||||
IN: compiler.tests.redefine9
|
||||
|
||||
! Mixin redefinition did not recompile all necessary words.
|
||||
|
||||
|
|
@ -16,7 +16,7 @@ IN: compiler.tests
|
|||
! We add the bogus quotation here to hinder inlining
|
||||
! since otherwise we cannot trigger this bug.
|
||||
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
@ -25,7 +25,7 @@ IN: compiler.tests
|
|||
IN: compiler.tests.redefine9
|
||||
TUPLE: my-tuple ;
|
||||
INSTANCE: my-tuple my-mixin
|
||||
"> eval
|
||||
"> eval( -- )
|
||||
] unit-test
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: compiler.tests
|
||||
IN: compiler.tests.reload
|
||||
USE: vocabs.loader
|
||||
|
||||
! "parser" reload
|
||||
|
|
|
|||
|
|
@ -1,9 +1,7 @@
|
|||
USING: compiler compiler.units tools.test kernel kernel.private
|
||||
sequences.private math.private math combinators strings alien
|
||||
arrays memory vocabs parser eval ;
|
||||
IN: compiler.tests
|
||||
|
||||
\ (compile) must-infer
|
||||
IN: compiler.tests.simple
|
||||
|
||||
! Test empty word
|
||||
[ ] [ [ ] compile-call ] unit-test
|
||||
|
|
@ -62,8 +60,8 @@ IN: compiler.tests
|
|||
|
||||
! Make sure error reporting works
|
||||
|
||||
[ [ dup ] compile-call ] must-fail
|
||||
[ [ drop ] compile-call ] must-fail
|
||||
! [ [ dup ] compile-call ] must-fail
|
||||
! [ [ drop ] compile-call ] must-fail
|
||||
|
||||
! Regression
|
||||
|
||||
|
|
@ -237,6 +235,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
|
|||
10 [
|
||||
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
|
||||
[ t ] [
|
||||
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
|
||||
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized?" eval( -- obj )
|
||||
] unit-test
|
||||
] times
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: math.private kernel combinators accessors arrays
|
||||
generalizations tools.test ;
|
||||
IN: compiler.tests
|
||||
generalizations tools.test words ;
|
||||
IN: compiler.tests.spilling
|
||||
|
||||
: float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b )
|
||||
{
|
||||
|
|
@ -47,7 +47,7 @@ IN: compiler.tests
|
|||
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
|
||||
[ 1.0 float-spill-bug ] unit-test
|
||||
|
||||
[ t ] [ \ float-spill-bug optimized>> ] unit-test
|
||||
[ t ] [ \ float-spill-bug optimized? ] unit-test
|
||||
|
||||
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
|
||||
{
|
||||
|
|
@ -132,7 +132,7 @@ IN: compiler.tests
|
|||
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
|
||||
[ 1.0 float-fixnum-spill-bug ] unit-test
|
||||
|
||||
[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
|
||||
[ t ] [ \ float-fixnum-spill-bug optimized? ] unit-test
|
||||
|
||||
: resolve-spill-bug ( a b -- c )
|
||||
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
|
||||
|
|
@ -159,7 +159,7 @@ IN: compiler.tests
|
|||
16 narray
|
||||
] if ;
|
||||
|
||||
[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
|
||||
[ t ] [ \ resolve-spill-bug optimized? ] unit-test
|
||||
|
||||
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
|
||||
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue