Merge branch 'master' of git://factorcode.org/git/factor
Conflicts: extra/combinators/lib/lib.factordb4
Joe Groff
commit
07baa20969
|
|
@ -15,5 +15,7 @@ factor
|
|||
.gdb_history
|
||||
*.*.marks
|
||||
.*.swp
|
||||
reverse-complement-in.txt
|
||||
reverse-complement-out.txt
|
||||
temp
|
||||
logs
|
||||
work
|
||||
misc/wordsize
|
||||
11
Makefile
11
Makefile
|
|
@ -45,7 +45,10 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
|
|||
|
||||
EXE_OBJS = $(PLAF_EXE_OBJS)
|
||||
|
||||
default:
|
||||
default: misc/wordsize
|
||||
make `./misc/target`
|
||||
|
||||
help:
|
||||
@echo "Run 'make' with one of the following parameters:"
|
||||
@echo ""
|
||||
@echo "freebsd-x86-32"
|
||||
|
|
@ -142,7 +145,8 @@ wince-arm:
|
|||
|
||||
macosx.app: factor
|
||||
mkdir -p $(BUNDLE)/Contents/MacOS
|
||||
cp $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
|
||||
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
|
||||
ln -s Factor.app/Contents/MacOS/factor ./factor
|
||||
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
|
||||
|
||||
install_name_tool \
|
||||
|
|
@ -158,6 +162,9 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
|
|||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
misc/wordsize: misc/wordsize.c
|
||||
gcc misc/wordsize.c -o misc/wordsize
|
||||
|
||||
clean:
|
||||
rm -f vm/*.o
|
||||
rm -f factor*.dll libfactor*.*
|
||||
|
|
|
|||
|
|
@ -52,7 +52,9 @@ The Factor runtime is written in GNU C99, and is built with GNU make and
|
|||
gcc.
|
||||
|
||||
Factor requires gcc 3.4 or later. On x86, it /will not/ build using gcc
|
||||
3.3 or earlier.
|
||||
3.3 or earlier. If you are using gcc 4.3, you might get an unusable
|
||||
Factor binary unless you add 'SITE_CFLAGS=-fno-forward-propagate' to the
|
||||
command-line arguments for make.
|
||||
|
||||
Run 'make' (or 'gmake' on *BSD) with no parameters to see a list of
|
||||
targets and build options. Then run 'make' with the appropriate target
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ $nl
|
|||
HELP: alien-invoke-error
|
||||
{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
|
||||
{ $list
|
||||
{ "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
|
||||
{ "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
|
||||
{ "The return type or parameter list references an unknown C type." }
|
||||
{ "The symbol or library could not be found." }
|
||||
{ "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." }
|
||||
|
|
@ -103,7 +103,7 @@ HELP: alien-invoke
|
|||
HELP: alien-indirect-error
|
||||
{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
|
||||
{ $list
|
||||
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
|
||||
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
|
||||
{ "The return type or parameter list references an unknown C type." }
|
||||
{ "One of the three inputs to " { $link alien-indirect } " is not a literal value." }
|
||||
}
|
||||
|
|
@ -120,7 +120,7 @@ HELP: alien-indirect
|
|||
HELP: alien-callback-error
|
||||
{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
|
||||
{ $list
|
||||
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
|
||||
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
|
||||
{ "The return type or parameter list references an unknown C type." }
|
||||
{ "One of the four inputs to " { $link alien-callback } " is not a literal value." }
|
||||
}
|
||||
|
|
@ -199,9 +199,7 @@ ARTICLE: "alien-invoke" "Calling C from Factor"
|
|||
{ $subsection alien-invoke }
|
||||
"Sometimes it is necessary to invoke a C function pointer, rather than a named C function:"
|
||||
{ $subsection alien-indirect }
|
||||
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
|
||||
$nl
|
||||
"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ;
|
||||
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ;
|
||||
|
||||
ARTICLE: "alien-callback-gc" "Callbacks and code GC"
|
||||
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: temporary
|
||||
IN: alien.tests
|
||||
USING: alien alien.accessors byte-arrays arrays kernel
|
||||
kernel.private namespaces tools.test sequences libc math system
|
||||
prettyprint ;
|
||||
prettyprint layouts ;
|
||||
|
||||
[ t ] [ -1 <alien> alien-address 0 > ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -84,33 +84,15 @@ HELP: alien>u16-string ( c-ptr -- string )
|
|||
{ $values { "c-ptr" c-ptr } { "string" string } }
|
||||
{ $description "Reads a null-terminated UCS-2 string from the specified address." } ;
|
||||
|
||||
HELP: memory>byte-array ( base len -- string )
|
||||
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
|
||||
HELP: memory>byte-array
|
||||
{ $values { "alien" c-ptr } { "len" "a non-negative integer" } { "byte-array" byte-array } }
|
||||
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new byte array." } ;
|
||||
|
||||
HELP: memory>char-string ( base len -- string )
|
||||
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
|
||||
{ $description "Reads " { $snippet "len" } " bytes starting from " { $snippet "base" } " and stores them in a new string." } ;
|
||||
|
||||
HELP: memory>u16-string ( base len -- string )
|
||||
{ $values { "base" c-ptr } { "len" "a non-negative integer" } { "string" string } }
|
||||
{ $description "Reads " { $snippet "len" } " UCS2 characters starting from " { $snippet "base" } " and stores them in a new string." } ;
|
||||
|
||||
HELP: byte-array>memory ( string base -- )
|
||||
HELP: byte-array>memory
|
||||
{ $values { "byte-array" byte-array } { "base" c-ptr } }
|
||||
{ $description "Writes a byte array to memory starting from the " { $snippet "base" } " address." }
|
||||
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
|
||||
|
||||
HELP: string>char-memory ( string base -- )
|
||||
{ $values { "string" string } { "base" c-ptr } }
|
||||
{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." }
|
||||
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
|
||||
|
||||
HELP: string>u16-memory ( string base -- )
|
||||
{ $values { "string" string } { "base" c-ptr } }
|
||||
{ $description "Writes a string to memory starting from the " { $snippet "base" } " address." }
|
||||
{ $warning "This word is unsafe. Improper use can corrupt memory." } ;
|
||||
|
||||
HELP: malloc-array
|
||||
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
|
||||
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
|
||||
|
|
@ -293,11 +275,7 @@ ARTICLE: "c-strings" "C strings"
|
|||
$nl
|
||||
"Finally, a set of words can be used to read and write " { $snippet "char*" } " and " { $snippet "ushort*" } " strings at arbitrary addresses:"
|
||||
{ $subsection alien>char-string }
|
||||
{ $subsection alien>u16-string }
|
||||
{ $subsection memory>char-string }
|
||||
{ $subsection memory>u16-string }
|
||||
{ $subsection string>char-memory }
|
||||
{ $subsection string>u16-memory } ;
|
||||
{ $subsection alien>u16-string } ;
|
||||
|
||||
ARTICLE: "c-data" "Passing data between Factor and C"
|
||||
"Two defining characteristics of Factor are dynamic typing and automatic memory management, which are somewhat incompatible with the machine-level data model exposed by C. Factor's C library interface defines its own set of C data types, distinct from Factor language types, together with automatic conversion between Factor values and C types. For example, C integer types must be declared and are fixed-width, whereas Factor supports arbitrary-precision integers. Also Factor's garbage collector can move objects in memory, which means that special support has to be provided for passing blocks of memory to C code."
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: alien.c-types.tests
|
||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: bit-arrays byte-arrays float-arrays arrays
|
|||
generator.registers assocs kernel kernel.private libc math
|
||||
namespaces parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
system compiler.units ;
|
||||
layouts system compiler.units io.files io.encodings.binary ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -155,20 +155,9 @@ M: float-array byte-length length "double" heap-size * ;
|
|||
: memory>byte-array ( alien len -- byte-array )
|
||||
dup <byte-array> [ -rot memcpy ] keep ;
|
||||
|
||||
: memory>char-string ( alien len -- string )
|
||||
memory>byte-array >string ;
|
||||
|
||||
DEFER: c-ushort-array>
|
||||
|
||||
: memory>u16-string ( alien len -- string )
|
||||
[ memory>byte-array ] keep 2/ c-ushort-array> >string ;
|
||||
|
||||
: byte-array>memory ( byte-array base -- )
|
||||
swap dup length memcpy ;
|
||||
|
||||
: string>char-memory ( string base -- )
|
||||
>r B{ } like r> byte-array>memory ;
|
||||
|
||||
DEFER: >c-ushort-array
|
||||
|
||||
: string>u16-memory ( string base -- )
|
||||
|
|
@ -273,6 +262,9 @@ M: long-long-type box-return ( type -- )
|
|||
r> add*
|
||||
] when ;
|
||||
|
||||
: malloc-file-contents ( path -- alien )
|
||||
binary file-contents malloc-byte-array ;
|
||||
|
||||
[
|
||||
[ alien-cell ]
|
||||
[ set-alien-cell ]
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: alien.compiler.tests
|
||||
USING: alien alien.c-types alien.syntax compiler kernel
|
||||
namespaces namespaces tools.test sequences inference words
|
||||
arrays parser quotations continuations inference.backend effects
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ inference.state inference.backend inference.dataflow system
|
|||
math.parser classes alien.arrays alien.c-types alien.structs
|
||||
alien.syntax cpu.architecture alien inspector quotations assocs
|
||||
kernel.private threads continuations.private libc combinators
|
||||
compiler.errors continuations ;
|
||||
compiler.errors continuations layouts ;
|
||||
IN: alien.compiler
|
||||
|
||||
! Common protocol for alien-invoke/alien-callback/alien-indirect
|
||||
|
|
@ -367,7 +367,7 @@ TUPLE: callback-context ;
|
|||
] if ;
|
||||
|
||||
: do-callback ( quot token -- )
|
||||
init-error-handler
|
||||
init-catchstack
|
||||
dup 2 setenv
|
||||
slip
|
||||
wait-to-return ; inline
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: alien.structs.tests
|
||||
USING: alien alien.syntax alien.c-types kernel tools.test
|
||||
sequences system libc words vocabs namespaces ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays kernel sequences sequences.private growable
|
||||
tools.test vectors layouts system math vectors.private ;
|
||||
IN: temporary
|
||||
IN: arrays.tests
|
||||
|
||||
[ -2 { "a" "b" "c" } nth ] must-fail
|
||||
[ 10 { "a" "b" "c" } nth ] must-fail
|
||||
|
|
|
|||
|
|
@ -162,6 +162,7 @@ HELP: assoc-each
|
|||
{ $description "Applies a quotation to each entry in the assoc." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: assocs kernel math prettyprint ;"
|
||||
"H{ { \"bananas\" 5 } { \"apples\" 42 } { \"pears\" 17 } }"
|
||||
"0 swap [ nip + ] assoc-each ."
|
||||
"64"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: assocs.tests
|
||||
USING: kernel math namespaces tools.test vectors sequences
|
||||
sequences.private hashtables io prettyprint assocs
|
||||
continuations ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: sequences arrays bit-arrays kernel tools.test math
|
||||
random ;
|
||||
IN: temporary
|
||||
IN: bit-arrays.tests
|
||||
|
||||
[ 100 ] [ 100 <bit-array> length ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: bit-vectors.tests
|
||||
USING: tools.test bit-vectors vectors sequences kernel math ;
|
||||
|
||||
[ 0 ] [ 123 <bit-vector> length ] unit-test
|
||||
|
|
|
|||
|
|
@ -16,6 +16,14 @@ IN: bootstrap.compiler
|
|||
|
||||
"cpu." cpu append require
|
||||
|
||||
: enable-compiler ( -- )
|
||||
[ optimized-recompile-hook ] recompile-hook set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
[ default-recompile-hook ] recompile-hook set-global ;
|
||||
|
||||
enable-compiler
|
||||
|
||||
nl
|
||||
"Compiling some words to speed up bootstrap..." write flush
|
||||
|
||||
|
|
@ -74,12 +82,4 @@ nl
|
|||
malloc free memcpy
|
||||
} compile
|
||||
|
||||
: enable-compiler ( -- )
|
||||
[ compiled-usages recompile ] recompile-hook set-global ;
|
||||
|
||||
: disable-compiler ( -- )
|
||||
[ default-recompile-hook ] recompile-hook set-global ;
|
||||
|
||||
enable-compiler
|
||||
|
||||
" done" print flush
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: bootstrap.image.tests
|
||||
USING: bootstrap.image bootstrap.image.private tools.test ;
|
||||
|
||||
\ ' must-infer
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ strings sbufs vectors words quotations assocs system layouts
|
|||
splitting growable classes tuples words.private
|
||||
io.binary io.files vocabs vocabs.loader source-files
|
||||
definitions debugger float-arrays quotations.private
|
||||
sequences.private combinators ;
|
||||
sequences.private combinators io.encodings.binary ;
|
||||
IN: bootstrap.image
|
||||
|
||||
: my-arch ( -- arch )
|
||||
|
|
@ -191,7 +191,9 @@ M: bignum '
|
|||
M: fixnum '
|
||||
#! When generating a 32-bit image on a 64-bit system,
|
||||
#! some fixnums should be bignums.
|
||||
dup most-negative-fixnum most-positive-fixnum between?
|
||||
dup
|
||||
bootstrap-most-negative-fixnum
|
||||
bootstrap-most-positive-fixnum between?
|
||||
[ tag-fixnum ] [ >bignum ' ] if ;
|
||||
|
||||
! Floats
|
||||
|
|
@ -416,7 +418,7 @@ M: curry '
|
|||
"Writing image to " write
|
||||
architecture get boot-image-name resource-path
|
||||
dup write "..." print flush
|
||||
[ (write-image) ] with-file-writer ;
|
||||
binary <file-writer> [ (write-image) ] with-stream ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
|
|
@ -30,7 +30,10 @@ crossref off
|
|||
"syntax" vocab vocab-words bootstrap-syntax set
|
||||
H{ } clone dictionary set
|
||||
H{ } clone changed-words set
|
||||
[ drop ] recompile-hook set
|
||||
|
||||
! Trivial recompile hook. We don't want to touch the code heap
|
||||
! during stage1 bootstrap, it would just waste time.
|
||||
[ drop { } ] recompile-hook set
|
||||
|
||||
call
|
||||
call
|
||||
|
|
@ -75,6 +78,7 @@ call
|
|||
"strings"
|
||||
"strings.private"
|
||||
"system"
|
||||
"system.private"
|
||||
"threads.private"
|
||||
"tools.profiler.private"
|
||||
"tuples"
|
||||
|
|
@ -271,7 +275,7 @@ define-builtin
|
|||
}
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
"?"
|
||||
"compiled?"
|
||||
{ "compiled?" "words" }
|
||||
f
|
||||
}
|
||||
|
|
@ -620,6 +624,7 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "fopen" "io.streams.c" }
|
||||
{ "fgetc" "io.streams.c" }
|
||||
{ "fread" "io.streams.c" }
|
||||
{ "fputc" "io.streams.c" }
|
||||
{ "fwrite" "io.streams.c" }
|
||||
{ "fflush" "io.streams.c" }
|
||||
{ "fclose" "io.streams.c" }
|
||||
|
|
@ -642,7 +647,8 @@ builtins get num-tags get tail f union-class define-class
|
|||
{ "innermost-frame-scan" "kernel.private" }
|
||||
{ "set-innermost-frame-quot" "kernel.private" }
|
||||
{ "call-clear" "kernel" }
|
||||
{ "(os-envs)" "system" }
|
||||
{ "(os-envs)" "system.private" }
|
||||
{ "(set-os-envs)" "system.private" }
|
||||
{ "resize-byte-array" "byte-arrays" }
|
||||
{ "resize-bit-array" "bit-arrays" }
|
||||
{ "resize-float-array" "float-arrays" }
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: bootstrap.stage1
|
||||
USING: arrays debugger generic hashtables io assocs
|
||||
kernel.private kernel math memory namespaces parser
|
||||
prettyprint sequences vectors words system splitting
|
||||
init io.files bootstrap.image bootstrap.image.private vocabs
|
||||
vocabs.loader system ;
|
||||
vocabs.loader system debugger continuations ;
|
||||
|
||||
{ "resource:core" } vocab-roots set
|
||||
|
||||
|
|
@ -40,7 +40,14 @@ vocabs.loader system ;
|
|||
[
|
||||
"resource:core/bootstrap/stage2.factor"
|
||||
dup resource-exists? [
|
||||
run-file
|
||||
[ run-file ]
|
||||
[
|
||||
:c
|
||||
dup print-error flush
|
||||
"listener" vocab
|
||||
[ restarts. vocab-main execute ]
|
||||
[ die ] if*
|
||||
] recover
|
||||
] [
|
||||
"Cannot find " write write "." print
|
||||
"Please move " write image write " to the same directory as the Factor sources," print
|
||||
|
|
|
|||
|
|
@ -29,9 +29,7 @@ SYMBOL: bootstrap-time
|
|||
|
||||
: compile-remaining ( -- )
|
||||
"Compiling remaining words..." print flush
|
||||
vocabs [
|
||||
words "compile" "compiler" lookup execute
|
||||
] each ;
|
||||
vocabs [ words [ compiled? not ] subset compile ] each ;
|
||||
|
||||
: count-words ( pred -- )
|
||||
all-words swap subset length number>string write ;
|
||||
|
|
@ -53,66 +51,60 @@ SYMBOL: bootstrap-time
|
|||
! Wrap everything in a catch which starts a listener so
|
||||
! you can see what went wrong, instead of dealing with a
|
||||
! fep
|
||||
[
|
||||
! We time bootstrap
|
||||
millis >r
|
||||
|
||||
default-image-name "output-image" set-global
|
||||
! We time bootstrap
|
||||
millis >r
|
||||
|
||||
"math help handbook compiler tools ui ui.tools io" "include" set-global
|
||||
"" "exclude" set-global
|
||||
default-image-name "output-image" set-global
|
||||
|
||||
parse-command-line
|
||||
"math help handbook compiler tools ui ui.tools io" "include" set-global
|
||||
"" "exclude" set-global
|
||||
|
||||
"-no-crossref" cli-args member? [ do-crossref ] unless
|
||||
parse-command-line
|
||||
|
||||
! Set dll paths
|
||||
wince? [ "windows.ce" require ] when
|
||||
winnt? [ "windows.nt" require ] when
|
||||
"-no-crossref" cli-args member? [ do-crossref ] unless
|
||||
|
||||
"deploy-vocab" get [
|
||||
"stage2: deployment mode" print
|
||||
] [
|
||||
"listener" require
|
||||
"none" require
|
||||
] if
|
||||
! Set dll paths
|
||||
wince? [ "windows.ce" require ] when
|
||||
winnt? [ "windows.nt" require ] when
|
||||
|
||||
[
|
||||
load-components
|
||||
|
||||
run-bootstrap-init
|
||||
|
||||
"bootstrap.compiler" vocab [
|
||||
compile-remaining
|
||||
] when
|
||||
] with-compiler-errors
|
||||
:errors
|
||||
|
||||
f error set-global
|
||||
f error-continuation set-global
|
||||
|
||||
"deploy-vocab" get [
|
||||
"tools.deploy.shaker" run
|
||||
] [
|
||||
[
|
||||
boot
|
||||
do-init-hooks
|
||||
[
|
||||
parse-command-line
|
||||
run-user-init
|
||||
"run" get run
|
||||
stdio get [ stream-flush ] when*
|
||||
] [ print-error 1 exit ] recover
|
||||
] set-boot-quot
|
||||
|
||||
millis r> - dup bootstrap-time set-global
|
||||
print-report
|
||||
|
||||
"output-image" get resource-path save-image-and-exit
|
||||
] if
|
||||
"deploy-vocab" get [
|
||||
"stage2: deployment mode" print
|
||||
] [
|
||||
:c
|
||||
print-error restarts.
|
||||
"listener" vocab-main execute
|
||||
1 exit
|
||||
] recover
|
||||
"listener" require
|
||||
"none" require
|
||||
] if
|
||||
|
||||
[
|
||||
load-components
|
||||
|
||||
run-bootstrap-init
|
||||
|
||||
"bootstrap.compiler" vocab [
|
||||
compile-remaining
|
||||
] when
|
||||
] with-compiler-errors
|
||||
:errors
|
||||
|
||||
f error set-global
|
||||
f error-continuation set-global
|
||||
|
||||
"deploy-vocab" get [
|
||||
"tools.deploy.shaker" run
|
||||
] [
|
||||
[
|
||||
boot
|
||||
do-init-hooks
|
||||
[
|
||||
parse-command-line
|
||||
run-user-init
|
||||
"run" get run
|
||||
stdio get [ stream-flush ] when*
|
||||
] [ print-error 1 exit ] recover
|
||||
] set-boot-quot
|
||||
|
||||
millis r> - dup bootstrap-time set-global
|
||||
print-report
|
||||
|
||||
"output-image" get resource-path save-image-and-exit
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ HELP: box>
|
|||
{ $errors "Throws an error if the box is empty." } ;
|
||||
|
||||
HELP: ?box
|
||||
{ $values { "box" box } { "value" "the value of the box or " { $link f } } { "?" "a boolean" } }
|
||||
{ $values { "box" box } { "value/f" "the value of the box or " { $link f } } { "?" "a boolean" } }
|
||||
{ $description "If the box is full, removes the value from the box and pushes " { $link t } ". If the box is empty pushes " { $snippet "f f" } "." } ;
|
||||
|
||||
ARTICLE: "boxes" "Boxes"
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: boxes.tests
|
||||
USING: boxes namespaces tools.test ;
|
||||
|
||||
[ ] [ <box> "b" set ] unit-test
|
||||
|
|
|
|||
|
|
@ -19,3 +19,6 @@ TUPLE: box value full? ;
|
|||
|
||||
: ?box ( box -- value/f ? )
|
||||
dup box-full? [ box> t ] [ drop f f ] if ;
|
||||
|
||||
: if-box? ( box quot -- )
|
||||
>r ?box r> [ drop ] if ; inline
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: byte-arrays.tests
|
||||
USING: tools.test byte-arrays ;
|
||||
|
||||
[ B{ 1 2 3 0 0 0 } ] [ 6 B{ 1 2 3 } resize-byte-array ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: byte-vectors.tests
|
||||
USING: tools.test byte-vectors vectors sequences kernel ;
|
||||
|
||||
[ 0 ] [ 123 <byte-vector> length ] unit-test
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ IN: byte-vectors
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: byte-array>vector ( byte-array capacity -- byte-vector )
|
||||
: byte-array>vector ( byte-array length -- byte-vector )
|
||||
byte-vector construct-boa ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: generic help.markup help.syntax kernel kernel.private
|
||||
USING: help.markup help.syntax kernel kernel.private
|
||||
namespaces sequences words arrays layouts help effects math
|
||||
layouts classes.private classes.union classes.mixin
|
||||
classes.predicate ;
|
||||
|
|
@ -7,11 +7,6 @@ IN: classes
|
|||
ARTICLE: "builtin-classes" "Built-in classes"
|
||||
"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
|
||||
$nl
|
||||
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
|
||||
{ $subsection type }
|
||||
"Built-in type numbers can be converted to classes, and vice versa:"
|
||||
{ $subsection type>class }
|
||||
{ $subsection type-number }
|
||||
"The set of built-in classes is a class:"
|
||||
{ $subsection builtin-class }
|
||||
{ $subsection builtin-class? }
|
||||
|
|
@ -79,7 +74,7 @@ HELP: class
|
|||
{ $values { "object" object } { "class" class } }
|
||||
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
|
||||
{ $class-description "The class of all class words. Subclasses include " { $link builtin-class } ", " { $link union-class } ", " { $link mixin-class } ", " { $link predicate-class } " and " { $link tuple-class } "." }
|
||||
{ $examples { $example "USE: classes" "1.0 class ." "float" } { $example "USE: classes" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
|
||||
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ;
|
||||
|
||||
HELP: classes
|
||||
{ $values { "seq" "a sequence of class words" } }
|
||||
|
|
@ -89,14 +84,14 @@ HELP: builtin-class
|
|||
{ $class-description "The class of built-in classes." }
|
||||
{ $examples
|
||||
"The class of arrays is a built-in class:"
|
||||
{ $example "USE: classes" "array builtin-class? ." "t" }
|
||||
"However, a literal array is not a built-in class; it is not even a class:"
|
||||
{ $example "USE: classes" "{ 1 2 3 } builtin-class? ." "f" }
|
||||
{ $example "USING: arrays classes prettyprint ;" "array builtin-class? ." "t" }
|
||||
"However, an instance of the array class is not a built-in class; it is not even a class:"
|
||||
{ $example "USING: classes prettyprint ;" "{ 1 2 3 } builtin-class? ." "f" }
|
||||
} ;
|
||||
|
||||
HELP: tuple-class
|
||||
{ $class-description "The class of tuple class words." }
|
||||
{ $examples { $example "USE: classes\nTUPLE: name title first last ;\nname tuple-class? ." "t" } } ;
|
||||
{ $examples { $example "USING: classes prettyprint ;" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
|
||||
|
||||
HELP: typemap
|
||||
{ $var-description "Hashtable mapping unions to class words, used to implement " { $link class-and } " and " { $link class-or } "." } ;
|
||||
|
|
@ -167,7 +162,7 @@ HELP: types
|
|||
HELP: class-empty?
|
||||
{ $values { "class" "a class" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a class is a union class with no members." }
|
||||
{ $examples { $example "USE: classes" "null class-empty? ." "t" } } ;
|
||||
{ $examples { $example "USING: classes kernel prettyprint ;" "null class-empty? ." "t" } } ;
|
||||
|
||||
HELP: (class<)
|
||||
{ $values { "class1" "a class" } { "class2" "a class" } { "?" "a boolean" } }
|
||||
|
|
@ -182,8 +177,6 @@ HELP: sort-classes
|
|||
{ $values { "seq" "a sequence of class" } { "newseq" "a new seqence of classes" } }
|
||||
{ $description "Outputs a topological sort of a sequence of classes. Larger classes come before their subclasses." } ;
|
||||
|
||||
{ sort-classes methods order } related-words
|
||||
|
||||
HELP: lookup-union
|
||||
{ $values { "classes" "a hashtable mapping class words to themselves" } { "class" class } }
|
||||
{ $description "Given a set of classes represented as a hashtable with equal keys and values, looks up a previously-defined union class having those members. If no union is defined, outputs " { $link object } "." } ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings
|
|||
tools.test vectors words quotations classes io.streams.string
|
||||
classes.private classes.union classes.mixin classes.predicate
|
||||
vectors definitions source-files compiler.units ;
|
||||
IN: temporary
|
||||
IN: classes.tests
|
||||
|
||||
H{ } "s" set
|
||||
|
||||
|
|
@ -56,13 +56,13 @@ UNION: c a b ;
|
|||
[ t ] [ \ c \ tuple class< ] unit-test
|
||||
[ f ] [ \ tuple \ c class< ] unit-test
|
||||
|
||||
DEFER: bah
|
||||
FORGET: bah
|
||||
! DEFER: bah
|
||||
! FORGET: bah
|
||||
UNION: bah fixnum alien ;
|
||||
[ bah ] [ \ bah? "predicating" word-prop ] unit-test
|
||||
|
||||
! Test generic see and parsing
|
||||
[ "USING: alien math ;\nIN: temporary\nUNION: bah fixnum alien ;\n" ]
|
||||
[ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ]
|
||||
[ [ \ bah see ] with-string-writer ] unit-test
|
||||
|
||||
! Test redefinition of classes
|
||||
|
|
@ -78,7 +78,7 @@ M: union-1 generic-update-test drop "union-1" ;
|
|||
|
||||
[ union-1 ] [ fixnum float class-or ] unit-test
|
||||
|
||||
"IN: temporary USE: math USE: arrays UNION: union-1 rational array ;" eval
|
||||
"IN: classes.tests USE: math USE: arrays UNION: union-1 rational array ;" eval
|
||||
|
||||
[ t ] [ bignum union-1 class< ] unit-test
|
||||
[ f ] [ union-1 number class< ] unit-test
|
||||
|
|
@ -86,7 +86,7 @@ M: union-1 generic-update-test drop "union-1" ;
|
|||
|
||||
[ object ] [ fixnum float class-or ] unit-test
|
||||
|
||||
"IN: temporary USE: math PREDICATE: integer union-1 even? ;" eval
|
||||
"IN: classes.tests USE: math PREDICATE: integer union-1 even? ;" eval
|
||||
|
||||
[ f ] [ union-1 union-class? ] unit-test
|
||||
[ t ] [ union-1 predicate-class? ] unit-test
|
||||
|
|
@ -126,7 +126,7 @@ INSTANCE: integer mx1
|
|||
[ t ] [ mx1 integer class< ] unit-test
|
||||
[ t ] [ mx1 number class< ] unit-test
|
||||
|
||||
"IN: temporary USE: arrays INSTANCE: array mx1" eval
|
||||
"IN: classes.tests USE: arrays INSTANCE: array mx1" eval
|
||||
|
||||
[ t ] [ array mx1 class< ] unit-test
|
||||
[ f ] [ mx1 number class< ] unit-test
|
||||
|
|
@ -157,7 +157,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ;
|
|||
[ t ] [ quotation redefine-bug-2 class< ] unit-test
|
||||
[ redefine-bug-2 ] [ fixnum quotation class-or ] unit-test
|
||||
|
||||
[ ] [ "IN: temporary USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
|
||||
[ ] [ "IN: classes.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test
|
||||
|
||||
[ t ] [ bignum redefine-bug-1 class< ] unit-test
|
||||
[ f ] [ fixnum redefine-bug-2 class< ] unit-test
|
||||
|
|
@ -185,7 +185,7 @@ DEFER: mixin-forget-test-g
|
|||
[ ] [
|
||||
{
|
||||
"USING: sequences ;"
|
||||
"IN: temporary"
|
||||
"IN: classes.tests"
|
||||
"MIXIN: mixin-forget-test"
|
||||
"INSTANCE: sequence mixin-forget-test"
|
||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||
|
|
@ -200,7 +200,7 @@ DEFER: mixin-forget-test-g
|
|||
[ ] [
|
||||
{
|
||||
"USING: hashtables ;"
|
||||
"IN: temporary"
|
||||
"IN: classes.tests"
|
||||
"MIXIN: mixin-forget-test"
|
||||
"INSTANCE: hashtable mixin-forget-test"
|
||||
"GENERIC: mixin-forget-test-g ( x -- y )"
|
||||
|
|
|
|||
|
|
@ -255,8 +255,7 @@ PRIVATE>
|
|||
|
||||
: (define-class) ( word props -- )
|
||||
over reset-class
|
||||
over reset-generic
|
||||
over define-symbol
|
||||
over deferred? [ over define-symbol ] when
|
||||
>r dup word-props r> union over set-word-props
|
||||
t "class" set-word-prop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -82,7 +82,7 @@ HELP: with-datastack
|
|||
{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
|
||||
{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
|
||||
{ $examples
|
||||
{ $example "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
|
||||
{ $example "USING: combinators math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
|
||||
} ;
|
||||
|
||||
HELP: recursive-hashcode
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: combinators.tests
|
||||
USING: alien strings kernel math tools.test io prettyprint
|
||||
namespaces combinators words ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: namespaces tools.test kernel command-line ;
|
||||
IN: temporary
|
||||
IN: command-line.tests
|
||||
|
||||
[
|
||||
[ f ] [ "-no-user-init" cli-arg ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,18 +1,14 @@
|
|||
USING: generator help.markup help.syntax words io parser
|
||||
assocs words.private sequences ;
|
||||
assocs words.private sequences compiler.units ;
|
||||
IN: compiler
|
||||
|
||||
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
||||
"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
|
||||
$nl
|
||||
"The main entry points to the optimizing compiler:"
|
||||
{ $subsection compile }
|
||||
{ $subsection recompile }
|
||||
{ $subsection recompile-all }
|
||||
"The main entry point to the optimizing compiler:"
|
||||
{ $subsection optimized-recompile-hook }
|
||||
"Removing a word's optimized definition:"
|
||||
{ $subsection decompile }
|
||||
"The optimizing compiler can also compile and call a single quotation:"
|
||||
{ $subsection compile-call } ;
|
||||
{ $subsection decompile } ;
|
||||
|
||||
ARTICLE: "compiler" "Optimizing compiler"
|
||||
"Factor is a fully compiled language implementation with two distinct compilers:"
|
||||
|
|
@ -26,22 +22,6 @@ ARTICLE: "compiler" "Optimizing compiler"
|
|||
|
||||
ABOUT: "compiler"
|
||||
|
||||
HELP: compile
|
||||
{ $values { "seq" "a sequence of words" } }
|
||||
{ $description "Compiles a set of words. Ignores words which are already compiled." } ;
|
||||
|
||||
HELP: recompile
|
||||
{ $values { "seq" "a sequence of words" } }
|
||||
{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ;
|
||||
|
||||
HELP: compile-call
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Compiles and runs a quotation." }
|
||||
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
|
||||
|
||||
HELP: recompile-all
|
||||
{ $description "Recompiles all words." } ;
|
||||
|
||||
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." } ;
|
||||
|
|
@ -50,3 +30,8 @@ HELP: (compile)
|
|||
{ $values { "word" word } }
|
||||
{ $description "Compile a single word." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
||||
HELP: optimized-recompile-hook
|
||||
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
|
||||
{ $description "Compile a set of words." }
|
||||
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
|
||||
|
|
|
|||
|
|
@ -4,14 +4,9 @@ USING: kernel namespaces arrays sequences io inference.backend
|
|||
inference.state generator debugger math.parser prettyprint words
|
||||
compiler.units continuations vocabs assocs alien.compiler dlists
|
||||
optimizer definitions math compiler.errors threads graphs
|
||||
generic ;
|
||||
generic inference ;
|
||||
IN: compiler
|
||||
|
||||
: compiled-usages ( words -- seq )
|
||||
[ [ dup ] H{ } map>assoc dup ] keep [
|
||||
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
|
||||
] with each keys ;
|
||||
|
||||
: ripple-up ( word -- )
|
||||
compiled-usage [ drop queue-compile ] assoc-each ;
|
||||
|
||||
|
|
@ -49,27 +44,17 @@ IN: compiler
|
|||
compile-loop
|
||||
] if ;
|
||||
|
||||
: recompile ( words -- )
|
||||
: decompile ( word -- )
|
||||
f 2array 1array t modify-code-heap ;
|
||||
|
||||
: optimized-recompile-hook ( words -- alist )
|
||||
[
|
||||
H{ } clone compile-queue set
|
||||
H{ } clone compiled set
|
||||
[ queue-compile ] each
|
||||
compile-queue get compile-loop
|
||||
compiled get >alist
|
||||
dup [ drop crossref? ] assoc-contains?
|
||||
modify-code-heap
|
||||
] with-scope ; inline
|
||||
|
||||
: compile ( words -- )
|
||||
[ compiled? not ] subset recompile ;
|
||||
|
||||
: compile-call ( quot -- )
|
||||
H{ } clone changed-words
|
||||
[ define-temp dup 1array compile ] with-variable
|
||||
execute ;
|
||||
] with-scope ;
|
||||
|
||||
: recompile-all ( -- )
|
||||
[ all-words recompile ] with-compiler-errors ;
|
||||
|
||||
: decompile ( word -- )
|
||||
f 2array 1array t modify-code-heap ;
|
||||
forget-errors all-words compile ;
|
||||
|
|
|
|||
|
|
@ -24,8 +24,8 @@ HELP: compiler-error.
|
|||
{ $description "Prints a compiler error to the " { $link stdio } " stream." } ;
|
||||
|
||||
HELP: compiler-errors.
|
||||
{ $values { "errors" "an assoc mapping words to errors" } }
|
||||
{ $description "Prints a set of compiler errors to the " { $link stdio } " stream." } ;
|
||||
{ $values { "type" symbol } }
|
||||
{ $description "Prints compiler errors to the " { $link stdio } " stream. The type parameter is one of " { $link +error+ } ", " { $link +warning+ } ", or " { $link +linkage+ } "." } ;
|
||||
HELP: :errors
|
||||
{ $description "Prints all serious compiler errors from the most recent compile to the " { $link stdio } " stream." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: tools.test compiler quotations math kernel sequences
|
||||
assocs namespaces ;
|
||||
IN: temporary
|
||||
USING: tools.test quotations math kernel sequences
|
||||
assocs namespaces compiler.units ;
|
||||
IN: compiler.tests
|
||||
|
||||
[ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test
|
||||
[ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: temporary
|
||||
USING: compiler kernel kernel.private memory math
|
||||
IN: compiler.tests
|
||||
USING: compiler.units kernel kernel.private memory math
|
||||
math.private tools.test math.floats.private ;
|
||||
|
||||
[ 5.0 ] [ [ 5.0 ] compile-call data-gc data-gc data-gc ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
IN: temporary
|
||||
USING: arrays compiler kernel kernel.private math math.constants
|
||||
math.private sequences strings tools.test words continuations
|
||||
sequences.private hashtables.private byte-arrays strings.private
|
||||
system random layouts vectors.private sbufs.private
|
||||
strings.private slots.private alien alien.accessors
|
||||
alien.c-types alien.syntax namespaces libc sequences.private ;
|
||||
IN: compiler.tests
|
||||
USING: arrays compiler.units kernel kernel.private math
|
||||
math.constants math.private sequences strings tools.test words
|
||||
continuations sequences.private hashtables.private byte-arrays
|
||||
strings.private system random layouts vectors.private
|
||||
sbufs.private strings.private slots.private alien
|
||||
alien.accessors alien.c-types alien.syntax namespaces libc
|
||||
sequences.private ;
|
||||
|
||||
! Make sure that intrinsic ops compile to correct code.
|
||||
[ ] [ 1 [ drop ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: compiler tools.test kernel kernel.private
|
||||
USING: compiler.units tools.test kernel kernel.private
|
||||
sequences.private math.private math combinators strings
|
||||
alien arrays memory ;
|
||||
IN: temporary
|
||||
IN: compiler.tests
|
||||
|
||||
! Test empty word
|
||||
[ ] [ [ ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: compiler.tests
|
||||
USING: compiler tools.test namespaces sequences
|
||||
kernel.private kernel math continuations continuations.private
|
||||
words splitting sorting ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! Testing templates machinery without compiling anything
|
||||
IN: temporary
|
||||
IN: compiler.tests
|
||||
USING: compiler generator generator.registers
|
||||
generator.registers.private tools.test namespaces sequences
|
||||
words kernel math effects definitions compiler.units ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ hashtables.private math.private namespaces sequences
|
|||
sequences.private tools.test namespaces.private slots.private
|
||||
sequences.private byte-arrays alien alien.accessors layouts
|
||||
words definitions compiler.units io combinators ;
|
||||
IN: temporary
|
||||
IN: compiler.tests
|
||||
|
||||
! Oops!
|
||||
[ 5000 ] [ [ 5000 ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: temporary
|
||||
USING: kernel tools.test compiler ;
|
||||
IN: compiler.tests
|
||||
USING: kernel tools.test compiler.units ;
|
||||
|
||||
TUPLE: color red green blue ;
|
||||
|
||||
|
|
|
|||
|
|
@ -61,3 +61,11 @@ HELP: modify-code-heap ( alist -- )
|
|||
{ { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." }
|
||||
} }
|
||||
{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;
|
||||
|
||||
HELP: compile
|
||||
{ $values { "words" "a sequence of words" } }
|
||||
{ $description "Compiles a set of words." } ;
|
||||
|
||||
HELP: compile-call
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Compiles and runs a quotation." } ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel continuations assocs namespaces sequences words
|
||||
vocabs definitions hashtables ;
|
||||
vocabs definitions hashtables init ;
|
||||
IN: compiler.units
|
||||
|
||||
SYMBOL: old-definitions
|
||||
|
|
@ -37,10 +37,11 @@ SYMBOL: recompile-hook
|
|||
|
||||
SYMBOL: definition-observers
|
||||
|
||||
definition-observers global [ V{ } like ] change-at
|
||||
|
||||
GENERIC: definitions-changed ( assoc obj -- )
|
||||
|
||||
[ V{ } clone definition-observers set-global ]
|
||||
"compiler.units" add-init-hook
|
||||
|
||||
: add-definition-observer ( obj -- )
|
||||
definition-observers get push ;
|
||||
|
||||
|
|
@ -63,24 +64,45 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
dup changed-words get update
|
||||
dup dup changed-vocabs update ;
|
||||
|
||||
: compile ( words -- )
|
||||
recompile-hook get call
|
||||
dup [ drop crossref? ] assoc-contains?
|
||||
modify-code-heap ;
|
||||
|
||||
SYMBOL: post-compile-tasks
|
||||
|
||||
: after-compilation ( quot -- )
|
||||
post-compile-tasks get push ;
|
||||
|
||||
: call-recompile-hook ( -- )
|
||||
changed-words get keys
|
||||
compiled-usages recompile-hook get call ;
|
||||
|
||||
: call-post-compile-tasks ( -- )
|
||||
post-compile-tasks get [ call ] each ;
|
||||
|
||||
: finish-compilation-unit ( -- )
|
||||
changed-words get keys recompile-hook get call
|
||||
call-recompile-hook
|
||||
call-post-compile-tasks
|
||||
dup [ drop crossref? ] assoc-contains? modify-code-heap
|
||||
changed-definitions notify-definition-observers ;
|
||||
|
||||
: with-compilation-unit ( quot -- )
|
||||
[
|
||||
H{ } clone changed-words set
|
||||
H{ } clone forgotten-definitions set
|
||||
V{ } clone post-compile-tasks set
|
||||
<definitions> new-definitions set
|
||||
<definitions> old-definitions set
|
||||
[ finish-compilation-unit ]
|
||||
[ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
: default-recompile-hook
|
||||
[ f ] { } map>assoc
|
||||
dup [ drop crossref? ] assoc-contains?
|
||||
modify-code-heap ;
|
||||
: compile-call ( quot -- )
|
||||
[ define-temp ] with-compilation-unit execute ;
|
||||
|
||||
: default-recompile-hook ( words -- alist )
|
||||
[ f ] { } map>assoc ;
|
||||
|
||||
recompile-hook global
|
||||
[ [ default-recompile-hook ] or ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax kernel kernel.private
|
||||
continuations.private parser vectors arrays namespaces
|
||||
threads assocs words quotations ;
|
||||
assocs words quotations ;
|
||||
IN: continuations
|
||||
|
||||
ARTICLE: "errors-restartable" "Restartable errors"
|
||||
|
|
@ -23,9 +23,10 @@ $nl
|
|||
"Two words raise an error in the innermost error handler for the current dynamic extent:"
|
||||
{ $subsection throw }
|
||||
{ $subsection rethrow }
|
||||
"Two words for establishing an error handler:"
|
||||
"Words for establishing an error handler:"
|
||||
{ $subsection cleanup }
|
||||
{ $subsection recover }
|
||||
{ $subsection ignore-errors }
|
||||
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
|
||||
{ $subsection "errors-restartable" }
|
||||
{ $subsection "errors-post-mortem" } ;
|
||||
|
|
@ -44,11 +45,7 @@ ARTICLE: "continuations.private" "Continuation implementation details"
|
|||
{ $subsection namestack }
|
||||
{ $subsection set-namestack }
|
||||
{ $subsection catchstack }
|
||||
{ $subsection set-catchstack }
|
||||
"The continuations implementation has hooks for single-steppers:"
|
||||
{ $subsection walker-hook }
|
||||
{ $subsection set-walker-hook }
|
||||
{ $subsection (continue-with) } ;
|
||||
{ $subsection set-catchstack } ;
|
||||
|
||||
ARTICLE: "continuations" "Continuations"
|
||||
"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
|
||||
|
|
@ -110,10 +107,6 @@ HELP: callcc1
|
|||
{ $values { "quot" "a quotation with stack effect " { $snippet "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
|
||||
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
|
||||
|
||||
HELP: (continue-with)
|
||||
{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
|
||||
{ $description "Resumes a continuation reified by " { $link callcc1 } " without invoking " { $link walker-hook } ". The object will be placed on the data stack when the continuation resumes." } ;
|
||||
|
||||
HELP: continue
|
||||
{ $values { "continuation" continuation } }
|
||||
{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ;
|
||||
|
|
@ -156,6 +149,10 @@ HELP: recover
|
|||
{ $values { "try" quotation } { "recovery" "a quotation with stack effect " { $snippet "( error -- )" } } }
|
||||
{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
|
||||
|
||||
HELP: ignore-errors
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;
|
||||
|
||||
HELP: rethrow
|
||||
{ $values { "error" object } }
|
||||
{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
|
||||
|
|
@ -196,9 +193,3 @@ HELP: save-error
|
|||
{ $values { "error" "an error" } }
|
||||
{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: init-error-handler
|
||||
{ $description "Called on startup to initialize the catch stack and set a pair of hooks which allow the Factor VM to signal errors to library code." } ;
|
||||
|
||||
HELP: break
|
||||
{ $description "Suspends execution of the current thread and starts the single stepper by calling " { $link break-hook } "." } ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: kernel math namespaces io tools.test sequences vectors
|
||||
continuations debugger parser memory arrays words
|
||||
kernel.private ;
|
||||
IN: temporary
|
||||
IN: continuations.tests
|
||||
|
||||
: (callcc1-test)
|
||||
swap 1- tuck swap ?push
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ IN: continuations
|
|||
|
||||
SYMBOL: error
|
||||
SYMBOL: error-continuation
|
||||
SYMBOL: error-thread
|
||||
SYMBOL: restarts
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -24,6 +25,8 @@ SYMBOL: restarts
|
|||
#! with a declaration.
|
||||
f { object } declare ;
|
||||
|
||||
: init-catchstack V{ } clone 1 setenv ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: catchstack ( -- catchstack ) catchstack* clone ; inline
|
||||
|
|
@ -91,14 +94,8 @@ C: <continuation> continuation
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: set-walker-hook ( quot -- ) 3 setenv ; inline
|
||||
|
||||
: walker-hook ( -- quot ) 3 getenv f set-walker-hook ; inline
|
||||
|
||||
: continue-with ( obj continuation -- )
|
||||
[
|
||||
walker-hook [ >r 2array r> ] when* (continue-with)
|
||||
] 2 (throw) ;
|
||||
[ (continue-with) ] 2 (throw) ;
|
||||
|
||||
: continue ( continuation -- )
|
||||
f swap continue-with ;
|
||||
|
|
@ -116,15 +113,19 @@ PRIVATE>
|
|||
SYMBOL: thread-error-hook
|
||||
|
||||
: rethrow ( error -- * )
|
||||
dup save-error
|
||||
catchstack* empty? [
|
||||
thread-error-hook get-global
|
||||
[ 1 (throw) ] [ die ] if*
|
||||
] when
|
||||
dup save-error c> continue-with ;
|
||||
c> continue-with ;
|
||||
|
||||
: recover ( try recovery -- )
|
||||
>r [ swap >c call c> drop ] curry r> ifcc ; inline
|
||||
|
||||
: ignore-errors ( quot -- )
|
||||
[ drop ] recover ; inline
|
||||
|
||||
: cleanup ( try cleanup-always cleanup-error -- )
|
||||
over >r compose [ dip rethrow ] curry
|
||||
recover r> call ; inline
|
||||
|
|
@ -171,34 +172,3 @@ M: condition compute-restarts
|
|||
condition-continuation
|
||||
[ <restart> ] curry { } assoc>map
|
||||
append ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: init-error-handler ( -- )
|
||||
V{ } clone set-catchstack
|
||||
! VM calls on error
|
||||
[
|
||||
continuation error-continuation set-global rethrow
|
||||
] 5 setenv
|
||||
! VM adds this to kernel errors, so that user-space
|
||||
! can identify them
|
||||
"kernel-error" 6 setenv ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Debugging support
|
||||
: with-walker-hook ( continuation -- )
|
||||
[ swap set-walker-hook (continue) ] curry callcc1 ;
|
||||
|
||||
SYMBOL: break-hook
|
||||
|
||||
: break ( -- )
|
||||
continuation callstack
|
||||
over set-continuation-call
|
||||
walker-hook [ (continue-with) ] [ break-hook get call ] if* ;
|
||||
|
||||
GENERIC: (step-into) ( obj -- )
|
||||
|
||||
M: wrapper (step-into) wrapped break ;
|
||||
M: object (step-into) break ;
|
||||
M: callable (step-into) \ break add* break ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: cpu.arm.assembler.tests
|
||||
USING: assembler-arm math test namespaces sequences kernel
|
||||
quotations ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types arrays cpu.x86.assembler
|
||||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
|
||||
cpu.architecture kernel kernel.private math namespaces sequences
|
||||
generator.registers generator.fixup generator system
|
||||
generator.registers generator.fixup generator system layouts
|
||||
alien.compiler combinators command-line
|
||||
compiler io vocabs.loader ;
|
||||
compiler compiler.units io vocabs.loader ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
PREDICATE: x86-backend x86-32-backend
|
||||
|
|
@ -281,7 +281,10 @@ T{ x86-backend f 4 } compiler-backend set-global
|
|||
|
||||
"-no-sse2" cli-args member? [
|
||||
"Checking if your CPU supports SSE2..." print flush
|
||||
[ sse2? ] compile-call [
|
||||
[ optimized-recompile-hook ] recompile-hook [
|
||||
[ sse2? ] compile-call
|
||||
] with-variable
|
||||
[
|
||||
" - yes" print
|
||||
"cpu.x86.sse2" require
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
|
|||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
||||
cpu.x86.allot cpu.architecture kernel kernel.private math
|
||||
namespaces sequences generator.registers generator.fixup system
|
||||
alien alien.accessors alien.compiler alien.structs slots
|
||||
layouts alien alien.accessors alien.compiler alien.structs slots
|
||||
splitting assocs ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: cpu.x86.assembler kernel tools.test namespaces ;
|
||||
IN: temporary
|
||||
IN: cpu.x86.assembler.tests
|
||||
|
||||
[ { HEX: 49 HEX: 89 HEX: 04 HEX: 24 } ] [ [ R12 [] RAX MOV ] { } make ] unit-test
|
||||
[ { HEX: 49 HEX: 8b HEX: 06 } ] [ [ RAX R14 [] MOV ] { } make ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generator.fixup io.binary kernel
|
||||
combinators kernel.private math namespaces parser sequences
|
||||
words system ;
|
||||
words system layouts ;
|
||||
IN: cpu.x86.assembler
|
||||
|
||||
! A postfix assembler for x86 and AMD64.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien arrays generic generic.math help.markup help.syntax
|
||||
kernel math memory strings sbufs vectors io io.files classes
|
||||
help generic.standard continuations system ;
|
||||
help generic.standard continuations system debugger.private ;
|
||||
IN: debugger
|
||||
|
||||
ARTICLE: "errors-assert" "Assertions"
|
||||
|
|
@ -80,9 +80,6 @@ HELP: print-error
|
|||
HELP: restarts.
|
||||
{ $description "Print a list of restarts for the most recently thrown error to the " { $link stdio } " stream." } ;
|
||||
|
||||
HELP: debug-help
|
||||
{ $description "Print a synopsis of useful debugger words." } ;
|
||||
|
||||
HELP: error-hook
|
||||
{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
|
||||
{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
|
||||
|
|
@ -169,3 +166,6 @@ HELP: depth
|
|||
HELP: assert-depth
|
||||
{ $values { "quot" "a quotation" } }
|
||||
{ $description "Runs a quotation. Throws an error if the total number of elements on the stack is not the same before and after the quotation runs." } ;
|
||||
|
||||
HELP: init-debugger
|
||||
{ $description "Called on startup to set a pair of hooks which allow the " { $link throw } " word to function." } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: debugger.tests
|
||||
USING: debugger kernel continuations tools.test ;
|
||||
|
||||
[ ] [ [ drop ] [ error. ] recover ] unit-test
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@ math namespaces prettyprint sequences assocs sequences.private
|
|||
strings io.styles vectors words system splitting math.parser
|
||||
tuples continuations continuations.private combinators
|
||||
generic.math io.streams.duplex classes compiler.units
|
||||
generic.standard vocabs ;
|
||||
generic.standard vocabs threads threads.private init
|
||||
kernel.private libc ;
|
||||
IN: debugger
|
||||
|
||||
GENERIC: error. ( error -- )
|
||||
|
|
@ -31,6 +32,9 @@ M: string error. print ;
|
|||
: :get ( variable -- value )
|
||||
error-continuation get continuation-name assoc-stack ;
|
||||
|
||||
: :vars ( -- )
|
||||
error-continuation get continuation-name namestack. ;
|
||||
|
||||
: :res ( n -- )
|
||||
1- restarts get-global nth f restarts set-global restart ;
|
||||
|
||||
|
|
@ -54,19 +58,6 @@ M: string error. print ;
|
|||
dup length [ restart. ] 2each
|
||||
] if ;
|
||||
|
||||
: debug-help ( -- )
|
||||
nl
|
||||
"Debugger commands:" print
|
||||
nl
|
||||
":help - documentation for this error" print
|
||||
":s - data stack at exception time" print
|
||||
":r - retain stack at exception time" print
|
||||
":c - call stack at exception time" print
|
||||
":edit - jump to source location (parse errors only)" print
|
||||
|
||||
":get ( var -- value ) accesses variables at time of the error" print
|
||||
flush ;
|
||||
|
||||
: print-error ( error -- )
|
||||
[ error. flush ] curry
|
||||
[ global [ "Error in print-error!" print drop ] bind ]
|
||||
|
|
@ -74,7 +65,12 @@ M: string error. print ;
|
|||
|
||||
SYMBOL: error-hook
|
||||
|
||||
[ print-error restarts. debug-help ] error-hook set-global
|
||||
[
|
||||
print-error
|
||||
restarts.
|
||||
nl
|
||||
"Type :help for debugging help." print flush
|
||||
] error-hook set-global
|
||||
|
||||
: try ( quot -- )
|
||||
[ error-hook get call ] recover ;
|
||||
|
|
@ -257,3 +253,49 @@ M: no-compilation-unit error.
|
|||
|
||||
M: no-vocab summary
|
||||
drop "Vocabulary does not exist" ;
|
||||
|
||||
M: check-ptr summary
|
||||
drop "Memory allocation failed" ;
|
||||
|
||||
M: double-free summary
|
||||
drop "Free failed since memory is not allocated" ;
|
||||
|
||||
M: realloc-error summary
|
||||
drop "Memory reallocation failed" ;
|
||||
|
||||
: error-in-thread. ( -- )
|
||||
error-thread get-global
|
||||
"Error in thread " write
|
||||
[
|
||||
dup thread-id #
|
||||
" (" % dup thread-name %
|
||||
", " % dup thread-quot unparse-short % ")" %
|
||||
] "" make swap write-object ":" print nl ;
|
||||
|
||||
! Hooks
|
||||
M: thread error-in-thread ( error thread -- )
|
||||
initial-thread get-global eq? [
|
||||
die drop
|
||||
] [
|
||||
global [
|
||||
error-in-thread. print-error flush
|
||||
] bind
|
||||
] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: init-debugger ( -- )
|
||||
V{ } clone set-catchstack
|
||||
! VM calls on error
|
||||
[
|
||||
self error-thread set-global
|
||||
continuation error-continuation set-global
|
||||
rethrow
|
||||
] 5 setenv
|
||||
! VM adds this to kernel errors, so that user-space
|
||||
! can identify them
|
||||
"kernel-error" 6 setenv ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
[ init-debugger ] "debugger" add-init-hook
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: definitions.tests
|
||||
USING: tools.test generic kernel definitions sequences
|
||||
compiler.units ;
|
||||
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ M: object uses drop f ;
|
|||
|
||||
: xref ( defspec -- ) dup uses crossref get add-vertex ;
|
||||
|
||||
: usage ( defspec -- seq ) crossref get at keys ;
|
||||
: usage ( defspec -- seq ) \ f or crossref get at keys ;
|
||||
|
||||
GENERIC: redefined* ( defspec -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: dlists dlists.private kernel tools.test random assocs
|
||||
hashtables sequences namespaces sorting debugger io prettyprint
|
||||
math ;
|
||||
IN: temporary
|
||||
IN: dlists.tests
|
||||
|
||||
[ t ] [ <dlist> dlist-empty? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ HELP: effect>string
|
|||
{ $values { "effect" effect } { "string" string } }
|
||||
{ $description "Turns a stack effect object into a string mnemonic." }
|
||||
{ $examples
|
||||
{ $example "USE: effects" "1 2 <effect> effect>string print" "( object -- object object )" }
|
||||
{ $example "USING: effects io ;" "1 2 <effect> effect>string print" "( object -- object object )" }
|
||||
} ;
|
||||
|
||||
HELP: stack-effect
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: effects.tests
|
||||
USING: effects tools.test ;
|
||||
|
||||
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: float-arrays.tests
|
||||
USING: float-arrays tools.test ;
|
||||
|
||||
[ F{ 1.0 1.0 1.0 } ] [ 3 1.0 <float-array> ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: float-vectors.tests
|
||||
USING: tools.test float-vectors vectors sequences kernel ;
|
||||
|
||||
[ 0 ] [ 123 <float-vector> length ] unit-test
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic assocs hashtables
|
||||
kernel kernel.private math namespaces sequences words
|
||||
quotations strings alien system combinators math.bitfields
|
||||
words.private cpu.architecture ;
|
||||
quotations strings alien layouts system combinators
|
||||
math.bitfields words.private cpu.architecture ;
|
||||
IN: generator.fixup
|
||||
|
||||
: no-stack-frame -1 ; inline
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ HELP: generate
|
|||
{ $description "Generates machine code for " { $snippet "label" } " from " { $snippet "node" } ". The value of " { $snippet "word" } " is retained for debugging purposes; it is the word which will appear in a call stack trace if this compiled code block throws an error when run." } ;
|
||||
|
||||
HELP: word-dataflow
|
||||
{ $values { "word" word } { "effect" effect } { "dependencies" sequence } { "dataflow" "a dataflow graph" } }
|
||||
{ $values { "word" word } { "effect" effect } { "dataflow" "a dataflow graph" } }
|
||||
{ $description "Outputs the dataflow graph of a word, taking specializers into account (see " { $link "specializers" } ")." } ;
|
||||
|
||||
HELP: define-intrinsics
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: help.markup help.syntax generic.math generic.standard
|
||||
words classes definitions kernel alien combinators sequences
|
||||
math quotations ;
|
||||
USING: help.markup help.syntax words classes definitions kernel
|
||||
alien sequences math quotations generic.standard generic.math
|
||||
combinators ;
|
||||
IN: generic
|
||||
|
||||
ARTICLE: "method-order" "Method precedence"
|
||||
|
|
@ -33,8 +33,6 @@ $nl
|
|||
"New generic words can be defined:"
|
||||
{ $subsection define-generic }
|
||||
{ $subsection define-simple-generic }
|
||||
"Methods are tuples:"
|
||||
{ $subsection <method> }
|
||||
"Methods can be added to existing generic words:"
|
||||
{ $subsection define-method }
|
||||
"Method definitions can be looked up:"
|
||||
|
|
@ -42,8 +40,10 @@ $nl
|
|||
{ $subsection methods }
|
||||
"A generic word contains methods; the list of methods specializing on a class can also be obtained:"
|
||||
{ $subsection implementors }
|
||||
"Low-level words which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
|
||||
"Low-level word which rebuilds the generic word after methods are added or removed, or the method combination is changed:"
|
||||
{ $subsection make-generic }
|
||||
"Low-level method constructor:"
|
||||
{ $subsection <method> }
|
||||
"A " { $emphasis "method specifier" } " refers to a method and implements the " { $link "definition-protocol" } ":"
|
||||
{ $subsection method-spec } ;
|
||||
|
||||
|
|
@ -116,16 +116,18 @@ HELP: method-spec
|
|||
{ $class-description "The class of method specifiers, which are two-element arrays consisting of a class word followed by a generic word." }
|
||||
{ $examples { $code "{ fixnum + }" "{ editor draw-gadget* }" } } ;
|
||||
|
||||
HELP: method-body
|
||||
{ $class-description "The class of method bodies, which are words with special word properties set." } ;
|
||||
|
||||
HELP: method
|
||||
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method } " or " { $link f } } }
|
||||
{ $description "Looks up a method definition." }
|
||||
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
|
||||
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
|
||||
{ $description "Looks up a method definition." } ;
|
||||
|
||||
{ method define-method POSTPONE: M: } related-words
|
||||
|
||||
HELP: <method>
|
||||
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
|
||||
{ $description "Creates a new "{ $link method } " instance." } ;
|
||||
{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
|
||||
{ $description "Creates a new method." } ;
|
||||
|
||||
HELP: methods
|
||||
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
|
||||
|
|
@ -146,7 +148,7 @@ HELP: with-methods
|
|||
$low-level-note ;
|
||||
|
||||
HELP: define-method
|
||||
{ $values { "method" quotation } { "class" class } { "generic" generic } }
|
||||
{ $values { "quot" quotation } { "class" class } { "generic" generic } }
|
||||
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
|
||||
|
||||
HELP: implementors
|
||||
|
|
@ -156,3 +158,5 @@ HELP: implementors
|
|||
HELP: forget-methods
|
||||
{ $values { "class" class } }
|
||||
{ $description "Remove all method definitions which specialize on the class." } ;
|
||||
|
||||
{ sort-classes methods order } related-words
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ generic.math assocs hashtables io kernel math namespaces parser
|
|||
prettyprint sequences strings tools.test vectors words
|
||||
quotations classes continuations layouts classes.union sorting
|
||||
compiler.units ;
|
||||
IN: temporary
|
||||
IN: generic.tests
|
||||
|
||||
GENERIC: foobar ( x -- y )
|
||||
M: object foobar drop "Hello world" ;
|
||||
|
|
@ -87,11 +87,11 @@ M: number union-containment drop 2 ;
|
|||
[ 2 ] [ 1.0 union-containment ] unit-test
|
||||
|
||||
! Testing recovery from bad method definitions
|
||||
"IN: temporary GENERIC: unhappy ( x -- x )" eval
|
||||
"IN: generic.tests GENERIC: unhappy ( x -- x )" eval
|
||||
[
|
||||
"IN: temporary M: dictionary unhappy ;" eval
|
||||
"IN: generic.tests M: dictionary unhappy ;" eval
|
||||
] must-fail
|
||||
[ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test
|
||||
[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
|
||||
|
||||
GENERIC# complex-combination 1 ( a b -- c )
|
||||
M: string complex-combination drop ;
|
||||
|
|
@ -192,12 +192,12 @@ SYMBOL: redefinition-test-generic
|
|||
|
||||
TUPLE: redefinition-test-tuple ;
|
||||
|
||||
"IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval
|
||||
"IN: generic.tests M: redefinition-test-tuple redefinition-test-generic ;" eval
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
redefinition-test-generic ,
|
||||
"IN: temporary TUPLE: redefinition-test-tuple ;" eval
|
||||
"IN: generic.tests TUPLE: redefinition-test-tuple ;" eval
|
||||
redefinition-test-generic ,
|
||||
] { } make all-equal?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -25,16 +25,12 @@ GENERIC: make-default-method ( generic combination -- method )
|
|||
|
||||
PREDICATE: word generic "combination" word-prop >boolean ;
|
||||
|
||||
M: generic definer drop f f ;
|
||||
|
||||
M: generic definition drop f ;
|
||||
|
||||
: make-generic ( word -- )
|
||||
dup { "unannotated-def" } reset-props
|
||||
dup dup "combination" word-prop perform-combination define ;
|
||||
|
||||
TUPLE: method word def specializer generic loc ;
|
||||
|
||||
: method ( class generic -- method/f )
|
||||
"methods" word-prop at ;
|
||||
|
||||
|
|
@ -47,7 +43,7 @@ PREDICATE: pair method-spec
|
|||
: methods ( word -- assoc )
|
||||
"methods" word-prop
|
||||
[ keys sort-classes ] keep
|
||||
[ dupd at method-word ] curry { } map>assoc ;
|
||||
[ dupd at ] curry { } map>assoc ;
|
||||
|
||||
TUPLE: check-method class generic ;
|
||||
|
||||
|
|
@ -63,29 +59,33 @@ TUPLE: check-method class generic ;
|
|||
: method-word-name ( class word -- string )
|
||||
word-name "/" rot word-name 3append ;
|
||||
|
||||
: make-method-def ( quot word combination -- quot )
|
||||
: make-method-def ( quot class generic -- quot )
|
||||
"combination" word-prop method-prologue swap append ;
|
||||
|
||||
PREDICATE: word method-body "method" word-prop >boolean ;
|
||||
PREDICATE: word method-body "method-def" word-prop >boolean ;
|
||||
|
||||
M: method-body stack-effect
|
||||
"method" word-prop method-generic stack-effect ;
|
||||
"method-generic" word-prop stack-effect ;
|
||||
|
||||
: <method-word> ( quot class generic -- word )
|
||||
[ make-method-def ] 2keep
|
||||
method-word-name f <word>
|
||||
dup rot define
|
||||
dup xref ;
|
||||
: method-word-props ( quot class generic -- assoc )
|
||||
[
|
||||
"method-generic" set
|
||||
"method-class" set
|
||||
"method-def" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: <method> ( quot class generic -- method )
|
||||
check-method
|
||||
[ <method-word> ] 3keep f \ method construct-boa
|
||||
dup method-word over "method" set-word-prop ;
|
||||
[ make-method-def ] 3keep
|
||||
[ method-word-props ] 2keep
|
||||
method-word-name f <word>
|
||||
tuck set-word-props
|
||||
dup rot define ;
|
||||
|
||||
: redefine-method ( quot class generic -- )
|
||||
[ method set-method-def ] 3keep
|
||||
[ method swap "method-def" set-word-prop ] 3keep
|
||||
[ make-method-def ] 2keep
|
||||
method method-word swap define ;
|
||||
method swap define ;
|
||||
|
||||
: define-method ( quot class generic -- )
|
||||
>r bootstrap-word r>
|
||||
|
|
@ -102,21 +102,36 @@ M: method-body stack-effect
|
|||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
dup first2 method [ method-loc ] [ second where ] ?if ;
|
||||
dup first2 method [ ] [ second ] ?if where ;
|
||||
|
||||
M: method-spec set-where first2 method set-method-loc ;
|
||||
M: method-spec set-where
|
||||
first2 method set-where ;
|
||||
|
||||
M: method-spec definer drop \ M: \ ; ;
|
||||
M: method-spec definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-spec definition
|
||||
first2 method dup [ method-def ] when ;
|
||||
first2 method dup
|
||||
[ "method-def" word-prop ] when ;
|
||||
|
||||
: forget-method ( class generic -- )
|
||||
check-method
|
||||
[ delete-at* ] with-methods
|
||||
[ method-word forget ] [ drop ] if ;
|
||||
[ forget-word ] [ drop ] if ;
|
||||
|
||||
M: method-spec forget* first2 forget-method ;
|
||||
M: method-spec forget*
|
||||
first2 forget-method ;
|
||||
|
||||
M: method-body definer
|
||||
drop \ M: \ ; ;
|
||||
|
||||
M: method-body definition
|
||||
"method-def" word-prop ;
|
||||
|
||||
M: method-body forget*
|
||||
dup "method-class" word-prop
|
||||
swap "method-generic" word-prop
|
||||
forget-method ;
|
||||
|
||||
: implementors* ( classes -- words )
|
||||
all-words [
|
||||
|
|
@ -154,8 +169,7 @@ M: word subwords drop f ;
|
|||
|
||||
M: generic subwords
|
||||
dup "methods" word-prop values
|
||||
swap "default-method" word-prop add
|
||||
[ method-word ] map ;
|
||||
swap "default-method" word-prop add ;
|
||||
|
||||
M: generic forget-word
|
||||
dup subwords [ forget-word ] each (forget-word) ;
|
||||
|
|
|
|||
|
|
@ -1,26 +1,27 @@
|
|||
USING: kernel generic help.markup help.syntax math classes
|
||||
generic.math ;
|
||||
sequences quotations ;
|
||||
IN: generic.math
|
||||
|
||||
HELP: math-upgrade
|
||||
{ $values { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
|
||||
{ $values { "class1" class } { "class2" class } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
|
||||
{ $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." }
|
||||
{ $examples { $example "USE: generic.math" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ;
|
||||
{ $examples { $example "USING: generic.math math kernel prettyprint ;" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ;
|
||||
|
||||
HELP: no-math-method
|
||||
{ $values { "left" "an object" } { "right" "an object" } { "generic" "a generic word" } }
|
||||
{ $values { "left" "an object" } { "right" "an object" } { "generic" generic } }
|
||||
{ $description "Throws a " { $link no-math-method } " error." }
|
||||
{ $error-description "Thrown by generic words using the " { $link math-combination } " method combination if there is no suitable method defined for the two inputs." } ;
|
||||
|
||||
HELP: math-method
|
||||
{ $values { "word" "a generic word" } { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation" } }
|
||||
{ $values { "word" generic } { "class1" class } { "class2" class } { "quot" quotation } }
|
||||
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
|
||||
{ $examples { $example "USE: generic.math" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
|
||||
{ $examples { $example "USING: generic.math math prettyprint ;" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
|
||||
|
||||
HELP: math-class
|
||||
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;
|
||||
|
||||
HELP: math-combination
|
||||
{ $values { "word" "a generic word" } { "quot" "a quotation" } }
|
||||
{ $values { "word" generic } { "quot" quotation } }
|
||||
{ $description "Generates a double-dispatching word definition. Only methods defined on numerical classes and " { $link object } " take effect in the math combination. Methods defined on numerical classes are guaranteed to have their two inputs upgraded to the highest priority type of the two."
|
||||
$nl
|
||||
"The math method combination is used for binary operators such as " { $link + } " and " { $link * } "."
|
||||
|
|
@ -40,5 +41,5 @@ HELP: math-generic
|
|||
{ $class-description "The class of generic words using " { $link math-combination } "." } ;
|
||||
|
||||
HELP: last/first
|
||||
{ $values { "seq" "a sequence" } { "pair" "a two-element array" } }
|
||||
{ $values { "seq" sequence } { "pair" "a two-element array" } }
|
||||
{ $description "Creates an array holding the first and last element of the sequence." } ;
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
|
|||
|
||||
: applicable-method ( generic class -- quot )
|
||||
over method
|
||||
[ method-word word-def ]
|
||||
[ word-def ]
|
||||
[ default-math-method ] ?if ;
|
||||
|
||||
: object-method ( generic -- quot )
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: generic help.markup help.syntax sequences
|
||||
generic.standard ;
|
||||
USING: generic help.markup help.syntax sequences ;
|
||||
IN: generic.standard
|
||||
|
||||
HELP: no-method
|
||||
{ $values { "object" "an object" } { "generic" "a generic word" } }
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@ TUPLE: no-method object generic ;
|
|||
] if ;
|
||||
|
||||
: default-method ( word -- pair )
|
||||
"default-method" word-prop method-word
|
||||
"default-method" word-prop
|
||||
object bootstrap-word swap 2array ;
|
||||
|
||||
: method-alist>quot ( alist base-class -- quot )
|
||||
|
|
|
|||
|
|
@ -18,19 +18,19 @@ $nl
|
|||
ABOUT: "growable"
|
||||
|
||||
HELP: set-fill
|
||||
{ $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } }
|
||||
{ $values { "n" "a new fill pointer" } { "seq" growable } }
|
||||
{ $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." }
|
||||
{ $side-effects "seq" }
|
||||
{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
|
||||
{ $warning "This word is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ;
|
||||
|
||||
HELP: underlying
|
||||
{ $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } }
|
||||
{ $values { "seq" growable } { "underlying" "the underlying sequence" } }
|
||||
{ $contract "Outputs the underlying storage of a resizable sequence." } ;
|
||||
|
||||
HELP: set-underlying
|
||||
{ $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } }
|
||||
{ $values { "underlying" sequence } { "seq" growable } }
|
||||
{ $contract "Modifies the underlying storage of a resizable sequence." }
|
||||
{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
|
||||
{ $warning "This word is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ;
|
||||
|
||||
HELP: capacity
|
||||
{ $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } }
|
||||
|
|
@ -41,7 +41,7 @@ HELP: new-size
|
|||
{ $description "Computes the new size of a resizable sequence." } ;
|
||||
|
||||
HELP: ensure
|
||||
{ $values { "n" "a positive integer" } { "seq" "a resizable sequence" } }
|
||||
{ $values { "n" "a positive integer" } { "seq" growable } }
|
||||
{ $description "If " { $snippet "n" } " is less than the length of the sequence, does nothing. Otherwise, if " { $snippet "n" } " also exceeds the capacity of the underlying storage, the underlying storage is grown, and the fill pointer is reset. Finally, if " { $snippet "n" } " is greater than or equal to the length but less than the capacity of the underlying storage, the fill pointer is moved and nothing else is done."
|
||||
$nl
|
||||
"This word is used in the implementation of the " { $link set-nth } " generic for sequences supporting the resizable sequence protocol (see " { $link "growable" } ")."
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: math sequences classes growable tools.test kernel
|
||||
layouts ;
|
||||
IN: temporary
|
||||
IN: growable.tests
|
||||
|
||||
! erg found this one
|
||||
[ fixnum ] [
|
||||
|
|
|
|||
|
|
@ -128,14 +128,14 @@ HELP: prune
|
|||
{ $values { "seq" "a sequence" } { "newseq" "a sequence" } }
|
||||
{ $description "Outputs a new sequence with each distinct element of " { $snippet "seq" } " appearing only once. Elements are compared for equality using " { $link = } " and elements are ordered according to their position in " { $snippet "seq" } "." }
|
||||
{ $examples
|
||||
{ $example "USE: hashtables" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
|
||||
{ $example "USING: hashtables prettyprint ;" "{ 1 1 t 3 t } prune ." "V{ 1 t 3 }" }
|
||||
} ;
|
||||
|
||||
HELP: all-unique?
|
||||
{ $values { "seq" sequence } { "?" "a boolean" } }
|
||||
{ $description "Tests whether a sequence contains any repeated elements." }
|
||||
{ $example
|
||||
"USE: combinators.lib"
|
||||
"USING: hashtables prettyprint ;"
|
||||
"{ 0 1 1 2 3 5 } all-unique? ."
|
||||
"f"
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: hashtables.tests
|
||||
USING: kernel math namespaces tools.test vectors sequences
|
||||
sequences.private hashtables io prettyprint assocs
|
||||
continuations ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel kernel.private slots.private math assocs
|
||||
math.private sequences sequences.private vectors ;
|
||||
math.private sequences sequences.private vectors ;
|
||||
IN: hashtables
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -16,16 +16,16 @@ IN: hashtables
|
|||
2 fixnum+fast over wrap ; inline
|
||||
|
||||
: (key@) ( key keys i -- array n ? )
|
||||
#! cond form expanded by hand for better interpreter speed
|
||||
3dup swap array-nth dup ((tombstone)) eq? [
|
||||
2drop probe (key@)
|
||||
] [
|
||||
dup ((empty)) eq? [
|
||||
3drop nip f f
|
||||
] [
|
||||
= [ rot drop t ] [ probe (key@) ] if
|
||||
] if
|
||||
] if ; inline
|
||||
3dup swap array-nth
|
||||
dup ((empty)) eq?
|
||||
[ 3drop nip f f ]
|
||||
[
|
||||
=
|
||||
[ rot drop t ]
|
||||
[ probe (key@) ]
|
||||
if
|
||||
]
|
||||
if ; inline
|
||||
|
||||
: key@ ( key hash -- array n ? )
|
||||
hash-array 2dup hash@ (key@) ; inline
|
||||
|
|
@ -40,7 +40,6 @@ IN: hashtables
|
|||
swap <hash-array> over set-hash-array init-hash ;
|
||||
|
||||
: (new-key@) ( key keys i -- keys n empty? )
|
||||
#! cond form expanded by hand for better interpreter speed
|
||||
3dup swap array-nth dup ((empty)) eq? [
|
||||
2drop rot drop t
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -11,69 +11,73 @@ $nl
|
|||
{ $subsection min-heap? }
|
||||
{ $subsection <min-heap> }
|
||||
"Max-heaps sort their elements so that the maximum element is first:"
|
||||
{ $subsection min-heap }
|
||||
{ $subsection min-heap? }
|
||||
{ $subsection <min-heap> }
|
||||
{ $subsection max-heap }
|
||||
{ $subsection max-heap? }
|
||||
{ $subsection <max-heap> }
|
||||
"Both obey a protocol."
|
||||
$nl
|
||||
"Queries:"
|
||||
{ $subsection heap-empty? }
|
||||
{ $subsection heap-length }
|
||||
{ $subsection heap-size }
|
||||
{ $subsection heap-peek }
|
||||
"Insertion:"
|
||||
{ $subsection heap-push }
|
||||
{ $subsection heap-push* }
|
||||
{ $subsection heap-push-all }
|
||||
"Removal:"
|
||||
{ $subsection heap-pop* }
|
||||
{ $subsection heap-pop } ;
|
||||
{ $subsection heap-pop }
|
||||
{ $subsection heap-delete } ;
|
||||
|
||||
ABOUT: "heaps"
|
||||
|
||||
HELP: <min-heap>
|
||||
{ $values { "min-heap" min-heap } }
|
||||
{ $description "Create a new " { $link min-heap } "." }
|
||||
{ $see-also <max-heap> } ;
|
||||
{ $description "Create a new " { $link min-heap } "." } ;
|
||||
|
||||
HELP: <max-heap>
|
||||
{ $values { "max-heap" max-heap } }
|
||||
{ $description "Create a new " { $link max-heap } "." }
|
||||
{ $see-also <min-heap> } ;
|
||||
{ $description "Create a new " { $link max-heap } "." } ;
|
||||
|
||||
HELP: heap-push
|
||||
{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } }
|
||||
{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
|
||||
{ $side-effects "heap" }
|
||||
{ $see-also heap-push-all heap-pop } ;
|
||||
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } }
|
||||
{ $description "Push a pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-push*
|
||||
{ $values { "key" "a comparable object" } { "value" object } { "heap" "a heap" } { "entry" entry } }
|
||||
{ $description "Push a pair onto a heap, and output an entry which may later be passed to " { $link heap-delete } "." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-push-all
|
||||
{ $values { "assoc" assoc } { "heap" heap } }
|
||||
{ $values { "assoc" assoc } { "heap" "a heap" } }
|
||||
{ $description "Push every key/value pair of an assoc onto a heap." }
|
||||
{ $side-effects "heap" }
|
||||
{ $see-also heap-push heap-pop } ;
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-peek
|
||||
{ $values { "heap" heap } { "key" object } { "value" object } }
|
||||
{ $description "Outputs the first element in the heap, leaving it in the heap." }
|
||||
{ $see-also heap-pop heap-pop* } ;
|
||||
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
|
||||
{ $description "Output the first element in the heap, leaving it in the heap." } ;
|
||||
|
||||
HELP: heap-pop*
|
||||
{ $values { "heap" heap } }
|
||||
{ $description "Removes the first element from the heap." }
|
||||
{ $side-effects "heap" }
|
||||
{ $see-also heap-pop heap-push heap-peek } ;
|
||||
{ $values { "heap" "a heap" } }
|
||||
{ $description "Remove the first element from the heap." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-pop
|
||||
{ $values { "heap" heap } { "key" object } { "value" object } }
|
||||
{ $description "Outputs the first element in the heap and removes it from the heap." }
|
||||
{ $side-effects "heap" }
|
||||
{ $see-also heap-pop* heap-push heap-peek } ;
|
||||
{ $values { "heap" "a heap" } { "key" object } { "value" object } }
|
||||
{ $description "Output and remove the first element in the heap." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
||||
HELP: heap-empty?
|
||||
{ $values { "heap" heap } { "?" "a boolean" } }
|
||||
{ $description "Tests if a " { $link heap } " has no nodes." }
|
||||
{ $see-also heap-length heap-peek } ;
|
||||
{ $values { "heap" "a heap" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a heap has no nodes." } ;
|
||||
|
||||
HELP: heap-length
|
||||
{ $values { "heap" heap } { "n" integer } }
|
||||
{ $description "Returns the number of key/value pairs in the heap." }
|
||||
{ $see-also heap-empty? } ;
|
||||
HELP: heap-size
|
||||
{ $values { "heap" "a heap" } { "n" integer } }
|
||||
{ $description "Returns the number of key/value pairs in the heap." } ;
|
||||
|
||||
HELP: heap-delete
|
||||
{ $values { "entry" entry } { "heap" "a heap" } }
|
||||
{ $description "Remove the specified entry from the heap." }
|
||||
{ $errors "Throws an error if the entry is from another heap or if it has already been deleted." }
|
||||
{ $side-effects "heap" } ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright 2007 Ryan Murphy
|
||||
! Copyright 2007, 2008 Ryan Murphy, Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: arrays kernel math namespaces tools.test
|
||||
heaps heaps.private ;
|
||||
IN: temporary
|
||||
heaps heaps.private math.parser random assocs sequences sorting ;
|
||||
IN: heaps.tests
|
||||
|
||||
[ <min-heap> heap-pop ] must-fail
|
||||
[ <max-heap> heap-pop ] must-fail
|
||||
|
|
@ -15,16 +15,8 @@ IN: temporary
|
|||
|
||||
! Binary Min Heap
|
||||
{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test
|
||||
{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test
|
||||
{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ]
|
||||
[ <min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test
|
||||
|
||||
[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [
|
||||
<min-heap> { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all
|
||||
3 [ dup heap-pop* ] times
|
||||
] unit-test
|
||||
{ t } [ t 5 f <entry> t 3 f <entry> T{ min-heap } heap-compare ] unit-test
|
||||
{ f } [ t 5 f <entry> t 3 f <entry> T{ max-heap } heap-compare ] unit-test
|
||||
|
||||
[ t 2 ] [ <min-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test
|
||||
|
||||
|
|
@ -32,18 +24,51 @@ IN: temporary
|
|||
|
||||
[ t 400 ] [ <max-heap> t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test
|
||||
|
||||
[ 0 ] [ <max-heap> heap-length ] unit-test
|
||||
[ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test
|
||||
[ 0 ] [ <max-heap> heap-size ] unit-test
|
||||
[ 1 ] [ <max-heap> t 1 pick heap-push heap-size ] unit-test
|
||||
|
||||
[ { { 1 2 } { 3 4 } { 5 6 } } ] [
|
||||
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
|
||||
[ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make
|
||||
] unit-test
|
||||
[ { { 1 2 } } ] [
|
||||
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
|
||||
[ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make
|
||||
] unit-test
|
||||
[ { } ] [
|
||||
T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
|
||||
[ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make
|
||||
] unit-test
|
||||
: heap-sort ( alist -- keys )
|
||||
<min-heap> [ heap-push-all ] keep heap-pop-all ;
|
||||
|
||||
: random-alist ( n -- alist )
|
||||
[
|
||||
[
|
||||
(random) dup number>string swap set
|
||||
] times
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: test-heap-sort ( n -- ? )
|
||||
random-alist dup >alist sort-keys swap heap-sort = ;
|
||||
|
||||
14 [
|
||||
[ t ] swap [ 2^ test-heap-sort ] curry unit-test
|
||||
] each
|
||||
|
||||
: test-entry-indices ( n -- ? )
|
||||
random-alist
|
||||
<min-heap> [ heap-push-all ] keep
|
||||
heap-data dup length swap [ entry-index ] map sequence= ;
|
||||
|
||||
14 [
|
||||
[ t ] swap [ 2^ test-entry-indices ] curry unit-test
|
||||
] each
|
||||
|
||||
: delete-random ( seq -- elt )
|
||||
dup length random dup pick nth >r swap delete-nth r> ;
|
||||
|
||||
: sort-entries ( entries -- entries' )
|
||||
[ [ entry-key ] compare ] sort ;
|
||||
|
||||
: delete-test ( n -- ? )
|
||||
[
|
||||
random-alist
|
||||
<min-heap> [ heap-push-all ] keep
|
||||
dup heap-data clone swap
|
||||
] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
|
||||
heap-data
|
||||
[ [ entry-key ] map ] 2apply
|
||||
[ natural-sort ] 2apply ;
|
||||
|
||||
11 [
|
||||
[ t ] swap [ 2^ delete-test sequence= ] curry unit-test
|
||||
] each
|
||||
|
|
|
|||
|
|
@ -1,26 +1,31 @@
|
|||
! Copyright (C) 2007 Ryan Murphy, Doug Coleman.
|
||||
! Copyright (C) 2007, 2008 Ryan Murphy, Doug Coleman,
|
||||
! Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math sequences arrays assocs ;
|
||||
USING: kernel math sequences arrays assocs sequences.private
|
||||
growable ;
|
||||
IN: heaps
|
||||
|
||||
MIXIN: priority-queue
|
||||
|
||||
GENERIC: heap-push ( value key heap -- )
|
||||
GENERIC: heap-push* ( value key heap -- entry )
|
||||
GENERIC: heap-peek ( heap -- value key )
|
||||
GENERIC: heap-pop* ( heap -- )
|
||||
GENERIC: heap-pop ( heap -- value key )
|
||||
GENERIC: heap-delete ( key heap -- )
|
||||
GENERIC: heap-delete* ( key heap -- old ? )
|
||||
GENERIC: heap-delete ( entry heap -- )
|
||||
GENERIC: heap-empty? ( heap -- ? )
|
||||
GENERIC: heap-length ( heap -- n )
|
||||
GENERIC# heap-pop-while 2 ( heap pred quot -- )
|
||||
GENERIC: heap-size ( heap -- n )
|
||||
|
||||
<PRIVATE
|
||||
TUPLE: heap data ;
|
||||
|
||||
: heap-data delegate ; inline
|
||||
|
||||
: <heap> ( class -- heap )
|
||||
>r V{ } clone heap construct-boa r>
|
||||
construct-delegate ; inline
|
||||
>r V{ } clone r> construct-delegate ; inline
|
||||
|
||||
TUPLE: entry value key heap index ;
|
||||
|
||||
: <entry> ( value key heap -- entry ) f entry construct-boa ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
TUPLE: min-heap ;
|
||||
|
|
@ -34,23 +39,67 @@ TUPLE: max-heap ;
|
|||
INSTANCE: min-heap priority-queue
|
||||
INSTANCE: max-heap priority-queue
|
||||
|
||||
M: priority-queue heap-empty? ( heap -- ? )
|
||||
heap-data empty? ;
|
||||
|
||||
M: priority-queue heap-size ( heap -- n )
|
||||
heap-data length ;
|
||||
|
||||
<PRIVATE
|
||||
: left ( n -- m ) 2 * 1+ ; inline
|
||||
: right ( n -- m ) 2 * 2 + ; inline
|
||||
: up ( n -- m ) 1- 2 /i ; inline
|
||||
: left-value ( n heap -- obj ) >r left r> nth ; inline
|
||||
: right-value ( n heap -- obj ) >r right r> nth ; inline
|
||||
: up-value ( n vec -- obj ) >r up r> nth ; inline
|
||||
: swap-up ( n vec -- ) >r dup up r> exchange ; inline
|
||||
: last-index ( vec -- n ) length 1- ; inline
|
||||
|
||||
: left ( n -- m ) 1 shift 1 + ; inline
|
||||
|
||||
: right ( n -- m ) 1 shift 2 + ; inline
|
||||
|
||||
: up ( n -- m ) 1- 2/ ; inline
|
||||
|
||||
: data-nth ( n heap -- entry )
|
||||
heap-data nth-unsafe ; inline
|
||||
|
||||
: up-value ( n heap -- entry )
|
||||
>r up r> data-nth ; inline
|
||||
|
||||
: left-value ( n heap -- entry )
|
||||
>r left r> data-nth ; inline
|
||||
|
||||
: right-value ( n heap -- entry )
|
||||
>r right r> data-nth ; inline
|
||||
|
||||
: data-set-nth ( entry n heap -- )
|
||||
>r [ swap set-entry-index ] 2keep r>
|
||||
heap-data set-nth-unsafe ;
|
||||
|
||||
: data-push ( entry heap -- n )
|
||||
dup heap-size [
|
||||
swap 2dup heap-data ensure 2drop data-set-nth
|
||||
] keep ; inline
|
||||
|
||||
: data-pop ( heap -- entry )
|
||||
heap-data pop ; inline
|
||||
|
||||
: data-pop* ( heap -- )
|
||||
heap-data pop* ; inline
|
||||
|
||||
: data-peek ( heap -- entry )
|
||||
heap-data peek ; inline
|
||||
|
||||
: data-first ( heap -- entry )
|
||||
heap-data first ; inline
|
||||
|
||||
: data-exchange ( m n heap -- )
|
||||
[ tuck data-nth >r data-nth r> ] 3keep
|
||||
tuck >r >r data-set-nth r> r> data-set-nth ; inline
|
||||
|
||||
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
|
||||
: (heap-compare) drop [ first ] compare 0 ; inline
|
||||
|
||||
: (heap-compare) drop [ entry-key ] compare 0 ; inline
|
||||
|
||||
M: min-heap heap-compare (heap-compare) > ;
|
||||
|
||||
M: max-heap heap-compare (heap-compare) < ;
|
||||
|
||||
: heap-bounds-check? ( m heap -- ? )
|
||||
heap-data length >= ; inline
|
||||
heap-size >= ; inline
|
||||
|
||||
: left-bounds-check? ( m heap -- ? )
|
||||
>r left r> heap-bounds-check? ; inline
|
||||
|
|
@ -58,41 +107,44 @@ M: max-heap heap-compare (heap-compare) < ;
|
|||
: right-bounds-check? ( m heap -- ? )
|
||||
>r right r> heap-bounds-check? ; inline
|
||||
|
||||
: up-heap-continue? ( vec heap -- ? )
|
||||
>r [ last-index ] keep [ up-value ] keep peek r>
|
||||
: continue? ( m up[m] heap -- ? )
|
||||
[ data-nth swap ] keep [ data-nth ] keep
|
||||
heap-compare ; inline
|
||||
|
||||
: up-heap ( vec heap -- )
|
||||
2dup up-heap-continue? [
|
||||
>r dup last-index [ over swap-up ] keep
|
||||
up 1+ head-slice r> up-heap
|
||||
DEFER: up-heap
|
||||
|
||||
: (up-heap) ( n heap -- )
|
||||
>r dup up r>
|
||||
3dup continue? [
|
||||
[ data-exchange ] 2keep up-heap
|
||||
] [
|
||||
2drop
|
||||
3drop
|
||||
] if ;
|
||||
|
||||
: up-heap ( n heap -- )
|
||||
over 0 > [ (up-heap) ] [ 2drop ] if ;
|
||||
|
||||
: (child) ( m heap -- n )
|
||||
dupd
|
||||
[ heap-data left-value ] 2keep
|
||||
[ heap-data right-value ] keep heap-compare
|
||||
2dup right-value
|
||||
>r 2dup left-value r>
|
||||
rot heap-compare
|
||||
[ right ] [ left ] if ;
|
||||
|
||||
: child ( m heap -- n )
|
||||
2dup right-bounds-check? [ drop left ] [ (child) ] if ;
|
||||
2dup right-bounds-check?
|
||||
[ drop left ] [ (child) ] if ;
|
||||
|
||||
: swap-down ( m heap -- )
|
||||
[ child ] 2keep heap-data exchange ;
|
||||
[ child ] 2keep data-exchange ;
|
||||
|
||||
DEFER: down-heap
|
||||
|
||||
: down-heap-continue? ( heap m heap -- m heap ? )
|
||||
[ heap-data nth ] 2keep child pick
|
||||
dupd [ heap-data nth swapd ] keep heap-compare ;
|
||||
|
||||
: (down-heap) ( m heap -- )
|
||||
2dup down-heap-continue? [
|
||||
-rot [ swap-down ] keep down-heap
|
||||
] [
|
||||
[ child ] 2keep swapd
|
||||
3dup continue? [
|
||||
3drop
|
||||
] [
|
||||
[ data-exchange ] 2keep down-heap
|
||||
] if ;
|
||||
|
||||
: down-heap ( m heap -- )
|
||||
|
|
@ -100,40 +152,43 @@ DEFER: down-heap
|
|||
|
||||
PRIVATE>
|
||||
|
||||
M: priority-queue heap-push ( value key heap -- )
|
||||
>r swap 2array r>
|
||||
[ heap-data push ] keep
|
||||
[ heap-data ] keep
|
||||
up-heap ;
|
||||
M: priority-queue heap-push* ( value key heap -- entry )
|
||||
[ <entry> dup ] keep [ data-push ] keep up-heap ;
|
||||
|
||||
: heap-push ( value key heap -- ) heap-push* drop ;
|
||||
|
||||
: heap-push-all ( assoc heap -- )
|
||||
[ swapd heap-push ] curry assoc-each ;
|
||||
|
||||
: >entry< ( entry -- key value )
|
||||
{ entry-value entry-key } get-slots ;
|
||||
|
||||
M: priority-queue heap-peek ( heap -- value key )
|
||||
heap-data first first2 swap ;
|
||||
data-first >entry< ;
|
||||
|
||||
: entry>index ( entry heap -- n )
|
||||
over entry-heap eq? [
|
||||
"Invalid entry passed to heap-delete" throw
|
||||
] unless
|
||||
entry-index ;
|
||||
|
||||
M: priority-queue heap-delete ( entry heap -- )
|
||||
[ entry>index ] keep
|
||||
2dup heap-size 1- = [
|
||||
nip data-pop*
|
||||
] [
|
||||
[ nip data-pop ] 2keep
|
||||
[ data-set-nth ] 2keep
|
||||
down-heap
|
||||
] if ;
|
||||
|
||||
M: priority-queue heap-pop* ( heap -- )
|
||||
dup heap-data length 1 > [
|
||||
[ heap-data pop ] keep
|
||||
[ heap-data set-first ] keep
|
||||
0 swap down-heap
|
||||
] [
|
||||
heap-data pop*
|
||||
] if ;
|
||||
dup data-first swap heap-delete ;
|
||||
|
||||
M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
|
||||
M: priority-queue heap-pop ( heap -- value key )
|
||||
dup data-first [ swap heap-delete ] keep >entry< ;
|
||||
|
||||
M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ;
|
||||
|
||||
M: priority-queue heap-length ( heap -- n ) heap-data length ;
|
||||
|
||||
: (heap-pop-while) ( heap pred quot -- )
|
||||
pick heap-empty? [
|
||||
3drop
|
||||
] [
|
||||
[ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep
|
||||
roll [ (heap-pop-while) ] [ 3drop ] if
|
||||
] if ;
|
||||
|
||||
M: priority-queue heap-pop-while ( heap pred quot -- )
|
||||
[ heap-pop ] swap [ t ] 3compose (heap-pop-while) ;
|
||||
: heap-pop-all ( heap -- alist )
|
||||
[ dup heap-empty? not ]
|
||||
[ dup heap-pop swap 2array ]
|
||||
[ ] unfold nip ;
|
||||
|
|
|
|||
|
|
@ -10,8 +10,7 @@ IN: inference.backend
|
|||
recursive-state get at ;
|
||||
|
||||
: inline? ( word -- ? )
|
||||
dup "method" word-prop
|
||||
[ method-generic inline? ] [ "inline" word-prop ] ?if ;
|
||||
dup "method-generic" word-prop swap or "inline" word-prop ;
|
||||
|
||||
: local-recursive-state ( -- assoc )
|
||||
recursive-state get dup keys
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
IN: temporary
|
||||
IN: inference.class.tests
|
||||
USING: arrays math.private kernel math compiler inference
|
||||
inference.dataflow optimizer tools.test kernel.private generic
|
||||
sequences words inference.class quotations alien
|
||||
alien.c-types strings sbufs sequences.private
|
||||
slots.private combinators definitions compiler.units
|
||||
system ;
|
||||
system layouts ;
|
||||
|
||||
! Make sure these compile even though this is invalid code
|
||||
[ ] [ [ 10 mod 3.0 /i ] dataflow optimize drop ] unit-test
|
||||
|
|
@ -288,3 +288,10 @@ cell-bits 32 = [
|
|||
[ HEX: ff bitand 0 HEX: ff between? ]
|
||||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ HEX: ff swap HEX: ff bitand >= ]
|
||||
\ >= inlined?
|
||||
] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -5,8 +5,8 @@ sequences strings vectors words quotations effects tools.test
|
|||
continuations generic.standard sorting assocs definitions
|
||||
prettyprint io inspector tuples classes.union classes.predicate
|
||||
debugger threads.private io.streams.string io.timeouts
|
||||
sequences.private ;
|
||||
IN: temporary
|
||||
io.thread sequences.private ;
|
||||
IN: inference.tests
|
||||
|
||||
{ 0 2 } [ 2 "Hello" ] must-infer-as
|
||||
{ 1 2 } [ dup ] must-infer-as
|
||||
|
|
@ -440,7 +440,7 @@ DEFER: bar
|
|||
\ error. must-infer
|
||||
|
||||
! Test odds and ends
|
||||
\ idle-thread must-infer
|
||||
\ io-thread must-infer
|
||||
|
||||
! Incorrect stack declarations on inline recursive words should
|
||||
! be caught
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ namespaces.private parser prettyprint quotations
|
|||
quotations.private sbufs sbufs.private sequences
|
||||
sequences.private slots.private strings strings.private system
|
||||
threads.private tuples tuples.private vectors vectors.private
|
||||
words words.private assocs inspector compiler.units ;
|
||||
words words.private assocs inspector compiler.units
|
||||
system.private ;
|
||||
IN: inference.known-words
|
||||
|
||||
! Shuffle words
|
||||
|
|
@ -538,6 +539,8 @@ set-primitive-effect
|
|||
|
||||
\ fwrite { string alien } { } <effect> set-primitive-effect
|
||||
|
||||
\ fputc { object alien } { } <effect> set-primitive-effect
|
||||
|
||||
\ fread { integer string } { object } <effect> set-primitive-effect
|
||||
|
||||
\ fflush { alien } { } <effect> set-primitive-effect
|
||||
|
|
@ -595,6 +598,8 @@ set-primitive-effect
|
|||
|
||||
\ (os-envs) { } { array } <effect> set-primitive-effect
|
||||
|
||||
\ (set-os-envs) { array } { } <effect> set-primitive-effect
|
||||
|
||||
\ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
|
||||
|
||||
\ dll-valid? { object } { object } <effect> set-primitive-effect
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
IN: temporary
|
||||
USING: tools.test inference.state ;
|
||||
IN: inference.state.tests
|
||||
USING: tools.test inference.state words ;
|
||||
|
||||
SYMBOL: a
|
||||
SYMBOL: b
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces sequences kernel ;
|
||||
USING: assocs namespaces sequences kernel words ;
|
||||
IN: inference.state
|
||||
|
||||
! Nesting state to solve recursion
|
||||
|
|
@ -31,9 +31,6 @@ SYMBOL: current-node
|
|||
! Words that the current dataflow IR depends on
|
||||
SYMBOL: dependencies
|
||||
|
||||
SYMBOL: +inlined+
|
||||
SYMBOL: +called+
|
||||
|
||||
: depends-on ( word how -- )
|
||||
swap dependencies get dup [
|
||||
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: inference.transforms.tests
|
||||
USING: sequences inference.transforms tools.test math kernel
|
||||
quotations inference ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
IN: init.tests
|
||||
USING: init namespaces sequences math tools.test kernel ;
|
||||
|
||||
[ t ] [
|
||||
init-hooks get [ first "libc" = ] find drop
|
||||
init-hooks get [ first "io.backend" = ] find drop <
|
||||
] unit-test
|
||||
|
|
@ -15,7 +15,7 @@ init-hooks global [ drop V{ } clone ] cache drop
|
|||
dup init-hooks get at [ over call ] unless
|
||||
init-hooks get set-at ;
|
||||
|
||||
: boot ( -- ) init-namespaces init-error-handler ;
|
||||
: boot ( -- ) init-namespaces init-catchstack ;
|
||||
|
||||
: boot-quot ( -- quot ) 20 getenv ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: kernel tools.test math namespaces prettyprint
|
||||
sequences inspector io.streams.string ;
|
||||
IN: temporary
|
||||
IN: inspector.tests
|
||||
|
||||
[ 1 2 3 ] describe
|
||||
f describe
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays generic hashtables io kernel assocs math
|
||||
namespaces prettyprint sequences strings io.styles vectors words
|
||||
|
|
@ -93,6 +93,15 @@ SYMBOL: +editable+
|
|||
|
||||
: describe ( obj -- ) H{ } describe* ;
|
||||
|
||||
: namestack. ( seq -- )
|
||||
[
|
||||
[ global eq? not ] subset
|
||||
[ keys ] map concat prune
|
||||
] keep [ dupd assoc-stack ] curry H{ } map>assoc describe ;
|
||||
|
||||
: .vars ( -- )
|
||||
namestack namestack. ;
|
||||
|
||||
SYMBOL: inspector-hook
|
||||
|
||||
[ H{ { +number-rows+ t } } describe* ] inspector-hook set-global
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
IN: temporary
|
||||
IN: io.backend.tests
|
||||
USING: tools.test io.backend kernel ;
|
||||
|
||||
[ ] [ "a" normalize-pathname drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,13 +1,17 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: init kernel system namespaces ;
|
||||
USING: init kernel system namespaces io io.encodings io.encodings.utf8 ;
|
||||
IN: io.backend
|
||||
|
||||
SYMBOL: io-backend
|
||||
|
||||
HOOK: init-io io-backend ( -- )
|
||||
|
||||
HOOK: init-stdio io-backend ( -- )
|
||||
HOOK: (init-stdio) io-backend ( -- stdin stdout stderr )
|
||||
|
||||
: init-stdio ( -- )
|
||||
(init-stdio) utf8 <encoder> stderr set-global
|
||||
utf8 <encoder-duplex> stdio set-global ;
|
||||
|
||||
HOOK: io-multiplex io-backend ( ms -- )
|
||||
|
||||
|
|
@ -19,7 +23,7 @@ HOOK: normalize-pathname io-backend ( str -- newstr )
|
|||
|
||||
M: object normalize-pathname ;
|
||||
|
||||
: set-io-backend ( backend -- )
|
||||
: set-io-backend ( io-backend -- )
|
||||
io-backend set-global init-io init-stdio ;
|
||||
|
||||
[ init-io embedded? [ init-stdio ] unless ]
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
USING: io.binary tools.test ;
|
||||
IN: temporary
|
||||
USING: io.binary tools.test classes math ;
|
||||
IN: io.binary.tests
|
||||
|
||||
[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test
|
||||
[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test
|
||||
[ B{ 0 0 4 HEX: d2 } ] [ 1234 4 >be ] unit-test
|
||||
[ B{ HEX: d2 4 0 0 } ] [ 1234 4 >le ] unit-test
|
||||
|
||||
[ 1234 ] [ 1234 4 >be be> ] unit-test
|
||||
[ 1234 ] [ 1234 4 >le le> ] unit-test
|
||||
|
||||
[ fixnum ] [ B{ 0 0 0 0 0 0 0 0 0 0 } be> class ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,14 +3,14 @@
|
|||
USING: kernel math sequences ;
|
||||
IN: io.binary
|
||||
|
||||
: le> ( seq -- x ) B{ } like byte-array>bignum ;
|
||||
: le> ( seq -- x ) B{ } like byte-array>bignum >integer ;
|
||||
: be> ( seq -- x ) <reversed> le> ;
|
||||
|
||||
: mask-byte ( x -- y ) HEX: ff bitand ; inline
|
||||
|
||||
: nth-byte ( x n -- b ) -8 * shift mask-byte ; inline
|
||||
|
||||
: >le ( x n -- str ) [ nth-byte ] with "" map-as ;
|
||||
: >le ( x n -- str ) [ nth-byte ] with B{ } map-as ;
|
||||
: >be ( x n -- str ) >le dup reverse-here ;
|
||||
|
||||
: d>w/w ( d -- w1 w2 )
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ HELP: crc32
|
|||
{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
|
||||
|
||||
HELP: lines-crc32
|
||||
{ $values { "lines" "a sequence of strings" } { "n" integer } }
|
||||
{ $values { "seq" "a sequence of strings" } { "n" integer } }
|
||||
{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
|
||||
|
||||
ARTICLE: "io.crc32" "CRC32 checksum calculation"
|
||||
|
|
|
|||
|
|
@ -1 +1,2 @@
|
|||
Daniel Ehrenberg
|
||||
Slava Pestov
|
||||
|
|
|
|||
|
|
@ -2,4 +2,4 @@ USING: help.syntax help.markup ;
|
|||
IN: io.encodings.binary
|
||||
|
||||
HELP: binary
|
||||
{ $class-description "This is the encoding descriptor for binary I/O." } ;
|
||||
{ $class-description "This is the encoding descriptor for binary I/O. Making an encoded stream with the binary encoding is a no-op; streams with this encoding deal with byte-arrays, not strings." } ;
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue