Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
22d14b036a
7
Makefile
7
Makefile
|
|
@ -7,7 +7,6 @@ CONSOLE_EXECUTABLE = factor-console
|
|||
TEST_LIBRARY = factor-ffi-test
|
||||
VERSION = 0.92
|
||||
|
||||
IMAGE = factor.image
|
||||
BUNDLE = Factor.app
|
||||
LIBPATH = -L/usr/X11R6/lib
|
||||
CFLAGS = -Wall
|
||||
|
|
@ -151,17 +150,17 @@ macosx.app: factor
|
|||
@executable_path/../Frameworks/libfactor.dylib \
|
||||
Factor.app/Contents/MacOS/factor
|
||||
|
||||
factor: $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
factor-console: $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
|
||||
$(LINKER) $(ENGINE) $(DLL_OBJS)
|
||||
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
|
||||
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
factor-ffi-test: vm/ffi_test.o
|
||||
$(TEST_LIBRARY): vm/ffi_test.o
|
||||
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
|
||||
|
||||
clean:
|
||||
|
|
|
|||
|
|
@ -1,7 +0,0 @@
|
|||
! (c)2009 Joe Groff, see bsd license
|
||||
USING: help.markup help.syntax ;
|
||||
IN: booleans
|
||||
|
||||
HELP: boolean
|
||||
{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ;
|
||||
|
||||
|
|
@ -1,7 +0,0 @@
|
|||
! (c)2009 Joe Groff, see bsd license
|
||||
USING: booleans tools.test ;
|
||||
IN: booleans.tests
|
||||
|
||||
[ t ] [ t boolean? ] unit-test
|
||||
[ t ] [ f boolean? ] unit-test
|
||||
[ f ] [ 1 boolean? ] unit-test
|
||||
|
|
@ -1,5 +0,0 @@
|
|||
! (c)2009 Joe Groff, see bsd license
|
||||
USING: kernel ;
|
||||
IN: booleans
|
||||
|
||||
UNION: boolean POSTPONE: t POSTPONE: f ;
|
||||
|
|
@ -68,9 +68,11 @@ SYMBOL: bootstrap-time
|
|||
"staging" get "deploy-vocab" get or [
|
||||
"stage2: deployment mode" print
|
||||
] [
|
||||
"listener" require
|
||||
"debugger" require
|
||||
"alien.prettyprint" require
|
||||
"inspector" require
|
||||
"tools.errors" require
|
||||
"listener" require
|
||||
"none" require
|
||||
] if
|
||||
|
||||
|
|
|
|||
|
|
@ -375,45 +375,21 @@ M: long-long-type flatten-value-type ( type -- types )
|
|||
: box-return* ( node -- )
|
||||
return>> [ ] [ box-return ] if-void ;
|
||||
|
||||
TUPLE: no-such-library name ;
|
||||
|
||||
M: no-such-library summary
|
||||
drop "Library not found" ;
|
||||
|
||||
M: no-such-library error-type drop +linkage-error+ ;
|
||||
|
||||
: no-such-library ( name -- )
|
||||
\ no-such-library boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
TUPLE: no-such-symbol name ;
|
||||
|
||||
M: no-such-symbol summary
|
||||
drop "Symbol not found" ;
|
||||
|
||||
M: no-such-symbol error-type drop +linkage-error+ ;
|
||||
|
||||
: no-such-symbol ( name -- )
|
||||
\ no-such-symbol boa
|
||||
compiling-word get compiler-error ;
|
||||
|
||||
: check-dlsym ( symbols dll -- )
|
||||
dup dll-valid? [
|
||||
dupd '[ _ dlsym ] any?
|
||||
[ drop ] [ no-such-symbol ] if
|
||||
[ drop ] [ compiling-word get no-such-symbol ] if
|
||||
] [
|
||||
dll-path no-such-library drop
|
||||
dll-path compiling-word get no-such-library drop
|
||||
] if ;
|
||||
|
||||
: stdcall-mangle ( symbol node -- symbol )
|
||||
"@"
|
||||
swap parameters>> parameter-sizes drop
|
||||
number>string 3append ;
|
||||
: stdcall-mangle ( symbol params -- symbol )
|
||||
parameters>> parameter-sizes drop number>string "@" glue ;
|
||||
|
||||
: alien-invoke-dlsym ( params -- symbols dll )
|
||||
dup function>> dup pick stdcall-mangle 2array
|
||||
swap library>> library dup [ dll>> ] when
|
||||
2dup check-dlsym ;
|
||||
[ [ function>> dup ] keep stdcall-mangle 2array ]
|
||||
[ library>> library dup [ dll>> ] when ]
|
||||
bi 2dup check-dlsym ;
|
||||
|
||||
M: ##alien-invoke generate-insn
|
||||
params>>
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ $nl
|
|||
$nl
|
||||
"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
|
||||
{ $list
|
||||
{ "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
|
||||
{ "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring certain compile errors generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
|
||||
{ "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
|
||||
{ "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
|
||||
{ "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." }
|
||||
|
|
|
|||
|
|
@ -2,13 +2,13 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces arrays sequences io words fry
|
||||
continuations vocabs assocs dlists definitions math graphs generic
|
||||
combinators deques search-deques macros io source-files.errors stack-checker
|
||||
stack-checker.state stack-checker.inlining combinators.short-circuit
|
||||
compiler.errors compiler.units compiler.tree.builder
|
||||
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer
|
||||
compiler.cfg.linearization compiler.cfg.two-operand
|
||||
compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen
|
||||
compiler.utilities ;
|
||||
combinators deques search-deques macros io source-files.errors
|
||||
stack-checker stack-checker.state stack-checker.inlining
|
||||
stack-checker.errors combinators.short-circuit compiler.errors
|
||||
compiler.units compiler.tree.builder compiler.tree.optimizer
|
||||
compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization
|
||||
compiler.cfg.two-operand compiler.cfg.linear-scan
|
||||
compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
|
||||
IN: compiler
|
||||
|
||||
SYMBOL: compile-queue
|
||||
|
|
@ -39,10 +39,10 @@ SYMBOL: compiled
|
|||
"trace-compilation" get [ dup name>> print flush ] when
|
||||
H{ } clone dependencies set
|
||||
H{ } clone generic-dependencies set
|
||||
f swap compiler-error ;
|
||||
clear-compiler-error ;
|
||||
|
||||
: ignore-error? ( word error -- ? )
|
||||
#! Ignore warnings on inline combinators, macros, and special
|
||||
#! Ignore some errors on inline combinators, macros, and special
|
||||
#! words such as 'call'.
|
||||
[
|
||||
{
|
||||
|
|
@ -51,7 +51,12 @@ SYMBOL: compiled
|
|||
[ "special" word-prop ]
|
||||
[ "no-compile" word-prop ]
|
||||
} 1||
|
||||
] [ error-type +compiler-warning+ eq? ] bi* and ;
|
||||
] [
|
||||
{
|
||||
[ do-not-compile? ]
|
||||
[ literal-expected? ]
|
||||
} 1||
|
||||
] bi* and ;
|
||||
|
||||
: finish ( word -- )
|
||||
#! Recompile callers if the word's stack effect changed, then
|
||||
|
|
@ -80,10 +85,16 @@ SYMBOL: compiled
|
|||
#! non-optimizing compiler, using its definition. Otherwise,
|
||||
#! if the compiler error is not ignorable, use a dummy
|
||||
#! definition from 'not-compiled-def' which throws an error.
|
||||
2dup ignore-error?
|
||||
[ drop f over def>> ]
|
||||
[ 2dup not-compiled-def ] if
|
||||
[ swap compiler-error ] [ deoptimize-with ] bi-curry* bi ;
|
||||
2dup ignore-error? [
|
||||
drop
|
||||
[ dup def>> deoptimize-with ]
|
||||
[ clear-compiler-error ]
|
||||
bi
|
||||
] [
|
||||
[ swap <compiler-error> compiler-error ]
|
||||
[ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ]
|
||||
2bi
|
||||
] if ;
|
||||
|
||||
: frontend ( word -- nodes )
|
||||
#! If the word contains breakpoints, don't optimize it, since
|
||||
|
|
|
|||
|
|
@ -1,56 +1,72 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors source-files.errors kernel namespaces assocs ;
|
||||
USING: accessors source-files.errors kernel namespaces assocs fry
|
||||
summary ;
|
||||
IN: compiler.errors
|
||||
|
||||
TUPLE: compiler-error < source-file-error ;
|
||||
|
||||
M: compiler-error error-type error>> error-type ;
|
||||
|
||||
SYMBOL: +compiler-error+
|
||||
SYMBOL: compiler-errors
|
||||
|
||||
compiler-errors [ H{ } clone ] initialize
|
||||
|
||||
SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ;
|
||||
TUPLE: compiler-error < source-file-error ;
|
||||
|
||||
: errors-of-type ( type -- assoc )
|
||||
compiler-errors get-global
|
||||
swap [ [ nip error-type ] dip eq? ] curry
|
||||
assoc-filter ;
|
||||
M: compiler-error error-type drop +compiler-error+ ;
|
||||
|
||||
SYMBOL: +linkage-error+
|
||||
SYMBOL: linkage-errors
|
||||
|
||||
linkage-errors [ H{ } clone ] initialize
|
||||
|
||||
TUPLE: linkage-error < source-file-error ;
|
||||
|
||||
M: linkage-error error-type drop +linkage-error+ ;
|
||||
|
||||
: clear-compiler-error ( word -- )
|
||||
compiler-errors linkage-errors
|
||||
[ get-global delete-at ] bi-curry@ bi ;
|
||||
|
||||
: compiler-error ( error -- )
|
||||
dup asset>> compiler-errors get-global set-at ;
|
||||
|
||||
T{ error-type
|
||||
{ type +compiler-error+ }
|
||||
{ word ":errors" }
|
||||
{ plural "compiler errors" }
|
||||
{ icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" }
|
||||
{ quot [ +compiler-error+ errors-of-type values ] }
|
||||
{ quot [ compiler-errors get values ] }
|
||||
{ forget-quot [ compiler-errors get delete-at ] }
|
||||
} define-error-type
|
||||
|
||||
T{ error-type
|
||||
{ type +compiler-warning+ }
|
||||
{ word ":warnings" }
|
||||
{ plural "compiler warnings" }
|
||||
{ icon "vocab:ui/tools/error-list/icons/compiler-warning.tiff" }
|
||||
{ quot [ +compiler-warning+ errors-of-type values ] }
|
||||
{ forget-quot [ compiler-errors get delete-at ] }
|
||||
} define-error-type
|
||||
: <compiler-error> ( error word -- compiler-error )
|
||||
\ compiler-error <definition-error> ;
|
||||
|
||||
: <linkage-error> ( error word -- linkage-error )
|
||||
\ linkage-error <definition-error> ;
|
||||
|
||||
: linkage-error ( error word class -- )
|
||||
'[ _ boa ] dip <linkage-error> dup asset>> linkage-errors get set-at ; inline
|
||||
|
||||
T{ error-type
|
||||
{ type +linkage-error+ }
|
||||
{ word ":linkage" }
|
||||
{ plural "linkage errors" }
|
||||
{ icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
|
||||
{ quot [ +linkage-error+ errors-of-type values ] }
|
||||
{ forget-quot [ compiler-errors get delete-at ] }
|
||||
{ quot [ linkage-errors get values ] }
|
||||
{ forget-quot [ linkage-errors get delete-at ] }
|
||||
{ fatal? f }
|
||||
} define-error-type
|
||||
|
||||
: <compiler-error> ( error word -- compiler-error )
|
||||
\ compiler-error <definition-error> ;
|
||||
TUPLE: no-such-library name ;
|
||||
|
||||
: compiler-error ( error word -- )
|
||||
compiler-errors get-global pick
|
||||
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
|
||||
M: no-such-library summary drop "Library not found" ;
|
||||
|
||||
: no-such-library ( name word -- ) \ no-such-library linkage-error ;
|
||||
|
||||
TUPLE: no-such-symbol name ;
|
||||
|
||||
M: no-such-symbol summary drop "Symbol not found" ;
|
||||
|
||||
: no-such-symbol ( name word -- ) \ no-such-symbol linkage-error ;
|
||||
|
||||
ERROR: not-compiled word error ;
|
||||
|
|
@ -15,7 +15,7 @@ IN: compiler.tree.builder
|
|||
|
||||
GENERIC: (build-tree) ( quot -- )
|
||||
|
||||
M: callable (build-tree) f initial-recursive-state infer-quot ;
|
||||
M: callable (build-tree) infer-quot-here ;
|
||||
|
||||
: check-no-compile ( word -- )
|
||||
dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
|
||||
|
|
@ -31,15 +31,13 @@ M: callable (build-tree) f initial-recursive-state infer-quot ;
|
|||
dup inline-recursive? [ 1quotation ] [ specialized-def ] if ;
|
||||
|
||||
M: word (build-tree)
|
||||
{
|
||||
[ initial-recursive-state recursive-state set ]
|
||||
[ check-no-compile ]
|
||||
[ word-body infer-quot-here ]
|
||||
[ current-effect check-effect ]
|
||||
} cleave ;
|
||||
[ check-no-compile ]
|
||||
[ word-body infer-quot-here ]
|
||||
[ current-effect check-effect ] tri ;
|
||||
|
||||
: build-tree-with ( in-stack word/quot -- nodes )
|
||||
[
|
||||
<recursive-state> recursive-state set
|
||||
V{ } clone stack-visitor set
|
||||
[ [ >vector \ meta-d set ] [ length d-in set ] bi ]
|
||||
[ (build-tree) ]
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ M: word article-title
|
|||
dup [ parsing-word? ] [ symbol? ] bi or [
|
||||
name>>
|
||||
] [
|
||||
[ name>> ]
|
||||
[ unparse ]
|
||||
[ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi
|
||||
append
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -15,13 +15,20 @@ HELP: each-file
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: recursive-directory
|
||||
HELP: recursive-directory-files
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" }
|
||||
{ "paths" "a sequence of pathname strings" }
|
||||
}
|
||||
{ $description "Traverses a directory path recursively and returns a sequence of files in a breadth-first or depth-first manner." } ;
|
||||
|
||||
HELP: recursive-directory-entries
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" }
|
||||
{ "directory-entries" "a sequence of directory-entries" }
|
||||
}
|
||||
{ $description "Traverses a directory path recursively and returns a sequence of directory-entries in a breadth-first or depth-first manner." } ;
|
||||
|
||||
HELP: find-file
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
|
||||
|
|
@ -41,11 +48,11 @@ HELP: find-all-files
|
|||
{ "path" "a pathname string" } { "quot" quotation }
|
||||
{ "paths/f" "a sequence of pathname strings or f" }
|
||||
}
|
||||
{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ;
|
||||
{ $description "Recursively finds all files in the input directory matching the predicate quotation." } ;
|
||||
|
||||
HELP: find-all-in-directories
|
||||
{ $values
|
||||
{ "directories" "a sequence of directory paths" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation }
|
||||
{ "directories" "a sequence of directory paths" } { "quot" quotation }
|
||||
{ "paths/f" "a sequence of pathname strings or f" }
|
||||
}
|
||||
{ $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
|
||||
|
|
@ -55,7 +62,8 @@ HELP: find-all-in-directories
|
|||
ARTICLE: "io.directories.search" "Searching directories"
|
||||
"The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl
|
||||
"Traversing directories:"
|
||||
{ $subsection recursive-directory }
|
||||
{ $subsection recursive-directory-files }
|
||||
{ $subsection recursive-directory-entries }
|
||||
{ $subsection each-file }
|
||||
"Finding files:"
|
||||
{ $subsection find-file }
|
||||
|
|
|
|||
|
|
@ -1,12 +1,14 @@
|
|||
USING: io.directories.search io.files io.files.unique
|
||||
io.pathnames kernel namespaces sequences sorting tools.test ;
|
||||
USING: combinators.smart io.directories
|
||||
io.directories.hierarchy io.directories.search io.files
|
||||
io.files.unique io.pathnames kernel namespaces sequences
|
||||
sorting strings tools.test ;
|
||||
IN: io.directories.search.tests
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
10 [ "io.paths.test" "gogogo" make-unique-file ] replicate
|
||||
current-temporary-directory get [ ] find-all-files
|
||||
] with-unique-directory drop [ natural-sort ] bi@ =
|
||||
] cleanup-unique-directory [ natural-sort ] bi@ =
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
|
|
@ -18,3 +20,18 @@ IN: io.directories.search.tests
|
|||
[ f ] [
|
||||
{ } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[
|
||||
current-temporary-directory get
|
||||
"the-head" unique-file drop t
|
||||
[ file-name "the-head" head? ] find-file string?
|
||||
] cleanup-unique-directory
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ unique-directory unique-directory ] output>array
|
||||
[ [ "abcd" append-path touch-file ] each ]
|
||||
[ [ file-name "abcd" = ] find-all-in-directories length 2 = ]
|
||||
[ [ delete-tree ] each ] tri
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -3,96 +3,106 @@
|
|||
USING: accessors arrays continuations deques dlists fry
|
||||
io.directories io.files io.files.info io.pathnames kernel
|
||||
sequences system vocabs.loader locals math namespaces
|
||||
sorting assocs ;
|
||||
sorting assocs calendar threads io math.parser ;
|
||||
IN: io.directories.search
|
||||
|
||||
: qualified-directory-entries ( path -- seq )
|
||||
dup directory-entries
|
||||
[ [ append-path ] change-name ] with map ;
|
||||
|
||||
: qualified-directory-files ( path -- seq )
|
||||
dup directory-files [ append-path ] with map ;
|
||||
|
||||
: with-qualified-directory-files ( path quot -- )
|
||||
'[ "" qualified-directory-files @ ] with-directory ; inline
|
||||
|
||||
: with-qualified-directory-entries ( path quot -- )
|
||||
'[ "" qualified-directory-entries @ ] with-directory ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: directory-iterator path bfs queue ;
|
||||
|
||||
: qualified-directory ( path -- seq )
|
||||
dup directory-files [ append-path ] with map ;
|
||||
|
||||
: push-directory ( path iter -- )
|
||||
[ qualified-directory ] dip '[
|
||||
: push-directory-entries ( path iter -- )
|
||||
[ [ qualified-directory-entries ] [ 2drop f ] recover ] dip '[
|
||||
_ [ queue>> ] [ bfs>> ] bi
|
||||
[ push-front ] [ push-back ] if
|
||||
] each ;
|
||||
|
||||
: <directory-iterator> ( path bfs? -- iterator )
|
||||
<dlist> directory-iterator boa
|
||||
dup path>> over push-directory ;
|
||||
dup path>> over push-directory-entries ;
|
||||
|
||||
: next-file ( iter -- file/f )
|
||||
: next-directory-entry ( iter -- directory-entry/f )
|
||||
dup queue>> deque-empty? [ drop f ] [
|
||||
dup queue>> pop-back dup link-info directory?
|
||||
[ over push-directory next-file ] [ nip ] if
|
||||
dup queue>> pop-back
|
||||
dup directory?
|
||||
[ name>> over push-directory-entries next-directory-entry ]
|
||||
[ nip ] if
|
||||
] if ;
|
||||
|
||||
:: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
|
||||
iter next-file [
|
||||
quot call [ iter quot iterate-directory ] unless*
|
||||
:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f )
|
||||
iter next-directory-entry [
|
||||
quot call
|
||||
[ iter quot iterate-directory-entries ] unless*
|
||||
] [
|
||||
f
|
||||
] if* ; inline recursive
|
||||
|
||||
: iterate-directory ( iter quot -- path/f )
|
||||
[ name>> ] prepose iterate-directory-entries ; inline
|
||||
|
||||
: setup-traversal ( path bfs quot -- iterator quot' )
|
||||
[ <directory-iterator> ] dip [ f ] compose ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: each-file ( path bfs? quot: ( obj -- ) -- )
|
||||
: each-file ( path bfs? quot -- )
|
||||
setup-traversal iterate-directory drop ; inline
|
||||
|
||||
: each-directory-entry ( path bfs? quot -- )
|
||||
setup-traversal iterate-directory-entries drop ; inline
|
||||
|
||||
: recursive-directory-files ( path bfs? -- paths )
|
||||
[ ] accumulator [ each-file ] dip ; inline
|
||||
|
||||
: recursive-directory-entries ( path bfs? -- directory-entries )
|
||||
[ ] accumulator [ each-directory-entry ] dip ; inline
|
||||
|
||||
: find-file ( path bfs? quot -- path/f )
|
||||
[ <directory-iterator> ] dip
|
||||
[ f ] compose iterate-directory drop ; inline
|
||||
[ keep and ] curry iterate-directory ; inline
|
||||
|
||||
: recursive-directory ( path bfs? -- paths )
|
||||
[ ] accumulator [ each-file ] dip ;
|
||||
: find-all-files ( path quot -- paths/f )
|
||||
[ f <directory-iterator> ] dip pusher
|
||||
[ [ f ] compose iterate-directory drop ] dip ; inline
|
||||
|
||||
: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
|
||||
'[
|
||||
_ _ _ [ <directory-iterator> ] dip
|
||||
[ keep and ] curry iterate-directory
|
||||
] [ drop f ] recover ; inline
|
||||
ERROR: file-not-found path bfs? quot ;
|
||||
|
||||
: find-all-files ( path quot: ( obj -- ? ) -- paths/f )
|
||||
f swap
|
||||
'[
|
||||
_ _ _ [ <directory-iterator> ] dip
|
||||
pusher [ [ f ] compose iterate-directory drop ] dip
|
||||
] [ drop f ] recover ; inline
|
||||
: find-file-throws ( path bfs? quot -- path )
|
||||
3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline
|
||||
|
||||
ERROR: file-not-found ;
|
||||
: find-in-directories ( directories bfs? quot -- path'/f )
|
||||
'[ _ [ _ _ find-file-throws ] attempt-all ]
|
||||
[ drop f ] recover ; inline
|
||||
|
||||
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
|
||||
'[
|
||||
_ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
|
||||
] [
|
||||
drop f
|
||||
] recover ; inline
|
||||
: find-all-in-directories ( directories quot -- paths/f )
|
||||
'[ _ find-all-files ] map concat ; inline
|
||||
|
||||
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
|
||||
'[ _ _ find-all-files ] map concat ; inline
|
||||
|
||||
: with-qualified-directory-files ( path quot -- )
|
||||
'[
|
||||
"" directory-files current-directory get
|
||||
'[ _ prepend-path ] map @
|
||||
] with-directory ; inline
|
||||
|
||||
: with-qualified-directory-entries ( path quot -- )
|
||||
'[
|
||||
"" directory-entries current-directory get
|
||||
'[ [ _ prepend-path ] change-name ] map @
|
||||
] with-directory ; inline
|
||||
: link-size/0 ( path -- n )
|
||||
[ link-info size-on-disk>> ] [ 2drop 0 ] recover ;
|
||||
|
||||
: directory-size ( path -- n )
|
||||
0 swap t [ link-info size-on-disk>> + ] each-file ;
|
||||
0 swap t [ link-size/0 + ] each-file ;
|
||||
|
||||
: path>usage ( directory-entry -- name size )
|
||||
[ name>> dup ] [ directory? ] bi
|
||||
[ directory-size ] [ link-size/0 ] if ;
|
||||
|
||||
: directory-usage ( path -- assoc )
|
||||
[
|
||||
[
|
||||
[ name>> dup ] [ directory? ] bi [
|
||||
directory-size
|
||||
] [
|
||||
link-info size-on-disk>>
|
||||
] if
|
||||
[ path>usage ] [ drop name>> 0 ] recover
|
||||
] { } map>assoc
|
||||
] with-qualified-directory-entries sort-values ;
|
||||
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ SYMBOL: max-stack-items
|
|||
|
||||
10 max-stack-items set-global
|
||||
|
||||
SYMBOL: error-summary-hook
|
||||
SYMBOL: error-summary?
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -99,13 +99,8 @@ SYMBOL: error-summary-hook
|
|||
in get auto-use? get [ " - auto" append ] when "( " " )" surround
|
||||
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
|
||||
|
||||
[ error-summary ] error-summary-hook set-global
|
||||
|
||||
: call-error-summary-hook ( -- )
|
||||
error-summary-hook get call( -- ) ;
|
||||
|
||||
:: (listener) ( datastack -- )
|
||||
call-error-summary-hook
|
||||
error-summary? get [ error-summary ] when
|
||||
visible-vars.
|
||||
datastack datastack.
|
||||
prompt.
|
||||
|
|
|
|||
|
|
@ -35,8 +35,8 @@ M: effect pprint* effect>string "(" ")" surround text ;
|
|||
name>> "( no name )" or ;
|
||||
|
||||
: pprint-word ( word -- )
|
||||
dup record-vocab
|
||||
dup word-name* swap word-style styled-text ;
|
||||
[ record-vocab ]
|
||||
[ [ word-name* ] [ word-style ] bi styled-text ] bi ;
|
||||
|
||||
: pprint-prefix ( word quot -- )
|
||||
<block swap pprint-word call block> ; inline
|
||||
|
|
@ -48,11 +48,12 @@ M: word pprint*
|
|||
[ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
|
||||
|
||||
M: method-body pprint*
|
||||
<block
|
||||
\ M\ pprint-word
|
||||
[ "method-class" word-prop pprint-word ]
|
||||
[ "method-generic" word-prop pprint-word ] bi
|
||||
block> ;
|
||||
[
|
||||
[
|
||||
[ "M\\ " % "method-class" word-prop word-name* % ]
|
||||
[ " " % "method-generic" word-prop word-name* % ] bi
|
||||
] "" make
|
||||
] [ word-style ] bi styled-text ;
|
||||
|
||||
M: real pprint* number>string text ;
|
||||
|
||||
|
|
|
|||
|
|
@ -101,8 +101,6 @@ $nl
|
|||
{ $subsection recursive-quotation-error }
|
||||
{ $subsection too-many->r }
|
||||
{ $subsection too-many-r> }
|
||||
{ $subsection missing-effect }
|
||||
"Main wrapper for all inference warnings and errors:"
|
||||
{ $subsection inference-error } ;
|
||||
{ $subsection missing-effect } ;
|
||||
|
||||
ABOUT: "inference-errors"
|
||||
|
|
|
|||
|
|
@ -1,93 +1,36 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic sequences io words arrays summary effects
|
||||
continuations assocs accessors namespaces compiler.errors
|
||||
stack-checker.values stack-checker.recursive-state
|
||||
source-files.errors compiler.errors ;
|
||||
USING: kernel stack-checker.values ;
|
||||
IN: stack-checker.errors
|
||||
|
||||
: pretty-word ( word -- word' )
|
||||
dup method-body? [ "method-generic" word-prop ] when ;
|
||||
TUPLE: inference-error ;
|
||||
|
||||
TUPLE: inference-error error type word ;
|
||||
ERROR: do-not-compile < inference-error word ;
|
||||
|
||||
M: inference-error error-type type>> ;
|
||||
ERROR: literal-expected < inference-error what ;
|
||||
|
||||
: (inference-error) ( ... class type -- * )
|
||||
[ boa ] dip
|
||||
recursive-state get word>>
|
||||
\ inference-error boa rethrow ; inline
|
||||
ERROR: unbalanced-branches-error < inference-error branches quots ;
|
||||
|
||||
: inference-error ( ... class -- * )
|
||||
+compiler-error+ (inference-error) ; inline
|
||||
ERROR: too-many->r < inference-error ;
|
||||
|
||||
: inference-warning ( ... class -- * )
|
||||
+compiler-warning+ (inference-error) ; inline
|
||||
ERROR: too-many-r> < inference-error ;
|
||||
|
||||
TUPLE: do-not-compile word ;
|
||||
ERROR: missing-effect < inference-error word ;
|
||||
|
||||
: do-not-compile ( word -- * ) \ do-not-compile inference-warning ;
|
||||
ERROR: effect-error < inference-error inferred declared ;
|
||||
|
||||
TUPLE: literal-expected what ;
|
||||
ERROR: recursive-quotation-error < inference-error quot ;
|
||||
|
||||
: literal-expected ( what -- * ) \ literal-expected inference-warning ;
|
||||
ERROR: undeclared-recursion-error < inference-error word ;
|
||||
|
||||
M: object (literal) "literal value" literal-expected ;
|
||||
ERROR: diverging-recursion-error < inference-error word ;
|
||||
|
||||
TUPLE: unbalanced-branches-error branches quots ;
|
||||
ERROR: unbalanced-recursion-error < inference-error word height ;
|
||||
|
||||
: unbalanced-branches-error ( branches quots -- * )
|
||||
\ unbalanced-branches-error inference-error ;
|
||||
ERROR: inconsistent-recursive-call-error < inference-error word ;
|
||||
|
||||
TUPLE: too-many->r ;
|
||||
ERROR: unknown-primitive-error < inference-error ;
|
||||
|
||||
: too-many->r ( -- * ) \ too-many->r inference-error ;
|
||||
ERROR: transform-expansion-error < inference-error word error ;
|
||||
|
||||
TUPLE: too-many-r> ;
|
||||
|
||||
: too-many-r> ( -- * ) \ too-many-r> inference-error ;
|
||||
|
||||
TUPLE: missing-effect word ;
|
||||
|
||||
: missing-effect ( word -- * )
|
||||
pretty-word \ missing-effect inference-error ;
|
||||
|
||||
TUPLE: effect-error inferred declared ;
|
||||
|
||||
: effect-error ( inferred declared -- * )
|
||||
\ effect-error inference-error ;
|
||||
|
||||
TUPLE: recursive-quotation-error quot ;
|
||||
|
||||
: recursive-quotation-error ( word -- * )
|
||||
\ recursive-quotation-error inference-error ;
|
||||
|
||||
TUPLE: undeclared-recursion-error word ;
|
||||
|
||||
: undeclared-recursion-error ( word -- * )
|
||||
\ undeclared-recursion-error inference-error ;
|
||||
|
||||
TUPLE: diverging-recursion-error word ;
|
||||
|
||||
: diverging-recursion-error ( word -- * )
|
||||
\ diverging-recursion-error inference-error ;
|
||||
|
||||
TUPLE: unbalanced-recursion-error word height ;
|
||||
|
||||
: unbalanced-recursion-error ( word height -- * )
|
||||
\ unbalanced-recursion-error inference-error ;
|
||||
|
||||
TUPLE: inconsistent-recursive-call-error word ;
|
||||
|
||||
: inconsistent-recursive-call-error ( word -- * )
|
||||
\ inconsistent-recursive-call-error inference-error ;
|
||||
|
||||
TUPLE: unknown-primitive-error ;
|
||||
|
||||
: unknown-primitive-error ( -- * )
|
||||
\ unknown-primitive-error inference-warning ;
|
||||
|
||||
TUPLE: transform-expansion-error word error ;
|
||||
|
||||
: transform-expansion-error ( word error -- * )
|
||||
\ transform-expansion-error inference-error ;
|
||||
M: object (literal) "literal value" literal-expected ;
|
||||
|
|
@ -1,18 +1,11 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel prettyprint io debugger
|
||||
sequences assocs stack-checker.errors summary effects make ;
|
||||
sequences assocs stack-checker.errors summary effects ;
|
||||
IN: stack-checker.errors.prettyprint
|
||||
|
||||
M: inference-error summary error>> summary ;
|
||||
|
||||
M: inference-error error-help error>> error-help ;
|
||||
|
||||
M: inference-error error.
|
||||
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
|
||||
|
||||
M: literal-expected summary
|
||||
[ "Got a computed value where a " % what>> % " was expected" % ] "" make ;
|
||||
what>> "Got a computed value where a " " was expected" surround ;
|
||||
|
||||
M: literal-expected error. summary print ;
|
||||
|
||||
|
|
@ -25,63 +18,45 @@ M: unbalanced-branches-error error.
|
|||
[ [ first pprint-short bl ] [ second effect>string print ] bi ] each ;
|
||||
|
||||
M: too-many->r summary
|
||||
drop
|
||||
"Quotation pushes elements on retain stack without popping them" ;
|
||||
drop "Quotation pushes elements on retain stack without popping them" ;
|
||||
|
||||
M: too-many-r> summary
|
||||
drop
|
||||
"Quotation pops retain stack elements which it did not push" ;
|
||||
drop "Quotation pops retain stack elements which it did not push" ;
|
||||
|
||||
M: missing-effect summary
|
||||
[
|
||||
"The word " %
|
||||
word>> name>> %
|
||||
" must declare a stack effect" %
|
||||
] "" make ;
|
||||
drop "Missing stack effect declaration" ;
|
||||
|
||||
M: effect-error summary
|
||||
drop "Stack effect declaration is wrong" ;
|
||||
|
||||
M: recursive-quotation-error error.
|
||||
"The quotation " write
|
||||
quot>> pprint
|
||||
" calls itself." print
|
||||
"Stack effect inference is undecidable when quotation-level recursion is permitted." print ;
|
||||
M: recursive-quotation-error summary
|
||||
drop "Recursive quotation" ;
|
||||
|
||||
M: undeclared-recursion-error summary
|
||||
drop
|
||||
"Inline recursive words must be declared recursive" ;
|
||||
word>> name>>
|
||||
"The inline recursive word " " must be declared recursive" surround ;
|
||||
|
||||
M: diverging-recursion-error summary
|
||||
[
|
||||
"The recursive word " %
|
||||
word>> name>> %
|
||||
" digs arbitrarily deep into the stack" %
|
||||
] "" make ;
|
||||
word>> name>>
|
||||
"The recursive word " " digs arbitrarily deep into the stack" surround ;
|
||||
|
||||
M: unbalanced-recursion-error summary
|
||||
[
|
||||
"The recursive word " %
|
||||
word>> name>> %
|
||||
" leaves with the stack having the wrong height" %
|
||||
] "" make ;
|
||||
word>> name>>
|
||||
"The recursive word " " leaves with the stack having the wrong height" surround ;
|
||||
|
||||
M: inconsistent-recursive-call-error summary
|
||||
[
|
||||
"The recursive word " %
|
||||
word>> name>> %
|
||||
" calls itself with a different set of quotation parameters than were input" %
|
||||
] "" make ;
|
||||
word>> name>>
|
||||
"The recursive word "
|
||||
" calls itself with a different set of quotation parameters than were input" surround ;
|
||||
|
||||
M: unknown-primitive-error summary
|
||||
drop
|
||||
"Cannot determine stack effect statically" ;
|
||||
word>> name>> "The " " word cannot be called from optimized words" surround ;
|
||||
|
||||
M: transform-expansion-error summary
|
||||
drop
|
||||
"Compiler transform threw an error" ;
|
||||
word>> name>> "Macro expansion of " " threw an error" surround ;
|
||||
|
||||
M: transform-expansion-error error.
|
||||
[ summary print ]
|
||||
[ "Word: " write word>> . nl ]
|
||||
[ error>> error. ] tri ;
|
||||
[ summary print ] [ error>> error. ] bi ;
|
||||
|
||||
M: do-not-compile summary
|
||||
word>> name>> "Cannot compile call to " prepend ;
|
||||
|
|
@ -1,25 +1,19 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays sequences kernel sequences assocs
|
||||
namespaces stack-checker.recursive-state.tree ;
|
||||
USING: accessors kernel namespaces stack-checker.recursive-state.tree ;
|
||||
IN: stack-checker.recursive-state
|
||||
|
||||
TUPLE: recursive-state word quotations inline-words ;
|
||||
TUPLE: recursive-state quotations inline-words ;
|
||||
|
||||
: initial-recursive-state ( word -- state )
|
||||
recursive-state new
|
||||
swap >>word
|
||||
f >>quotations
|
||||
f >>inline-words ; inline
|
||||
: <recursive-state> ( -- state ) recursive-state new ; inline
|
||||
|
||||
f initial-recursive-state recursive-state set-global
|
||||
<recursive-state> recursive-state set-global
|
||||
|
||||
: add-local-quotation ( rstate quot -- rstate )
|
||||
swap clone [ dupd store ] change-quotations ;
|
||||
|
||||
: add-inline-word ( word label -- rstate )
|
||||
swap recursive-state get clone
|
||||
[ store ] change-inline-words ;
|
||||
swap recursive-state get clone [ store ] change-inline-words ;
|
||||
|
||||
: inline-recursive-label ( word -- label/f )
|
||||
recursive-state get inline-words>> lookup ;
|
||||
|
|
|
|||
|
|
@ -1,35 +1,34 @@
|
|||
IN: tools.errors
|
||||
USING: help.markup help.syntax source-files.errors words io
|
||||
compiler.errors ;
|
||||
compiler.errors classes ;
|
||||
|
||||
ARTICLE: "compiler-errors" "Compiler warnings and errors"
|
||||
"After loading a vocabulary, you might see messages like:"
|
||||
ARTICLE: "compiler-errors" "Compiler errors"
|
||||
"After loading a vocabulary, you might see a message like:"
|
||||
{ $code
|
||||
":errors - print 2 compiler errors"
|
||||
":warnings - print 1 compiler warnings"
|
||||
}
|
||||
"This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "."
|
||||
$nl
|
||||
"Words to view warnings and errors:"
|
||||
{ $subsection :warnings }
|
||||
"Words to view errors:"
|
||||
{ $subsection :errors }
|
||||
{ $subsection :linkage }
|
||||
"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ;
|
||||
"Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ;
|
||||
|
||||
HELP: compiler-error
|
||||
{ $values { "error" "an error" } { "word" word } }
|
||||
{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ;
|
||||
{ $values { "error" compiler-error } }
|
||||
{ $description "Saves the error for viewing with " { $link :errors } "." } ;
|
||||
|
||||
HELP: linkage-error
|
||||
{ $values { "error" linkage-error } { "word" word } { "class" class } }
|
||||
{ $description "Saves the error for viewing with " { $link :linkage } "." } ;
|
||||
|
||||
HELP: :errors
|
||||
{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
|
||||
|
||||
HELP: :warnings
|
||||
{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
|
||||
{ $description "Prints all compiler errors." } ;
|
||||
|
||||
HELP: :linkage
|
||||
{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
|
||||
{ $description "Prints all C library interface linkage errors." } ;
|
||||
|
||||
{ :errors :warnings :linkage } related-words
|
||||
{ :errors :linkage } related-words
|
||||
|
||||
HELP: errors.
|
||||
{ $values { "errors" "a sequence of " { $link source-file-error } " instances" } }
|
||||
|
|
|
|||
|
|
@ -6,14 +6,7 @@ DEFER: blah
|
|||
[ ] [
|
||||
{
|
||||
T{ compiler-error
|
||||
{ error
|
||||
T{ inference-error
|
||||
f
|
||||
T{ do-not-compile f blah }
|
||||
+compiler-error+
|
||||
blah
|
||||
}
|
||||
}
|
||||
{ error T{ do-not-compile f blah } }
|
||||
{ asset blah }
|
||||
}
|
||||
} errors.
|
||||
|
|
|
|||
|
|
@ -2,17 +2,15 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs debugger io kernel sequences source-files.errors
|
||||
summary accessors continuations make math.parser io.styles namespaces
|
||||
compiler.errors ;
|
||||
compiler.errors prettyprint ;
|
||||
IN: tools.errors
|
||||
|
||||
#! Tools for source-files.errors. Used by tools.tests and others
|
||||
#! for error reporting
|
||||
|
||||
M: source-file-error compute-restarts
|
||||
error>> compute-restarts ;
|
||||
M: source-file-error compute-restarts error>> compute-restarts ;
|
||||
|
||||
M: source-file-error error-help
|
||||
error>> error-help ;
|
||||
M: source-file-error error-help error>> error-help ;
|
||||
|
||||
CONSTANT: +listener-input+ "<Listener input>"
|
||||
|
||||
|
|
@ -20,11 +18,13 @@ M: source-file-error summary
|
|||
[
|
||||
[ file>> [ % ": " % ] [ +listener-input+ % ] if* ]
|
||||
[ line#>> [ # ] when* ] bi
|
||||
] "" make
|
||||
;
|
||||
] "" make ;
|
||||
|
||||
M: source-file-error error.
|
||||
[ summary print nl ] [ error>> error. ] bi ;
|
||||
[ summary print nl ]
|
||||
[ asset>> [ "Asset: " write short. nl ] when* ]
|
||||
[ error>> error. ]
|
||||
tri ;
|
||||
|
||||
: errors. ( errors -- )
|
||||
group-by-source-file sort-errors
|
||||
|
|
@ -34,14 +34,9 @@ M: source-file-error error.
|
|||
bi*
|
||||
] assoc-each ;
|
||||
|
||||
: compiler-errors. ( type -- )
|
||||
errors-of-type values errors. ;
|
||||
: :errors ( -- ) compiler-errors get values errors. ;
|
||||
|
||||
: :errors ( -- ) +compiler-error+ compiler-errors. ;
|
||||
|
||||
: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
|
||||
|
||||
: :linkage ( -- ) +linkage-error+ compiler-errors. ;
|
||||
: :linkage ( -- ) linkage-errors get values errors. ;
|
||||
|
||||
M: not-compiled summary
|
||||
word>> name>> "The word " " cannot be executed because it failed to compile" surround ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: models source-files.errors namespaces models.delay init
|
||||
kernel calendar ;
|
||||
IN: tools.errors.model
|
||||
|
||||
SYMBOLS: (error-list-model) error-list-model ;
|
||||
|
||||
(error-list-model) [ f <model> ] initialize
|
||||
|
||||
error-list-model [ (error-list-model) get-global 100 milliseconds <delay> ] initialize
|
||||
|
||||
SINGLETON: updater
|
||||
|
||||
M: updater errors-changed drop f (error-list-model) get-global set-model ;
|
||||
|
||||
[ updater add-error-observer ] "ui.tools.error-list" add-init-hook
|
||||
|
||||
|
|
@ -10,7 +10,7 @@ IN: tools.time
|
|||
: time. ( data -- )
|
||||
unclip
|
||||
"==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl
|
||||
4 cut*
|
||||
5 cut*
|
||||
"==== GARBAGE COLLECTION" print nl
|
||||
[
|
||||
6 group
|
||||
|
|
@ -32,6 +32,7 @@ IN: tools.time
|
|||
"Total GC time (us):"
|
||||
"Cards scanned:"
|
||||
"Decks scanned:"
|
||||
"Card scan time (us):"
|
||||
"Code heap literal scans:"
|
||||
} swap zip simple-table.
|
||||
] bi* ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: ui.gadgets.tables.tests
|
||||
USING: ui.gadgets.tables ui.gadgets.scrollers accessors
|
||||
models namespaces tools.test kernel ;
|
||||
USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors
|
||||
models namespaces tools.test kernel combinators ;
|
||||
|
||||
SINGLETON: test-renderer
|
||||
|
||||
|
|
@ -8,15 +8,40 @@ M: test-renderer row-columns drop ;
|
|||
|
||||
M: test-renderer column-titles drop { "First" "Last" } ;
|
||||
|
||||
[ ] [
|
||||
: test-table ( -- table )
|
||||
{
|
||||
{ "Britney" "Spears" }
|
||||
{ "Justin" "Timberlake" }
|
||||
{ "Don" "Stewart" }
|
||||
} <model> test-renderer <table>
|
||||
"table" set
|
||||
} <model> test-renderer <table> ;
|
||||
|
||||
[ ] [
|
||||
test-table "table" set
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
"table" get <scroller> "scroller" set
|
||||
] unit-test
|
||||
|
||||
[ { "Justin" "Timberlake" } { "Britney" "Spears" } ] [
|
||||
test-table t >>selection-required? dup [
|
||||
{
|
||||
[ 1 select-row ]
|
||||
[
|
||||
model>> {
|
||||
{ "Justin" "Timberlake" }
|
||||
{ "Britney" "Spears" }
|
||||
{ "Don" "Stewart" }
|
||||
} swap set-model
|
||||
]
|
||||
[ selected-row drop ]
|
||||
[
|
||||
model>> {
|
||||
{ "Britney" "Spears" }
|
||||
{ "Don" "Stewart" }
|
||||
} swap set-model
|
||||
]
|
||||
[ selected-row drop ]
|
||||
} cleave
|
||||
] with-grafted-gadget
|
||||
] unit-test
|
||||
|
|
@ -5,8 +5,8 @@ math.functions math.rectangles math.order math.vectors namespaces
|
|||
opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
|
||||
ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text
|
||||
ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support
|
||||
math.rectangles models math.ranges sequences combinators fonts locals
|
||||
strings ;
|
||||
math.rectangles models math.ranges sequences combinators
|
||||
combinators.short-circuit fonts locals strings ;
|
||||
IN: ui.gadgets.tables
|
||||
|
||||
! Row rendererer protocol
|
||||
|
|
@ -246,9 +246,6 @@ PRIVATE>
|
|||
: update-selected-value ( table -- )
|
||||
[ selected-row drop ] [ selected-value>> ] bi set-model ;
|
||||
|
||||
: initial-selected-index ( model table -- n/f )
|
||||
[ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ;
|
||||
|
||||
: show-row-summary ( table n -- )
|
||||
over nth-row
|
||||
[ swap [ renderer>> row-value ] keep show-summary ]
|
||||
|
|
@ -258,8 +255,28 @@ PRIVATE>
|
|||
: hide-mouse-help ( table -- )
|
||||
f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
|
||||
|
||||
: find-row-index ( value table -- n/f )
|
||||
[ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ;
|
||||
|
||||
: initial-selected-index ( table -- n/f )
|
||||
{
|
||||
[ model>> value>> empty? not ]
|
||||
[ selection-required?>> ]
|
||||
[ drop 0 ]
|
||||
} 1&& ;
|
||||
|
||||
: (update-selected-index) ( table -- n/f )
|
||||
[ selected-value>> value>> ] keep over
|
||||
[ find-row-index ] [ 2drop f ] if ;
|
||||
|
||||
: update-selected-index ( table -- n/f )
|
||||
{
|
||||
[ (update-selected-index) ]
|
||||
[ initial-selected-index ]
|
||||
} 1|| ;
|
||||
|
||||
M: table model-changed
|
||||
[ nip ] [ initial-selected-index ] 2bi {
|
||||
nip dup update-selected-index {
|
||||
[ >>selected-index f >>mouse-index drop ]
|
||||
[ show-row-summary ]
|
||||
[ drop update-selected-value ]
|
||||
|
|
@ -302,6 +319,8 @@ PRIVATE>
|
|||
: table-button-up ( table -- )
|
||||
dup row-action? [ row-action ] [ update-selected-value ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: select-row ( table n -- )
|
||||
over validate-line
|
||||
[ (select-row) ]
|
||||
|
|
@ -309,6 +328,8 @@ PRIVATE>
|
|||
[ show-row-summary ]
|
||||
2tri ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: prev/next-row ( table n -- )
|
||||
[ dup selected-index>> ] dip '[ _ + ] [ 0 ] if* select-row ;
|
||||
|
||||
|
|
@ -354,9 +375,9 @@ PRIVATE>
|
|||
show-operations-menu
|
||||
] [ drop ] if-mouse-row ;
|
||||
|
||||
: focus-table ( table -- ) t >>focused? drop ;
|
||||
: focus-table ( table -- ) t >>focused? relayout-1 ;
|
||||
|
||||
: unfocus-table ( table -- ) f >>focused? drop ;
|
||||
: unfocus-table ( table -- ) f >>focused? relayout-1 ;
|
||||
|
||||
table "sundry" f {
|
||||
{ mouse-enter show-mouse-help }
|
||||
|
|
|
|||
|
|
@ -8,13 +8,12 @@ $nl
|
|||
{ $heading "Message icons" }
|
||||
{ $table
|
||||
{ "Icon" "Message type" "Reference" }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } "Compiler warning" { $link "compiler-errors" } }
|
||||
! { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } }
|
||||
! { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } }
|
||||
{ { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } }
|
||||
} ;
|
||||
|
||||
ABOUT: "ui.tools.error-list"
|
||||
|
|
|
|||
|
|
@ -4,14 +4,14 @@ USING: accessors arrays sequences sorting assocs colors.constants fry
|
|||
combinators combinators.smart combinators.short-circuit editors make
|
||||
memoize compiler.units fonts kernel io.pathnames prettyprint
|
||||
source-files.errors math.parser init math.order models models.arrow
|
||||
models.arrow.smart models.search models.mapping models.delay debugger
|
||||
models.arrow.smart models.search models.mapping debugger
|
||||
namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes
|
||||
ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures
|
||||
ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers
|
||||
ui.tools.inspector ui.gadgets.status-bar ui.operations
|
||||
ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs
|
||||
ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener
|
||||
compiler.errors calendar tools.errors ;
|
||||
compiler.errors tools.errors tools.errors.model ;
|
||||
IN: ui.tools.error-list
|
||||
|
||||
CONSTANT: source-file-icon
|
||||
|
|
@ -180,23 +180,9 @@ error-list-gadget "toolbar" f {
|
|||
{ T{ key-down f f "F1" } error-list-help }
|
||||
} define-command-map
|
||||
|
||||
SYMBOL: error-list-model
|
||||
|
||||
error-list-model [ f <model> ] initialize
|
||||
|
||||
SINGLETON: updater
|
||||
|
||||
M: updater errors-changed
|
||||
drop f error-list-model get-global set-model ;
|
||||
|
||||
[ updater add-error-observer ] "ui.tools.error-list" add-init-hook
|
||||
|
||||
: <error-list-model> ( -- model )
|
||||
error-list-model get-global
|
||||
1/2 seconds <delay> [ drop all-errors ] <arrow> ;
|
||||
|
||||
: error-list-window ( -- )
|
||||
<error-list-model> <error-list-gadget> "Errors" open-status-window ;
|
||||
error-list-model get [ drop all-errors ] <arrow>
|
||||
<error-list-gadget> "Errors" open-status-window ;
|
||||
|
||||
: show-error-list ( -- )
|
||||
[ error-list-gadget? ] find-window
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -13,7 +13,7 @@ ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
|
|||
ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
|
||||
ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
|
||||
ui.tools.listener.completion ui.tools.listener.popups
|
||||
ui.tools.listener.history ui.tools.error-list ui.images ;
|
||||
ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ;
|
||||
FROM: source-files.errors => all-errors ;
|
||||
IN: ui.tools.listener
|
||||
|
||||
|
|
@ -187,8 +187,18 @@ TUPLE: listener-gadget < tool error-summary output scroller input ;
|
|||
[ >>input ] [ pane new-pane t >>scrolls? >>output ] bi
|
||||
dup listener-streams >>output drop ;
|
||||
|
||||
: error-summary. ( -- )
|
||||
error-counts keys [
|
||||
H{ { table-gap { 3 3 } } } [
|
||||
[ [ [ icon>> write-image ] with-cell ] each ] with-row
|
||||
] tabular-output
|
||||
{ "Press " { $command tool "common" show-error-list } " to view errors." }
|
||||
print-element
|
||||
] unless-empty ;
|
||||
|
||||
: <error-summary> ( -- gadget )
|
||||
<pane> COLOR: light-yellow <solid> >>interior ;
|
||||
error-list-model get [ drop error-summary. ] <pane-control>
|
||||
COLOR: light-yellow <solid> >>interior ;
|
||||
|
||||
: init-error-summary ( listener -- listener )
|
||||
<error-summary> >>error-summary
|
||||
|
|
@ -366,22 +376,11 @@ interactor "completion" f {
|
|||
{ T{ key-down f { C+ } "r" } history-completion-popup }
|
||||
} define-command-map
|
||||
|
||||
: error-summary. ( listener -- )
|
||||
error-summary>> [
|
||||
error-counts keys [
|
||||
H{ { table-gap { 3 3 } } } [
|
||||
[ [ [ icon>> write-image ] with-cell ] each ] with-row
|
||||
] tabular-output
|
||||
{ "Press " { $command tool "common" show-error-list } " to view errors." }
|
||||
print-element
|
||||
] unless-empty
|
||||
] with-pane ;
|
||||
|
||||
: listener-thread ( listener -- )
|
||||
dup listener-streams [
|
||||
[ com-browse ] help-hook set
|
||||
[ '[ [ _ input>> ] 2dip debugger-popup ] error-hook set ]
|
||||
[ '[ _ error-summary. ] error-summary-hook set ] bi
|
||||
'[ [ _ input>> ] 2dip debugger-popup ] error-hook set
|
||||
error-summary? off
|
||||
tip-of-the-day. nl
|
||||
listener
|
||||
] with-streams* ;
|
||||
|
|
|
|||
|
|
@ -361,8 +361,7 @@ HELP: inc-at
|
|||
|
||||
HELP: >alist
|
||||
{ $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } }
|
||||
{ $contract "Converts an associative structure into an association list." }
|
||||
{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which constructs the association list by iterating over the assoc with " { $link assoc-find } "." } ;
|
||||
{ $contract "Converts an associative structure into an association list." } ;
|
||||
|
||||
HELP: assoc-clone-like
|
||||
{ $values
|
||||
|
|
|
|||
|
|
@ -198,6 +198,8 @@ ARTICLE: "booleans" "Booleans"
|
|||
"In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value."
|
||||
{ $subsection f }
|
||||
{ $subsection t }
|
||||
"A union class of the above:"
|
||||
{ $subsection boolean }
|
||||
"There are some logical operations on booleans:"
|
||||
{ $subsection >boolean }
|
||||
{ $subsection not }
|
||||
|
|
|
|||
|
|
@ -144,8 +144,8 @@ GENERIC: definitions-changed ( assoc obj -- )
|
|||
update-tuples
|
||||
process-forgotten-definitions
|
||||
modify-code-heap
|
||||
updated-definitions dup assoc-empty? [ drop ] [ notify-definition-observers ] if
|
||||
notify-error-observers ;
|
||||
updated-definitions dup assoc-empty?
|
||||
[ drop ] [ notify-definition-observers notify-error-observers ] if ;
|
||||
|
||||
: with-nested-compilation-unit ( quot -- )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -129,6 +129,9 @@ HELP: ?
|
|||
{ $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } }
|
||||
{ $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ;
|
||||
|
||||
HELP: boolean
|
||||
{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ;
|
||||
|
||||
HELP: >boolean
|
||||
{ $values { "obj" "a generalized boolean" } { "?" "a boolean" } }
|
||||
{ $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ;
|
||||
|
|
|
|||
|
|
@ -176,12 +176,14 @@ PRIVATE>
|
|||
: tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline
|
||||
|
||||
! Booleans
|
||||
UNION: boolean POSTPONE: t POSTPONE: f ;
|
||||
|
||||
: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
|
||||
|
||||
: not ( obj -- ? ) [ f ] [ t ] if ; inline
|
||||
|
||||
: and ( obj1 obj2 -- ? ) over ? ; inline
|
||||
|
||||
: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
|
||||
|
||||
: or ( obj1 obj2 -- ? ) dupd ? ; inline
|
||||
|
||||
: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
|
||||
|
|
|
|||
|
|
@ -110,7 +110,7 @@ HELP: save-location
|
|||
{ $description "Saves the location of a definition and associates this definition with the current source file." } ;
|
||||
|
||||
HELP: parser-notes
|
||||
{ $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
|
||||
{ $var-description "A boolean controlling whether the parser will print various notes. Switched on by default. If a source file is being run for its effect on " { $link output-stream } ", this variable should be switched off, to prevent parser notes from polluting the output." } ;
|
||||
|
||||
HELP: parser-notes?
|
||||
{ $values { "?" "a boolean" } }
|
||||
|
|
@ -260,7 +260,7 @@ HELP: forget-smudged
|
|||
|
||||
HELP: finish-parsing
|
||||
{ $values { "lines" "the lines of text just parsed" } { "quot" "the quotation just parsed" } }
|
||||
{ $description "Records information to the current " { $link file } " and prints warnings about any removed definitions which are still in use." }
|
||||
{ $description "Records information to the current " { $link file } "." }
|
||||
{ $notes "This is one of the factors of " { $link parse-stream } "." } ;
|
||||
|
||||
HELP: parse-stream
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math sequences kernel ;
|
||||
IN: benchmark.gc1
|
||||
|
||||
: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ;
|
||||
|
||||
MAIN: gc1
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.encodings.utf8 io.files kernel peg.javascript ;
|
||||
IN: benchmark.javascript
|
||||
|
||||
: javascript-parser-benchmark ( -- )
|
||||
"vocab:benchmark/javascript/jquery-1.3.2.min.js"
|
||||
utf8 file-contents parse-javascript drop ;
|
||||
|
||||
MAIN: javascript-parser-benchmark
|
||||
File diff suppressed because one or more lines are too long
|
|
@ -0,0 +1 @@
|
|||
Aaron Schaefer
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
|
||||
! The contents of this file are licensed under the Simplified BSD License
|
||||
! A copy of the license is available at http://factorcode.org/license.txt
|
||||
USING: arrays formatting fry grouping io kernel locals math math.functions
|
||||
math.matrices math.parser math.primes.factors math.vectors prettyprint
|
||||
sequences sequences.deep sets ;
|
||||
IN: benchmark.pidigits
|
||||
|
||||
: extract ( z x -- n )
|
||||
1 2array '[ _ v* sum ] map first2 /i ;
|
||||
|
||||
: next ( z -- n )
|
||||
3 extract ;
|
||||
|
||||
: safe? ( z n -- ? )
|
||||
[ 4 extract ] dip = ;
|
||||
|
||||
: >matrix ( q s r t -- z )
|
||||
4array 2 group ;
|
||||
|
||||
: produce ( z n -- z' )
|
||||
[ 10 ] dip -10 * 0 1 >matrix swap m. ;
|
||||
|
||||
: gen-x ( x -- matrix )
|
||||
dup 2 * 1 + [ 2 * 0 ] keep >matrix ;
|
||||
|
||||
: consume ( z k -- z' )
|
||||
gen-x m. ;
|
||||
|
||||
:: (padded-total) ( row col -- str n format )
|
||||
"" row col + "%" "s\t:%d\n"
|
||||
10 col - number>string glue ;
|
||||
|
||||
: padded-total ( row col -- )
|
||||
(padded-total) '[ _ printf ] call( str n -- ) ;
|
||||
|
||||
:: (pidigits) ( k z n row col -- )
|
||||
n 0 > [
|
||||
z next :> y
|
||||
z y safe? [
|
||||
col 10 = [
|
||||
row 10 + y "\t:%d\n%d" printf
|
||||
k z y produce n 1 - row 10 + 1 (pidigits)
|
||||
] [
|
||||
y number>string write
|
||||
k z y produce n 1 - row col 1 + (pidigits)
|
||||
] if
|
||||
] [
|
||||
k 1 + z k consume n row col (pidigits)
|
||||
] if
|
||||
] [ row col padded-total ] if ;
|
||||
|
||||
: pidigits ( n -- )
|
||||
[ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
|
||||
|
||||
: pidigits-main ( -- )
|
||||
10000 pidigits ;
|
||||
|
||||
MAIN: pidigits-main
|
||||
|
|
@ -93,7 +93,7 @@ IN: mason.report
|
|||
load-everything-errors-file
|
||||
error-dump
|
||||
|
||||
"Compiler warnings and errors"
|
||||
"Compiler errors"
|
||||
compiler-errors-file
|
||||
compiler-error-messages-file
|
||||
error-dump
|
||||
|
|
|
|||
|
|
@ -117,9 +117,6 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
|||
: lookup ( cards table -- value )
|
||||
[ rank-bits ] dip nth ;
|
||||
|
||||
: unique5? ( cards -- ? )
|
||||
unique5-table lookup 0 > ;
|
||||
|
||||
: map-product ( seq quot -- n )
|
||||
[ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline
|
||||
|
||||
|
|
@ -138,11 +135,11 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
|
|||
bitxor values-table nth ;
|
||||
|
||||
: hand-value ( cards -- value )
|
||||
{
|
||||
{ [ dup flush? ] [ flushes-table lookup ] }
|
||||
{ [ dup unique5? ] [ unique5-table lookup ] }
|
||||
[ prime-bits perfect-hash-find ]
|
||||
} cond ;
|
||||
dup flush? [ flushes-table lookup ] [
|
||||
dup unique5-table lookup dup 0 > [ nip ] [
|
||||
drop prime-bits perfect-hash-find
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: >card-rank ( card -- str )
|
||||
-8 shift HEX: F bitand RANK_STR nth ;
|
||||
|
|
|
|||
|
|
@ -5,3 +5,4 @@ IN: project-euler.001.tests
|
|||
[ 233168 ] [ euler001a ] unit-test
|
||||
[ 233168 ] [ euler001b ] unit-test
|
||||
[ 233168 ] [ euler001c ] unit-test
|
||||
[ 233168 ] [ euler001d ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions math.ranges sequences project-euler.common ;
|
||||
USING: kernel math math.functions math.ranges project-euler.common sequences
|
||||
sets ;
|
||||
IN: project-euler.001
|
||||
|
||||
! http://projecteuler.net/index.php?section=problems&id=1
|
||||
|
|
@ -32,7 +33,7 @@ PRIVATE>
|
|||
999 15 sum-divisible-by - ;
|
||||
|
||||
! [ euler001 ] 100 ave-time
|
||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
||||
! 0 ms ave run time - 0.0 SD (100 trials)
|
||||
|
||||
|
||||
! ALTERNATE SOLUTIONS
|
||||
|
|
@ -42,14 +43,14 @@ PRIVATE>
|
|||
0 999 3 <range> sum 0 999 5 <range> sum + 0 999 15 <range> sum - ;
|
||||
|
||||
! [ euler001a ] 100 ave-time
|
||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
||||
! 0 ms ave run time - 0.03 SD (100 trials)
|
||||
|
||||
|
||||
: euler001b ( -- answer )
|
||||
1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
|
||||
|
||||
! [ euler001b ] 100 ave-time
|
||||
! 0 ms run / 0 ms GC ave time - 100 trials
|
||||
! 0 ms ave run time - 0.06 SD (100 trials)
|
||||
|
||||
|
||||
: euler001c ( -- answer )
|
||||
|
|
@ -58,4 +59,11 @@ PRIVATE>
|
|||
! [ euler001c ] 100 ave-time
|
||||
! 0 ms ave run time - 0.06 SD (100 trials)
|
||||
|
||||
|
||||
: euler001d ( -- answer )
|
||||
{ 3 5 } [ [ 999 ] keep <range> ] gather sum ;
|
||||
|
||||
! [ euler001d ] 100 ave-time
|
||||
! 0 ms ave run time - 0.08 SD (100 trials)
|
||||
|
||||
SOLUTION: euler001
|
||||
|
|
|
|||
|
|
@ -69,12 +69,9 @@ PRIVATE>
|
|||
[ nth-prime primes-upto ]
|
||||
} cond product ;
|
||||
|
||||
: (primorial-upto) ( count limit -- m )
|
||||
'[ dup primorial _ <= ] [ 1+ dup primorial ] produce
|
||||
nip penultimate ;
|
||||
|
||||
: primorial-upto ( limit -- m )
|
||||
1 swap (primorial-upto) ;
|
||||
1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce
|
||||
nip penultimate ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
|||
14
vm/data_gc.c
14
vm/data_gc.c
|
|
@ -115,9 +115,13 @@ void copy_gen_cards(CELL gen)
|
|||
old->new references */
|
||||
void copy_cards(void)
|
||||
{
|
||||
u64 start = current_micros();
|
||||
|
||||
int i;
|
||||
for(i = collecting_gen + 1; i < data_heap->gen_count; i++)
|
||||
copy_gen_cards(i);
|
||||
|
||||
card_scan_time += (current_micros() - start);
|
||||
}
|
||||
|
||||
/* Copy all tagged pointers in a range of memory */
|
||||
|
|
@ -435,7 +439,7 @@ void garbage_collection(CELL gen,
|
|||
return;
|
||||
}
|
||||
|
||||
s64 start = current_micros();
|
||||
u64 start = current_micros();
|
||||
|
||||
performing_gc = true;
|
||||
growing_data_heap = growing_data_heap_;
|
||||
|
|
@ -539,9 +543,10 @@ void primitive_gc_stats(void)
|
|||
total_gc_time += s->gc_time;
|
||||
}
|
||||
|
||||
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(total_gc_time)));
|
||||
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned)));
|
||||
GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned)));
|
||||
GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(total_gc_time)));
|
||||
GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(cards_scanned)));
|
||||
GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(decks_scanned)));
|
||||
GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(card_scan_time)));
|
||||
GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans));
|
||||
|
||||
GROWABLE_ARRAY_TRIM(stats);
|
||||
|
|
@ -556,6 +561,7 @@ void clear_gc_stats(void)
|
|||
|
||||
cards_scanned = 0;
|
||||
decks_scanned = 0;
|
||||
card_scan_time = 0;
|
||||
code_heap_scans = 0;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ typedef struct {
|
|||
F_GC_STATS gc_stats[MAX_GEN_COUNT];
|
||||
u64 cards_scanned;
|
||||
u64 decks_scanned;
|
||||
u64 card_scan_time;
|
||||
CELL code_heap_scans;
|
||||
|
||||
/* What generation was being collected when copy_code_heap_roots() was last
|
||||
|
|
|
|||
Loading…
Reference in New Issue