From 1559b7464000d16aa20b398adc1bd9b08ffa416d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 06:16:51 -0500 Subject: [PATCH 01/23] Add new check-datastack primitive and re-implement call( with it, instead of using with-datastack. call( is now 5x faster --- basis/call/call-tests.factor | 2 +- basis/call/call.factor | 42 ++++++++++++------- .../known-words/known-words.factor | 23 ++++++---- core/bootstrap/primitives.factor | 1 + core/effects/effects.factor | 3 ++ vm/callstack.h | 2 - vm/primitives.c | 1 + vm/run.c | 26 ++++++++++++ vm/run.h | 3 ++ 9 files changed, 79 insertions(+), 24 deletions(-) diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor index 4e45c3cf8f..bc6f9a5d4c 100644 --- a/basis/call/call-tests.factor +++ b/basis/call/call-tests.factor @@ -6,7 +6,7 @@ IN: call.tests [ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test [ 1 2 [ + ] call( -- z ) ] must-fail [ 1 2 [ + ] call( x y -- z a ) ] must-fail -[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test +[ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test [ [ + ] call( x y -- z ) ] must-infer [ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test diff --git a/basis/call/call.factor b/basis/call/call.factor index 0c1b5bbfbf..e4803c36f9 100644 --- a/basis/call/call.factor +++ b/basis/call/call.factor @@ -1,28 +1,39 @@ ! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel macros fry summary sequences sequences.private -generalizations accessors continuations effects effects.parser -parser words ; +USING: kernel kernel.private macros fry summary sequences +sequences.private accessors effects effects.parser parser words +make ; IN: call -ERROR: wrong-values values quot length-required ; +ERROR: wrong-values effect ; -M: wrong-values summary - drop "Wrong number of values returned from quotation" ; +M: wrong-values summary drop "Quotation called with stack effect" ; +: (call-effect>quot) ( in out effect -- quot ) + [ + [ [ datastack ] dip dip ] % + [ [ , ] bi@ \ check-datastack , ] dip [ wrong-values ] curry , \ unless , + ] [ ] make ; + +: call-effect>quot ( effect -- quot ) + [ in>> length ] [ out>> length ] [ ] tri + [ (call-effect>quot) ] keep add-effect-input + [ call-effect-unsafe ] 2curry ; + MACRO: call-effect ( effect -- quot ) - [ in>> length ] [ out>> length ] bi - '[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ; + call-effect>quot ; : call( \ call-effect parse-call( ; parsing @@ -44,17 +55,20 @@ MACRO: call-effect ( effect -- quot ) over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline : cache-miss ( word effect ic -- ) - [ 2dup execute-effect-unsafe? ] dip - '[ [ drop _ set-first ] [ execute-effect-unsafe ] 2bi ] + 2over execute-effect-unsafe? + [ [ nip set-first ] [ drop execute-effect-unsafe ] 3bi ] [ execute-effect-slow ] if ; inline : execute-effect-ic ( word effect ic -- ) #! ic is a mutable cell { effect } 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline +: execute-effect>quot ( effect -- quot ) + { f } clone [ execute-effect-ic ] 2curry ; + PRIVATE> MACRO: execute-effect ( effect -- ) - { f } clone '[ _ _ execute-effect-ic ] ; + execute-effect>quot ; : execute( \ execute-effect parse-call( ; parsing diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index e366073326..392cea62d6 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -140,13 +140,17 @@ M: object infer-call* peek-d literal value>> 2 + { "*" } apply-word/effect ; -: infer-execute-effect-unsafe ( -- ) - \ execute +: infer-effect-unsafe ( word -- ) pop-literal nip - [ in>> "word" suffix ] [ out>> ] [ terminated?>> ] tri - effect boa + add-effect-input apply-word/effect ; +: infer-execute-effect-unsafe ( -- ) + \ execute infer-effect-unsafe ; + +: infer-call-effect-unsafe ( -- ) + \ call infer-effect-unsafe ; + : infer-exit ( -- ) \ exit (( n -- * )) apply-word/effect ; @@ -186,6 +190,7 @@ M: object infer-call* { \ execute [ infer-execute ] } { \ (execute) [ infer-execute ] } { \ execute-effect-unsafe [ infer-execute-effect-unsafe ] } + { \ call-effect-unsafe [ infer-call-effect-unsafe ] } { \ if [ infer-if ] } { \ dispatch [ infer-dispatch ] } { \ [ infer- ] } @@ -212,9 +217,10 @@ M: object infer-call* { declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose - execute (execute) execute-effect-unsafe if dispatch - (throw) exit load-local load-locals get-local drop-locals - do-primitive alien-invoke alien-indirect alien-callback + execute (execute) call-effect-unsafe execute-effect-unsafe if + dispatch (throw) exit load-local load-locals get-local + drop-locals do-primitive alien-invoke alien-indirect + alien-callback } [ t "special" set-word-prop ] each { call execute dispatch load-locals get-local drop-locals } @@ -627,6 +633,9 @@ M: object infer-call* \ datastack { } { array } define-primitive \ datastack make-flushable +\ check-datastack { array integer integer } { object } define-primitive +\ check-datastack make-flushable + \ retainstack { } { array } define-primitive \ retainstack make-flushable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 083059cec5..f04a42f493 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -533,6 +533,7 @@ tuple { "gc-reset" "memory" } { "jit-compile" "quotations" } { "load-locals" "locals.backend" } + { "check-datastack" "kernel.private" } } [ [ first2 ] dip make-primitive ] each-index diff --git a/core/effects/effects.factor b/core/effects/effects.factor index d21132aebb..142b9120a8 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -63,3 +63,6 @@ M: effect clone : shuffle ( stack shuffle -- newstack ) shuffle-mapping swap nths ; + +: add-effect-input ( effect -- effect' ) + [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ; diff --git a/vm/callstack.h b/vm/callstack.h index 68937980f6..3c13e7b1cd 100755 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -14,8 +14,6 @@ CELL frame_scan(F_STACK_FRAME *frame); CELL frame_type(F_STACK_FRAME *frame); void primitive_callstack(void); -void primitive_set_datastack(void); -void primitive_set_retainstack(void); void primitive_set_callstack(void); void primitive_callstack_to_array(void); void primitive_innermost_stack_frame_quot(void); diff --git a/vm/primitives.c b/vm/primitives.c index 2bce9eedb7..82b0555894 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -144,4 +144,5 @@ void *primitives[] = { primitive_clear_gc_stats, primitive_jit_compile, primitive_load_locals, + primitive_check_datastack }; diff --git a/vm/run.c b/vm/run.c index c7002eb0ec..e55eb904a7 100755 --- a/vm/run.c +++ b/vm/run.c @@ -155,6 +155,32 @@ void primitive_set_retainstack(void) rs = array_to_stack(untag_array(dpop()),rs_bot); } +/* Used to implement call( */ +void primitive_check_datastack(void) +{ + F_FIXNUM out = to_fixnum(dpop()); + F_FIXNUM in = to_fixnum(dpop()); + F_FIXNUM height = out - in; + F_ARRAY *array = untag_array(dpop()); + F_FIXNUM length = array_capacity(array); + F_FIXNUM depth = (ds - ds_bot + CELLS) / CELLS; + if(depth - height != length) + dpush(F); + else + { + F_FIXNUM i; + for(i = 0; i < length - in; i++) + { + if(get(ds_bot + i * CELLS) != array_nth(array,i)) + { + dpush(F); + return; + } + } + dpush(T); + } +} + void primitive_getenv(void) { F_FIXNUM e = untag_fixnum_fast(dpeek()); diff --git a/vm/run.h b/vm/run.h index 06b6317015..2acff2cd5a 100755 --- a/vm/run.h +++ b/vm/run.h @@ -236,6 +236,9 @@ void init_stacks(CELL ds_size, CELL rs_size); void primitive_datastack(void); void primitive_retainstack(void); +void primitive_set_datastack(void); +void primitive_set_retainstack(void); +void primitive_check_datastack(void); void primitive_getenv(void); void primitive_setenv(void); void primitive_exit(void); From 38c6be94d4cf4cf1c9a73b48dee159d2dfdedc94 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 06:17:18 -0500 Subject: [PATCH 02/23] Fixing some stack comments --- basis/compiler/codegen/codegen.factor | 4 ++-- basis/io/pipes/pipes.factor | 9 +++++---- core/classes/tuple/parser/parser.factor | 8 ++++---- core/generic/parser/parser.factor | 2 +- core/parser/parser.factor | 2 +- 5 files changed, 13 insertions(+), 12 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index d915b29ae5..486675ec26 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -3,7 +3,7 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs -alien.strings alien.arrays alien.complex sets libc +alien.strings alien.arrays alien.complex sets libc call continuations.private fry cpu.architecture compiler.errors compiler.alien @@ -464,7 +464,7 @@ TUPLE: callback-context ; dup current-callback eq? [ drop ] [ - yield-hook get call wait-to-return + yield-hook get call( -- ) wait-to-return ] if ; : do-callback ( quot token -- ) diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index 9cadb3f6cc..ad59cbc632 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings io.backend io.ports io.streams.duplex io splitting grouping sequences namespaces kernel -destructors math concurrency.combinators accessors +destructors math concurrency.combinators accessors call fry arrays continuations quotations system vocabs.loader combinators ; IN: io.pipes @@ -29,11 +29,12 @@ HOOK: (pipe) io-backend ( -- pipe ) : ?writer ( handle/f -- stream ) [ &dispose ] [ output-stream get ] if* ; -GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot ) +GENERIC: run-pipeline-element ( input-fd output-fd obj -- result ) M: callable run-pipeline-element [ - [ [ ?reader ] [ ?writer ] bi* ] dip with-streams* + [ [ ?reader ] [ ?writer ] bi* ] dip + '[ _ call( -- result ) ] with-streams* ] with-destructors ; : ( n -- pipes ) diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 659195edbf..5e12322a48 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -30,7 +30,7 @@ ERROR: duplicate-slot-names names ; ERROR: invalid-slot-name name ; -: parse-long-slot-name ( -- ) +: parse-long-slot-name ( -- spec ) [ scan , \ } parse-until % ] { } make ; : parse-slot-name ( string/f -- ? ) @@ -64,7 +64,7 @@ ERROR: bad-literal-tuple ; : parse-slot-value ( -- ) scan scan-object 2array , scan { - { f [ unexpected-eof ] } + { f [ \ } unexpected-eof ] } { "}" [ ] } [ bad-literal-tuple ] } case ; @@ -72,13 +72,13 @@ ERROR: bad-literal-tuple ; : (parse-slot-values) ( -- ) parse-slot-value scan { - { f [ unexpected-eof ] } + { f [ \ } unexpected-eof ] } { "{" [ (parse-slot-values) ] } { "}" [ ] } [ bad-literal-tuple ] } case ; -: parse-slot-values ( -- ) +: parse-slot-values ( -- values ) [ (parse-slot-values) ] { } make ; : boa>tuple ( class slots -- tuple ) diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor index 0852459c34..bf9cdb19f5 100644 --- a/core/generic/parser/parser.factor +++ b/core/generic/parser/parser.factor @@ -18,6 +18,6 @@ SYMBOL: current-method : with-method-definition ( method quot -- ) over current-method set call current-method off ; inline -: (M:) ( method def -- ) +: (M:) ( -- method def ) CREATE-METHOD [ parse-definition ] with-method-definition ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index c68d453b15..dddea09db9 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -214,7 +214,7 @@ print-use-hook [ [ ] ] initialize [ V{ } clone amended-use set parse-lines - amended-use get empty? [ print-use-hook get call ] unless + amended-use get empty? [ print-use-hook get assert-depth ] unless ] with-file-vocabs ; : parsing-file ( file -- ) From 0c77a3b3be9704be91603d27ecc19179c940383f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 06:27:01 -0500 Subject: [PATCH 03/23] compiler: use call( instead of assert-depth --- basis/compiler/compiler.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 349d50fe35..f9627752e7 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io stack-checker +combinators deques search-deques macros io stack-checker call 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 @@ -111,7 +111,7 @@ t compile-dependencies? set-global ] with-return ; : compile-loop ( deque -- ) - [ (compile) yield-hook get assert-depth ] slurp-deque ; + [ (compile) yield-hook get call( -- ) ] slurp-deque ; : decompile ( word -- ) f 2array 1array modify-code-heap ; From 3a611f41c7ec70d71955456b6a5f744aac53117e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 06:27:19 -0500 Subject: [PATCH 04/23] ui.gadgets.editors: remove unnecessary workaround, make another word infer --- basis/ui/gadgets/editors/editors.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 9adb33a164..4398b0ce70 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -8,7 +8,7 @@ continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment -math.rectangles splitting unicode.categories fonts grouping ; +math.rectangles splitting unicode.categories fonts grouping call ; IN: ui.gadgets.editors TUPLE: editor < line-gadget @@ -413,8 +413,7 @@ editor "caret-motion" f { } define-command-map : clear-editor ( editor -- ) - #! The with-datastack is a kludge to make it infer. Stupid. - model>> 1array [ clear-doc ] with-datastack drop ; + model>> clear-doc ; : select-all ( editor -- ) doc-elt select-elt ; @@ -619,7 +618,7 @@ TUPLE: action-field < field quot ; [ editor>> editor-string ] [ editor>> clear-editor ] [ quot>> ] - tri call ; + tri call( string -- ) ; action-field H{ { T{ key-down f f "RET" } [ invoke-action-field ] } From be4fb1e7d9fdf9c44b24075180c50af7c6d155bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 20:11:36 -0500 Subject: [PATCH 05/23] Move call( and execute( to core --- basis/alien/c-types/c-types.factor | 2 +- basis/bootstrap/image/image.factor | 2 + basis/call/authors.txt | 2 - basis/call/call-docs.factor | 47 ------------ basis/call/call-tests.factor | 33 --------- basis/call/call.factor | 74 ------------------- basis/call/summary.txt | 1 - basis/call/tags.txt | 1 - basis/cocoa/messages/messages.factor | 2 +- basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/compiler.factor | 2 +- basis/compiler/constants/constants.factor | 2 +- .../tree/propagation/inlining/inlining.factor | 4 +- basis/debugger/debugger.factor | 2 + basis/eval/eval.factor | 2 +- basis/furnace/actions/actions.factor | 2 +- basis/furnace/boilerplate/boilerplate.factor | 2 +- basis/furnace/referrer/referrer.factor | 2 +- basis/help/help.factor | 2 +- basis/help/lint/lint.factor | 2 +- basis/help/markup/markup.factor | 2 +- basis/html/forms/forms.factor | 2 +- basis/html/templates/chloe/chloe.factor | 2 +- .../templates/chloe/compiler/compiler.factor | 2 +- basis/html/templates/fhtml/fhtml.factor | 4 +- basis/html/templates/templates.factor | 2 +- basis/http/server/static/static.factor | 2 +- basis/inverse/inverse.factor | 2 +- basis/io/pipes/pipes.factor | 2 +- basis/io/servers/connection/connection.factor | 2 +- basis/listener/listener.factor | 2 +- basis/lists/lazy/lazy.factor | 2 +- basis/models/arrow/arrow.factor | 2 +- basis/peg/ebnf/ebnf.factor | 2 +- basis/peg/peg.factor | 2 +- basis/regexp/regexp.factor | 6 +- .../known-words/known-words.factor | 10 +-- basis/stack-checker/transforms/authors.txt | 1 + .../transforms/transforms-tests.factor | 7 +- .../transforms/transforms.factor | 64 +++++++++++++--- basis/threads/threads.factor | 8 +- basis/tools/deploy/deploy-docs.factor | 2 +- basis/tools/deploy/test/12/12.factor | 6 +- basis/tools/walker/walker.factor | 1 - basis/ui/backend/cocoa/cocoa.factor | 2 +- basis/ui/commands/commands.factor | 3 +- basis/ui/gadgets/buttons/buttons.factor | 2 +- basis/ui/gadgets/editors/editors.factor | 2 +- basis/ui/gadgets/panes/panes.factor | 2 +- basis/ui/gadgets/worlds/worlds.factor | 8 +- basis/ui/gestures/gestures.factor | 2 +- basis/ui/operations/operations.factor | 2 +- basis/ui/ui.factor | 2 +- basis/wrap/wrap.factor | 2 +- basis/xmode/loader/syntax/syntax.factor | 2 +- core/bootstrap/primitives.factor | 3 +- core/bootstrap/syntax.factor | 2 + core/combinators/authors.txt | 1 + core/combinators/combinators-docs.factor | 32 +++++++- core/combinators/combinators-tests.factor | 24 ++++++ core/combinators/combinators.factor | 26 ++++++- core/continuations/continuations-docs.factor | 5 -- core/continuations/continuations.factor | 32 ++++---- core/effects/parser/parser.factor | 5 +- core/kernel/kernel.factor | 4 +- core/parser/parser-tests.factor | 4 +- core/parser/parser.factor | 21 +++--- core/strings/parser/parser.factor | 12 +-- core/syntax/syntax-docs.factor | 10 +++ core/syntax/syntax.factor | 6 +- core/vocabs/loader/loader.factor | 2 +- core/vocabs/vocabs.factor | 2 +- core/words/words.factor | 4 +- extra/4DNav/4DNav.factor | 1 - extra/monads/monads-tests.factor | 2 +- extra/monads/monads.factor | 22 +++--- extra/promises/promises.factor | 2 +- extra/ui/gadgets/lists/lists.factor | 2 +- vm/cpu-x86.32.S | 2 +- vm/cpu-x86.64.S | 2 +- vm/errors.c | 6 -- vm/errors.h | 1 - vm/layouts.h | 4 + vm/primitives.c | 1 - vm/quotations.c | 2 + 85 files changed, 286 insertions(+), 310 deletions(-) delete mode 100644 basis/call/authors.txt delete mode 100644 basis/call/call-docs.factor delete mode 100644 basis/call/call-tests.factor delete mode 100644 basis/call/call.factor delete mode 100644 basis/call/summary.txt delete mode 100644 basis/call/tags.txt diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index c3fd41e689..dc35f8bbb0 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations fry call classes ; +accessors combinators effects continuations fry classes ; IN: alien.c-types DEFER: diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index aeedef39bd..a2621f4c32 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -446,6 +446,8 @@ M: quotation ' quotation type-number object tag-number [ emit ! array f ' emit ! compiled + f ' emit ! cached-effect + f ' emit ! cache-counter 0 emit ! xt 0 emit ! code ] emit-object diff --git a/basis/call/authors.txt b/basis/call/authors.txt deleted file mode 100644 index 33616a2d6a..0000000000 --- a/basis/call/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Daniel Ehrenberg -Slava Pestov diff --git a/basis/call/call-docs.factor b/basis/call/call-docs.factor deleted file mode 100644 index 5f76f53fac..0000000000 --- a/basis/call/call-docs.factor +++ /dev/null @@ -1,47 +0,0 @@ -! Copyright (C) 2009 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax quotations effects words call.private ; -IN: call - -ABOUT: "call" - -ARTICLE: "call" "Calling code with known stack effects" -"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." -$nl -"Quotations:" -{ $subsection POSTPONE: call( } -{ $subsection call-effect } -"Words:" -{ $subsection POSTPONE: execute( } -{ $subsection execute-effect } -"Unsafe calls:" -{ $subsection POSTPONE: execute-unsafe( } -{ $subsection execute-effect-unsafe } ; - -HELP: call( -{ $syntax "call( stack -- effect )" } -{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; - -HELP: call-effect -{ $values { "quot" quotation } { "effect" effect } } -{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ; - -HELP: execute( -{ $syntax "execute( stack -- effect )" } -{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ; - -HELP: execute-effect -{ $values { "word" word } { "effect" effect } } -{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ; - -HELP: execute-unsafe( -{ $syntax "execute-unsafe( stack -- effect )" } -{ $description "Calls the word on the top of the stack, blindly declaring that it has the given stack effect. The word does not need to be known at compile time." } -{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ; -HELP: execute-effect-unsafe -{ $values { "word" word } { "effect" effect } } -{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } -{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link execute-effect-unsafe } " instead." } ; - -{ call-effect execute-effect execute-effect-unsafe } related-words -{ POSTPONE: call( POSTPONE: execute( POSTPONE: execute-unsafe( } related-words \ No newline at end of file diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor deleted file mode 100644 index bc6f9a5d4c..0000000000 --- a/basis/call/call-tests.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2009 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: math tools.test call call.private kernel accessors ; -IN: call.tests - -[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test -[ 1 2 [ + ] call( -- z ) ] must-fail -[ 1 2 [ + ] call( x y -- z a ) ] must-fail -[ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test -[ [ + ] call( x y -- z ) ] must-infer - -[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test -[ 1 2 \ + execute( -- z ) ] must-fail -[ 1 2 \ + execute( x y -- z a ) ] must-fail -[ \ + execute( x y -- z ) ] must-infer - -: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ; - -[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test -[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test - -: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ; - -[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test -[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test -[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test -[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test -[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test - -[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test -[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test -[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test -[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test diff --git a/basis/call/call.factor b/basis/call/call.factor deleted file mode 100644 index e4803c36f9..0000000000 --- a/basis/call/call.factor +++ /dev/null @@ -1,74 +0,0 @@ -! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private macros fry summary sequences -sequences.private accessors effects effects.parser parser words -make ; -IN: call - -ERROR: wrong-values effect ; - -M: wrong-values summary drop "Quotation called with stack effect" ; - - - -: (call-effect>quot) ( in out effect -- quot ) - [ - [ [ datastack ] dip dip ] % - [ [ , ] bi@ \ check-datastack , ] dip [ wrong-values ] curry , \ unless , - ] [ ] make ; - -: call-effect>quot ( effect -- quot ) - [ in>> length ] [ out>> length ] [ ] tri - [ (call-effect>quot) ] keep add-effect-input - [ call-effect-unsafe ] 2curry ; - -MACRO: call-effect ( effect -- quot ) - call-effect>quot ; - -: call( \ call-effect parse-call( ; parsing - -> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline - -: cache-miss ( word effect ic -- ) - 2over execute-effect-unsafe? - [ [ nip set-first ] [ drop execute-effect-unsafe ] 3bi ] - [ execute-effect-slow ] if ; inline - -: execute-effect-ic ( word effect ic -- ) - #! ic is a mutable cell { effect } - 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline - -: execute-effect>quot ( effect -- quot ) - { f } clone [ execute-effect-ic ] 2curry ; - -PRIVATE> - -MACRO: execute-effect ( effect -- ) - execute-effect>quot ; - -: execute( \ execute-effect parse-call( ; parsing diff --git a/basis/call/summary.txt b/basis/call/summary.txt deleted file mode 100644 index d449497971..0000000000 --- a/basis/call/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Calling arbitrary quotations and executing arbitrary words with a static stack effect diff --git a/basis/call/tags.txt b/basis/call/tags.txt deleted file mode 100644 index f4274299b1..0000000000 --- a/basis/call/tags.txt +++ /dev/null @@ -1 +0,0 @@ -extensions diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 8818c9a217..f71b9f3f56 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien stack-checker kernel math namespaces make parser quotations sequences strings words cocoa.runtime io macros memoize io.encodings.utf8 effects libc libc.private parser lexer init core-foundation fry generalizations -specialized-arrays.direct.alien call ; +specialized-arrays.direct.alien ; IN: cocoa.messages : make-sender ( method function -- quot ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 486675ec26..40b1f56f8b 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -3,7 +3,7 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs -alien.strings alien.arrays alien.complex sets libc call +alien.strings alien.arrays alien.complex sets libc continuations.private fry cpu.architecture compiler.errors compiler.alien diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index f9627752e7..c8e1e5fd0f 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io stack-checker call +combinators deques search-deques macros io 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 diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index e03c062e9e..f82b6d479f 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -20,7 +20,7 @@ CONSTANT: deck-bits 18 : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline : class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; inline : word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ; inline -: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; inline +: quot-xt-offset ( -- n ) 5 bootstrap-cells object tag-number - ; inline : word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 953956c3bd..f18cfcd3a3 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel arrays sequences math math.order call +USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 627fd95384..efd35ab280 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -325,3 +325,5 @@ M: bad-literal-tuple summary drop "Bad literal tuple" ; M: check-mixin-class summary drop "Not a mixin class" ; M: not-found-in-roots summary drop "Cannot resolve vocab: path" ; + +M: wrong-values summary drop "Quotation called with wrong stack effect" ; \ No newline at end of file diff --git a/basis/eval/eval.factor b/basis/eval/eval.factor index dfa9baf418..3672337a58 100644 --- a/basis/eval/eval.factor +++ b/basis/eval/eval.factor @@ -4,7 +4,7 @@ USING: splitting parser compiler.units kernel namespaces debugger io.streams.string fry ; IN: eval -: parse-string ( str -- ) +: parse-string ( str -- quot ) [ string-lines parse-lines ] with-compilation-unit ; : (eval) ( str -- ) diff --git a/basis/furnace/actions/actions.factor b/basis/furnace/actions/actions.factor index b0814db4dd..a582755dc4 100644 --- a/basis/furnace/actions/actions.factor +++ b/basis/furnace/actions/actions.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors sequences kernel assocs combinators validators http hashtables namespaces fry continuations locals -io arrays math boxes splitting urls call +io arrays math boxes splitting urls xml.entities http.server http.server.responses diff --git a/basis/furnace/boilerplate/boilerplate.factor b/basis/furnace/boilerplate/boilerplate.factor index 84b29bf831..b4bc574ae2 100644 --- a/basis/furnace/boilerplate/boilerplate.factor +++ b/basis/furnace/boilerplate/boilerplate.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math.order namespaces combinators.short-circuit call +USING: accessors kernel math.order namespaces combinators.short-circuit html.forms html.templates html.templates.chloe diff --git a/basis/furnace/referrer/referrer.factor b/basis/furnace/referrer/referrer.factor index acd4563cd6..0eb00bac27 100644 --- a/basis/furnace/referrer/referrer.factor +++ b/basis/furnace/referrer/referrer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel http.server http.server.filters -http.server.responses furnace.utilities call ; +http.server.responses furnace.utilities ; IN: furnace.referrer TUPLE: referrer-check < filter-responder quot ; diff --git a/basis/help/help.factor b/basis/help/help.factor index 27a81f9948..d8629008d2 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -5,7 +5,7 @@ parser prettyprint sequences words words.symbol assocs definitions generic quotations effects slots continuations classes.tuple debugger combinators vocabs help.stylesheet help.topics help.crossref help.markup sorting classes -vocabs.loader call ; +vocabs.loader ; IN: help GENERIC: word-help* ( word -- content ) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 2281c295c3..7942f90e0a 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate macros math sets eval vocabs.parser words.symbol values grouping unicode.categories -sequences.deep call ; +sequences.deep ; IN: help.lint SYMBOL: vocabs-quot diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index ea64def751..8ea36d62fb 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -4,7 +4,7 @@ USING: accessors arrays definitions generic io kernel assocs hashtables namespaces make parser prettyprint sequences strings io.styles vectors words math sorting splitting classes slots fry sets vocabs help.stylesheet help.topics vocabs.loader quotations -combinators call see ; +combinators see ; IN: help.markup PREDICATE: simple-element < array diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index 4cab87acfa..cc8b4f0a15 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors strings namespaces assocs hashtables io call +USING: kernel accessors strings namespaces assocs hashtables io mirrors math fry sequences words continuations xml.entities xml.writer xml.syntax ; IN: html.forms diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index da0d45a9d4..1fe90b08d3 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -4,7 +4,7 @@ USING: accessors kernel sequences combinators kernel fry namespaces make classes.tuple assocs splitting words arrays io io.files io.files.info io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml -logging call +logging xml.data xml.writer xml.syntax strings html.forms html diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 3cb7523bdc..92e4a8dc49 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs namespaces make kernel sequences accessors combinators strings splitting io io.streams.string present -xml.writer xml.data xml.entities html.forms call +xml.writer xml.data xml.entities html.forms html.templates html.templates.chloe.syntax ; IN: html.templates.chloe.compiler diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index 78202d6460..f3539f6a0f 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel namespaces debugger combinators math quotations generic strings splitting accessors -assocs fry vocabs.parser parser lexer io io.files call +assocs fry vocabs.parser parser lexer io io.files io.streams.string io.encodings.utf8 html.templates ; IN: html.templates.fhtml @@ -65,7 +65,7 @@ DEFER: <% delimiter ] with-file-vocabs ; : eval-template ( string -- ) - parse-template call ; + parse-template call( -- ) ; TUPLE: fhtml path ; diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index fcb1b28b1a..aebae701ed 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel fry io io.encodings.utf8 io.files debugger prettyprint continuations namespaces boxes sequences -arrays strings html io.streams.string assocs call +arrays strings html io.streams.string assocs quotations xml.data xml.writer xml.syntax ; IN: html.templates diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 13b9efc86d..bbca70d845 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -6,7 +6,7 @@ sorting logging calendar.format accessors splitting io io.files io.files.info io.directories io.pathnames io.encodings.binary fry xml.entities destructors urls html xml.syntax html.templates.fhtml http http.server http.server.responses -http.server.redirection xml.writer call ; +http.server.redirection xml.writer ; IN: http.server.static TUPLE: file-responder root hook special allow-listings ; diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 9dc79e91b5..3a86703caf 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations continuations debugger classes.tuple namespaces make vectors bit-arrays byte-arrays strings sbufs math.functions macros sequences.private combinators mirrors splitting -combinators.short-circuit fry words.symbol generalizations call ; +combinators.short-circuit fry words.symbol generalizations ; RENAME: _ fry => __ IN: inverse diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index ad59cbc632..c15663b031 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings io.backend io.ports io.streams.duplex io splitting grouping sequences namespaces kernel -destructors math concurrency.combinators accessors call fry +destructors math concurrency.combinators accessors fry arrays continuations quotations system vocabs.loader combinators ; IN: io.pipes diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 5a3233afa9..8eafe1b5bf 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -7,7 +7,7 @@ fry accessors arrays io io.sockets io.encodings.ascii io.sockets.secure io.files io.streams.duplex io.timeouts io.encodings threads make concurrency.combinators concurrency.semaphores concurrency.flags -combinators.short-circuit call ; +combinators.short-circuit ; IN: io.servers.connection TUPLE: threaded-server diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 78a9c03d20..4f7ccf227e 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -4,7 +4,7 @@ USING: arrays hashtables io kernel math math.parser memory namespaces parser lexer sequences strings io.styles vectors words generic system combinators continuations debugger definitions compiler.units accessors colors prettyprint fry -sets vocabs.parser call ; +sets vocabs.parser ; IN: listener GENERIC: stream-read-quot ( stream -- quot/f ) diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index d3b08a11fb..139f6726e8 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences math vectors arrays namespaces make -quotations promises combinators io lists accessors call ; +quotations promises combinators io lists accessors ; IN: lists.lazy M: promise car ( promise -- car ) diff --git a/basis/models/arrow/arrow.factor b/basis/models/arrow/arrow.factor index fcdfd166c5..e0cf73c7f1 100644 --- a/basis/models/arrow/arrow.factor +++ b/basis/models/arrow/arrow.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors models kernel call ; +USING: accessors models kernel ; IN: models.arrow TUPLE: arrow < model model quot ; diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor index db29ce1ee7..1f526d47f2 100644 --- a/basis/peg/ebnf/ebnf.factor +++ b/basis/peg/ebnf/ebnf.factor @@ -5,7 +5,7 @@ sequences quotations vectors namespaces make math assocs continuations peg peg.parsers unicode.categories multiline splitting accessors effects sequences.deep peg.search combinators.short-circuit lexer io.streams.string stack-checker -io combinators parser call ; +io combinators parser ; IN: peg.ebnf : rule ( name word -- parser ) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 01891a1da1..6c0772aacc 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -4,7 +4,7 @@ USING: kernel sequences strings fry namespaces make math assocs io vectors arrays math.parser math.order vectors combinators classes sets unicode.categories compiler.units parser words quotations effects memoize accessors locals effects splitting -combinators.short-circuit generalizations call ; +combinators.short-circuit generalizations ; IN: peg TUPLE: parse-result remaining ast ; diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 63a2f25885..5889b19e47 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -4,7 +4,7 @@ USING: accessors combinators kernel kernel.private math sequences sequences.private strings sets assocs prettyprint.backend prettyprint.custom make lexer namespaces parser arrays fry locals regexp.parser splitting sorting regexp.ast regexp.negation -regexp.compiler compiler.units words call call.private math.ranges ; +regexp.compiler compiler.units words math.ranges ; IN: regexp TUPLE: regexp @@ -35,7 +35,7 @@ M: lookbehind question>quot ! Returns ( index string -- ? ) : match-index-from ( i string regexp -- index/f ) ! This word is unsafe. It assumes that i is a fixnum ! and that string is a string. - dup dfa>> execute-unsafe( index string regexp -- i/f ) ; inline + dup dfa>> execute( index string regexp -- i/f ) ; inline GENERIC: end/start ( string regexp -- end start ) M: regexp end/start drop length 0 ; @@ -68,7 +68,7 @@ PRIVATE> : do-next-match ( i string regexp -- i start end ? ) dup next-match>> - execute-unsafe( i string regexp -- i start end ? ) ; inline + execute( i string regexp -- i start end ? ) ; inline :: (each-match) ( i string regexp quot: ( start end string -- ) -- ) i string regexp do-next-match [| i' start end | diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 392cea62d6..a7f348d36b 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -11,7 +11,7 @@ strings.private system threads.private classes.tuple classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private -quotations.private call call.private stack-checker.values +quotations.private combinators.private stack-checker.values stack-checker.alien stack-checker.state stack-checker.errors @@ -135,11 +135,6 @@ M: object infer-call* peek-d literal value>> second 1+ { tuple } apply-word/effect ; -: infer-(throw) ( -- ) - \ (throw) - peek-d literal value>> 2 + { "*" } - apply-word/effect ; - : infer-effect-unsafe ( word -- ) pop-literal nip add-effect-input @@ -194,7 +189,6 @@ M: object infer-call* { \ if [ infer-if ] } { \ dispatch [ infer-dispatch ] } { \ [ infer- ] } - { \ (throw) [ infer-(throw) ] } { \ exit [ infer-exit ] } { \ load-local [ 1 infer->r ] } { \ load-locals [ infer-load-locals ] } @@ -218,7 +212,7 @@ M: object infer-call* { declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose execute (execute) call-effect-unsafe execute-effect-unsafe if - dispatch (throw) exit load-local load-locals get-local + dispatch exit load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect alien-callback } [ t "special" set-word-prop ] each diff --git a/basis/stack-checker/transforms/authors.txt b/basis/stack-checker/transforms/authors.txt index 1901f27a24..a44f8d7f8d 100644 --- a/basis/stack-checker/transforms/authors.txt +++ b/basis/stack-checker/transforms/authors.txt @@ -1 +1,2 @@ Slava Pestov +Daniel Ehrenberg diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index fe580084c0..751e589c28 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -65,4 +65,9 @@ DEFER: curry-folding-test ( quot -- ) { 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as { 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as -{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as \ No newline at end of file +{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as + +[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test +[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test +[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test +[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index ecc2365cf9..6c1d391490 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,11 +1,12 @@ -! Copyright (C) 2007, 2009 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors arrays kernel words sequences generic math -namespaces make quotations assocs combinators classes.tuple -classes.tuple.private effects summary hashtables classes generic -sets definitions generic.standard slots.private continuations locals -generalizations stack-checker.backend stack-checker.state -stack-checker.visitor stack-checker.errors stack-checker.values +USING: fry accessors arrays kernel kernel.private combinators.private +words sequences generic math namespaces make quotations assocs +combinators classes.tuple classes.tuple.private effects summary +hashtables classes generic sets definitions generic.standard +slots.private continuations locals generalizations +stack-checker.backend stack-checker.state stack-checker.visitor +stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.transforms @@ -50,6 +51,47 @@ IN: stack-checker.transforms [ nip "transform-n" set-word-prop ] 3bi ; +! call( and execute( +: (call-effect>quot) ( in out effect -- quot ) + [ + [ [ datastack ] dip dip ] % + [ [ , ] bi@ \ check-datastack , ] dip + '[ _ wrong-values ] , \ unless , + ] [ ] make ; + +: call-effect>quot ( effect -- quot ) + [ in>> length ] [ out>> length ] [ ] tri + [ (call-effect>quot) ] keep add-effect-input + [ call-effect-unsafe ] 2curry ; + +\ call-effect [ call-effect>quot ] 1 define-transform + +: execute-effect-slow ( word effect -- ) + [ '[ _ execute ] ] dip call-effect ; inline + +TUPLE: inline-cache value ; + +: cache-hit? ( word ic -- ? ) value>> eq? ; inline + +: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline + +: execute-effect-unsafe? ( word effect -- ? ) + over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline + +: cache-miss ( word effect ic -- ) + 2over execute-effect-unsafe? + [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ] + [ drop execute-effect-slow ] if ; inline + +: execute-effect-ic ( word effect ic -- ) + #! ic is a mutable cell { effect } + 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline + +: execute-effect>quot ( effect -- quot ) + inline-cache new '[ _ _ execute-effect-ic ] ; + +\ execute-effect [ execute-effect>quot ] 1 define-transform + ! Combinators \ cond [ cond>quot ] 1 define-transform @@ -141,8 +183,12 @@ CONSTANT: bit-member-n 256 dup bit-member? [ bit-member-quot ] [ - [ literalize [ t ] ] { } map>assoc - [ drop f ] suffix [ case ] curry + dup length 4 <= [ + [ drop f ] swap + [ literalize [ t ] ] { } map>assoc linear-case-quot + ] [ + unique [ key? ] curry + ] if ] if ; \ member? [ diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 3f4267df15..1f25c0e031 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! Copyright (C) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private -dlists assocs system combinators init boxes accessors -math.order deques strings quotations fry ; +dlists assocs system combinators combinators.private init boxes +accessors math.order deques strings quotations fry ; IN: threads SYMBOL: initial-thread @@ -126,7 +126,7 @@ DEFER: stop { } set-retainstack { } set-datastack self quot>> [ call stop ] call-clear - ] 2 (throw) ; + ] (( namestack thread -- * )) call-effect-unsafe ; DEFER: next diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index a47b3dca32..2db53f2292 100644 --- a/basis/tools/deploy/deploy-docs.factor +++ b/basis/tools/deploy/deploy-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax words alien.c-types assocs -kernel call call.private tools.deploy.config ; +kernel combinators combinators.private tools.deploy.config ; IN: tools.deploy ARTICLE: "prepare-deploy" "Preparing to deploy an application" diff --git a/basis/tools/deploy/test/12/12.factor b/basis/tools/deploy/test/12/12.factor index 3ee0643c38..3bc2af3da4 100644 --- a/basis/tools/deploy/test/12/12.factor +++ b/basis/tools/deploy/test/12/12.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: call math.parser io math ; +USING: math.parser io math ; IN: tools.deploy.test.12 : execute-test ( a b w -- c ) execute( a b -- c ) ; -: foo ( -- ) 1 2 \ + execute-test number>string print ; +: call-test ( a b q -- c ) call( a b -- c ) ; + +: foo ( -- ) 1 2 \ + execute-test 4 [ * ] call-test number>string print ; MAIN: foo \ No newline at end of file diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index f0d9a084b1..b4ace6b770 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -139,7 +139,6 @@ SYMBOL: +stopped+ { dip [ (step-into-dip) ] } { 2dip [ (step-into-2dip) ] } { 3dip [ (step-into-3dip) ] } - { (throw) [ drop (step-into-quot) ] } { execute [ (step-into-execute) ] } { if [ (step-into-if) ] } { dispatch [ (step-into-dispatch) ] } diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 5cb02f5ad6..fc392c595d 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -8,7 +8,7 @@ ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds ui.backend.cocoa.views core-foundation core-foundation.run-loop core-graphics.types threads math.rectangles fry libc generalizations alien.c-types cocoa.views -combinators io.thread locals call ; +combinators io.thread locals ; IN: ui.backend.cocoa TUPLE: handle ; diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor index d6c7c7905b..28529b013b 100644 --- a/basis/ui/commands/commands.factor +++ b/basis/ui/commands/commands.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel sequences strings math assocs words generic namespaces make assocs quotations -splitting ui.gestures unicode.case unicode.categories tr fry -call ; +splitting ui.gestures unicode.case unicode.categories tr fry ; IN: ui.commands SYMBOL: +nullary+ diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index ebac290f4b..0504231972 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -6,7 +6,7 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid ui.pens.image ui.pens.tile math.rectangles locals fry -combinators.smart call ; +combinators.smart ; IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 4398b0ce70..bda9938f8a 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -8,7 +8,7 @@ continuations ui.clipboards ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.menus ui.gadgets.wrappers ui.render ui.pens.solid ui.gadgets.line-support ui.text ui.gestures ui.baseline-alignment -math.rectangles splitting unicode.categories fonts grouping call ; +math.rectangles splitting unicode.categories fonts grouping ; IN: ui.gadgets.editors TUPLE: editor < line-gadget diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index 6019d6a954..44da013f2c 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/basis/ui/gadgets/panes/panes.factor @@ -10,7 +10,7 @@ ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render ui.text ui.gadgets.presentations ui.gadgets.grids ui.gadgets.tracks ui.gadgets.icons ui.gadgets.grid-lines ui.baseline-alignment -colors call io.styles ; +colors io.styles ; IN: ui.gadgets.panes TUPLE: pane < track diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index ccfa83334b..163dbff514 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs continuations kernel math models -call namespaces opengl sequences io combinators -combinators.short-circuit fry math.vectors math.rectangles cache -ui.gadgets ui.gestures ui.render ui.text ui.text.private -ui.backend ui.gadgets.tracks ui.commands ; +namespaces opengl sequences io combinators combinators.short-circuit +fry math.vectors math.rectangles cache ui.gadgets ui.gestures +ui.render ui.text ui.text.private ui.backend ui.gadgets.tracks +ui.commands ; IN: ui.gadgets.worlds TUPLE: world < track diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 2e52a2fe1e..c7db0839d7 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs kernel math math.order models namespaces make sequences words strings system hashtables math.parser math.vectors classes.tuple classes boxes calendar alarms combinators sets columns fry deques ui.gadgets ui.gadgets.private unicode.case -unicode.categories combinators.short-circuit call ; +unicode.categories combinators.short-circuit ; IN: ui.gestures GENERIC: handle-gesture ( gesture gadget -- ? ) diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor index 2f9cfba961..db6048061e 100644 --- a/basis/ui/operations/operations.factor +++ b/basis/ui/operations/operations.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions kernel ui.commands ui.gestures sequences strings math words generic namespaces -hashtables help.markup quotations assocs fry call linked-assocs ; +hashtables help.markup quotations assocs fry linked-assocs ; IN: ui.operations SYMBOL: +keyboard+ diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index fe318101ee..8ce8f57cf0 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces make dlists -deques sequences threads sequences words continuations init call +deques sequences threads sequences words continuations init combinators hashtables concurrency.flags sets accessors calendar fry destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index 0b7f869141..58957ba8e7 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences math arrays locals fry accessors -lists splitting call make combinators.short-circuit namespaces +lists splitting make combinators.short-circuit namespaces grouping splitting.monotonic ; IN: wrap diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index 60318e669e..4cbf58c8aa 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -12,7 +12,7 @@ IN: xmode.loader.syntax : RULE: scan scan-word scan-word [ - parse-definition { } make + [ parse-definition call( -- ) ] { } make swap [ (parse-rule-tag) ] 2curry ] dip swap define-tag ; parsing diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index f04a42f493..5ad693bc86 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -243,6 +243,8 @@ bi "quotation" "quotations" create { { "array" { "array" "arrays" } read-only } { "compiled" read-only } + "cached-effect" + "cache-counter" } define-builtin "dll" "alien" create { @@ -491,7 +493,6 @@ tuple { "set-alien-double" "alien.accessors" } { "alien-cell" "alien.accessors" } { "set-alien-cell" "alien.accessors" } - { "(throw)" "kernel.private" } { "alien-address" "alien" } { "set-slot" "slots.private" } { "string-nth" "strings.private" } diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 654a8f5f34..1c97ee5a50 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -78,6 +78,8 @@ IN: bootstrap.syntax "call-next-method" "initial:" "read-only" + "call(" + "execute(" } [ "syntax" create drop ] each "t" "syntax" lookup define-symbol diff --git a/core/combinators/authors.txt b/core/combinators/authors.txt index 1901f27a24..a44f8d7f8d 100644 --- a/core/combinators/authors.txt +++ b/core/combinators/authors.txt @@ -1 +1,2 @@ Slava Pestov +Daniel Ehrenberg diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index a26c2fbe5d..cc502140ad 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -1,6 +1,7 @@ USING: arrays help.markup help.syntax strings sbufs vectors kernel quotations generic generic.standard classes -math assocs sequences sequences.private ; +math assocs sequences sequences.private combinators.private +effects words ; IN: combinators ARTICLE: "combinators-quot" "Quotation construction utilities" @@ -9,6 +10,19 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" { $subsection case>quot } { $subsection alist>quot } ; +ARTICLE: "call" "Calling code with known stack effects" +"Arbitrary quotations and words can be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." +$nl +"Quotations:" +{ $subsection POSTPONE: call( } +{ $subsection call-effect } +"Words:" +{ $subsection POSTPONE: execute( } +{ $subsection execute-effect } +"Unsafe calls:" +{ $subsection call-effect-unsafe } +{ $subsection execute-effect-unsafe } ; + ARTICLE: "combinators" "Additional combinators" "The " { $vocab-link "combinators" } " vocabulary provides a few useful combinators." $nl @@ -27,11 +41,27 @@ $nl $nl "A combinator which can help with implementing methods on " { $link hashcode* } ":" { $subsection recursive-hashcode } +{ $subsection "call" } { $subsection "combinators-quot" } { $see-also "quotations" "dataflow" } ; ABOUT: "combinators" +HELP: call-effect +{ $values { "quot" quotation } { "effect" effect } } +{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ; + +HELP: execute-effect +{ $values { "word" word } { "effect" effect } } +{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ; + +HELP: execute-effect-unsafe +{ $values { "word" word } { "effect" effect } } +{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } +{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ; + +{ call-effect call-effect-unsafe execute-effect execute-effect-unsafe } related-words + HELP: cleave { $values { "x" object } { "seq" "a sequence of quotations with stack effect " { $snippet "( x -- ... )" } } } { $description "Applies each quotation to the object in turn." } diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 1ee3a4e3ed..1a4ee34fa2 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -3,6 +3,30 @@ namespaces combinators words classes sequences accessors math.functions arrays ; IN: combinators.tests +[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test +[ 1 2 [ + ] call( -- z ) ] must-fail +[ 1 2 [ + ] call( x y -- z a ) ] must-fail +[ 1 2 3 { 1 2 3 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test +[ [ + ] call( x y -- z ) ] must-infer + +[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test +[ 1 2 \ + execute( -- z ) ] must-fail +[ 1 2 \ + execute( x y -- z a ) ] must-fail +[ \ + execute( x y -- z ) ] must-infer + +: compile-execute(-test-1 ( a b -- c ) \ + execute( a b -- c ) ; + +[ t ] [ \ compile-execute(-test-1 optimized>> ] unit-test +[ 4 ] [ 1 3 compile-execute(-test-1 ] unit-test + +: compile-execute(-test-2 ( a b w -- c ) execute( a b -- c ) ; + +[ t ] [ \ compile-execute(-test-2 optimized>> ] unit-test +[ 4 ] [ 1 3 \ + compile-execute(-test-2 ] unit-test +[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test +[ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test +[ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test + ! Compiled : cond-test-1 ( obj -- str ) { diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index daf247d678..4c600e06ca 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -1,10 +1,34 @@ -! Copyright (C) 2006, 2008 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors hashtables sorting words sets math.order make ; IN: combinators + + +ERROR: wrong-values effect ; + +! We can't USE: effects here so we forward reference slots instead +SLOT: in +SLOT: out + +: call-effect ( quot effect -- ) + [ [ datastack ] dip dip ] dip + [ in>> length ] [ out>> length ] [ ] tri [ check-datastack ] dip + [ wrong-values ] curry unless ; + +: execute-effect ( word effect -- ) + [ [ execute ] curry ] dip call-effect ; + ! cleave : cleave ( x seq -- ) [ call ] with each ; diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 0d66829898..0627ed5265 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -83,7 +83,6 @@ $nl { $subsection with-return } "Reflecting the datastack:" { $subsection with-datastack } -{ $subsection assert-depth } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -217,10 +216,6 @@ HELP: with-datastack { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; -HELP: assert-depth -{ $values { "quot" "a quotation" } } -{ $description "Runs a quotation. Throws an error if the quotation attempts to take input values from the stack, or leave outputs on the stack." } ; - HELP: attempt-all { $values { "seq" sequence } { "quot" quotation } diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 37418b85f5..051d28d8c2 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces make math splitting sorting quotations assocs -combinators accessors ; +combinators combinators.private accessors ; IN: continuations SYMBOL: error @@ -73,7 +73,7 @@ C: continuation continuation< set-catchstack set-namestack @@ -81,19 +81,18 @@ C: continuation [ set-datastack ] dip set-callstack ; -: (continue-with) ( obj continuation -- ) - swap 4 setenv - >continuation< - set-catchstack - set-namestack - set-retainstack - [ set-datastack drop 4 getenv f 4 setenv f ] dip - set-callstack ; - PRIVATE> : continue-with ( obj continuation -- * ) - [ (continue-with) ] 2 (throw) ; + [ + swap 4 setenv + >continuation< + set-catchstack + set-namestack + set-retainstack + [ set-datastack drop 4 getenv f 4 setenv f ] dip + set-callstack + ] (( obj continuation -- * )) call-effect-unsafe ; : continue ( continuation -- * ) f swap continue-with ; @@ -111,12 +110,9 @@ SYMBOL: return-continuation [ [ [ { } like set-datastack ] dip call datastack ] dip continue-with - ] 3 (throw) + ] (( stack quot continuation -- * )) call-effect-unsafe ] callcc1 2nip ; -: assert-depth ( quot -- ) - { } swap with-datastack { } assert= ; inline - GENERIC: compute-restarts ( error -- seq ) continue-with ; diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index a009db76b1..04dc42712c 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: lexer sets sequences kernel splitting effects combinators arrays parser ; @@ -26,3 +26,6 @@ ERROR: bad-effect ; : parse-effect ( end -- effect ) parse-effect-tokens { "--" } split1 dup [ ] [ "Stack effect declaration must contain --" throw ] if ; + +: parse-call( ( accum word -- accum ) + [ ")" parse-effect parsed ] dip parsed ; \ No newline at end of file diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index cf4bf95db9..52529892f4 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -22,6 +22,8 @@ DEFER: 3dip ! Combinators GENERIC: call ( callable -- ) +GENERIC: execute ( word -- ) + DEFER: if : ? ( ? true false -- true/false ) @@ -235,7 +237,7 @@ GENERIC: boa ( ... class -- tuple ) ! Error handling -- defined early so that other files can ! throw errors before continuations are loaded -: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ; +GENERIC: throw ( error -- * ) ERROR: assert got expect ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 6b90abeced..adf1c8adcf 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -402,9 +402,7 @@ IN: parser.tests [ t ] [ "foo" "parser.tests" lookup symbol? ] unit-test ] times -[ "vocab:parser/test/assert-depth.factor" run-file ] -[ got>> { 1 2 3 } sequence= ] -must-fail-with +[ "vocab:parser/test/assert-depth.factor" run-file ] must-fail 2 [ [ ] [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index dddea09db9..1f4d377b27 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -1,11 +1,10 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces -sequences strings vectors words words.symbol quotations io -combinators sorting splitting math.parser effects continuations -io.files vocabs io.encodings.utf8 source-files -classes hashtables compiler.errors compiler.units accessors sets -lexer vocabs.parser slots ; +sequences strings vectors words words.symbol quotations io combinators +sorting splitting math.parser effects continuations io.files vocabs +io.encodings.utf8 source-files classes hashtables compiler.errors +compiler.units accessors sets lexer vocabs.parser slots ; IN: parser : location ( -- loc ) @@ -90,9 +89,9 @@ SYMBOL: auto-use? ERROR: staging-violation word ; -: execute-parsing ( word -- ) +: execute-parsing ( accum word -- accum ) dup changed-definitions get key? [ staging-violation ] when - execute ; + execute( accum -- accum ) ; : scan-object ( -- object ) scan-word dup parsing-word? @@ -125,7 +124,7 @@ M: f parse-quotation \ ] parse-until >quotation ; [ f parse-until >quotation ] with-lexer ; : parse-lines ( lines -- quot ) - lexer-factory get call (parse-lines) ; + lexer-factory get call( lines -- lexer ) (parse-lines) ; : parse-literal ( accum end quot -- accum ) [ parse-until ] dip call parsed ; inline @@ -214,7 +213,7 @@ print-use-hook [ [ ] ] initialize [ V{ } clone amended-use set parse-lines - amended-use get empty? [ print-use-hook get assert-depth ] unless + amended-use get empty? [ print-use-hook get call( -- ) ] unless ] with-file-vocabs ; : parsing-file ( file -- ) @@ -288,7 +287,7 @@ print-use-hook [ [ ] ] initialize ] recover ; : run-file ( file -- ) - [ parse-file call ] curry assert-depth ; + parse-file call( -- ) ; : ?run-file ( path -- ) dup exists? [ run-file ] [ drop ] if ; diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index 8c9d0b5557..c6e58f659a 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -29,7 +29,7 @@ name>char-hook [ : unicode-escape ( str -- ch str' ) "{" ?head-slice [ CHAR: } over index cut-slice - [ >string name>char-hook get call ] dip + [ >string name>char-hook get call( name -- char ) ] dip rest-slice ] [ 6 cut-slice [ hex> ] dip @@ -45,10 +45,10 @@ name>char-hook [ : (parse-string) ( str -- m ) dup [ "\"\\" member? ] find dup [ [ cut-slice [ % ] dip rest-slice ] dip - dup CHAR: " = [ - drop from>> + CHAR: " = [ + from>> ] [ - drop next-escape [ , ] dip (parse-string) + next-escape [ , ] dip (parse-string) ] if ] [ "Unterminated string" throw @@ -59,8 +59,8 @@ name>char-hook [ [ swap tail-slice (parse-string) ] "" make swap ] change-lexer-column ; -: (unescape-string) ( str -- str' ) - dup [ CHAR: \\ = ] find [ +: (unescape-string) ( str -- ) + CHAR: \\ over index dup [ cut-slice [ % ] dip rest-slice next-escape [ , ] dip (unescape-string) diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 25b963c574..1a61845fd1 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -770,3 +770,13 @@ HELP: call-next-method { POSTPONE: call-next-method (call-next-method) next-method } related-words { POSTPONE: << POSTPONE: >> } related-words + +HELP: call( +{ $syntax "call( stack -- effect )" } +{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; + +HELP: execute( +{ $syntax "execute( stack -- effect )" } +{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ; + +{ POSTPONE: call( POSTPONE: execute( } related-words \ No newline at end of file diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index de3be98ceb..f6d124d8da 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien arrays byte-arrays definitions generic hashtables kernel math namespaces parser lexer sequences strings @@ -246,4 +246,8 @@ IN: bootstrap.syntax "initial:" "syntax" lookup define-symbol "read-only" "syntax" lookup define-symbol + + "call(" [ \ call-effect parse-call( ] define-syntax + + "execute(" [ \ execute-effect parse-call( ] define-syntax ] with-compilation-unit diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 00c4df92a6..df6d2d02a7 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -64,7 +64,7 @@ SYMBOL: load-help? +parsing+ >>source-loaded? dup vocab-source-path [ parse-file ] [ [ ] ] if* [ +parsing+ >>source-loaded? ] dip - [ % ] [ assert-depth ] if-bootstrapping + [ % ] [ call( -- ) ] if-bootstrapping +done+ >>source-loaded? drop ] [ ] [ f >>source-loaded? ] cleanup ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 977eac2b35..b9f38dfef3 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -105,4 +105,4 @@ M: vocab-spec forget* forget-vocab ; SYMBOL: load-vocab-hook ! ( name -- vocab ) -: load-vocab ( name -- vocab ) load-vocab-hook get call ; \ No newline at end of file +: load-vocab ( name -- vocab ) load-vocab-hook get call( name -- vocab ) ; \ No newline at end of file diff --git a/core/words/words.factor b/core/words/words.factor index cd11fb2db1..c4a94f0a4c 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays definitions graphs assocs kernel kernel.private slots.private math namespaces sequences strings @@ -10,8 +10,6 @@ IN: words : set-word ( word -- ) \ word set-global ; -GENERIC: execute ( word -- ) - M: word execute (execute) ; M: word <=> diff --git a/extra/4DNav/4DNav.factor b/extra/4DNav/4DNav.factor index f6c00154bb..ee37b33fbf 100755 --- a/extra/4DNav/4DNav.factor +++ b/extra/4DNav/4DNav.factor @@ -17,7 +17,6 @@ colors colors.constants prettyprint vars -call quotations io io.directories diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor index 44234bc4bc..ee63b14f3c 100644 --- a/extra/monads/monads-tests.factor +++ b/extra/monads/monads-tests.factor @@ -79,7 +79,7 @@ IN: monads.tests LAZY: nats-from ( n -- list ) dup 1+ nats-from cons ; -: nats 0 nats-from ; +: nats ( -- list ) 0 nats-from ; [ 3 ] [ { diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor index e9ae167532..6b35772596 100644 --- a/extra/monads/monads.factor +++ b/extra/monads/monads.factor @@ -6,7 +6,7 @@ shuffle ; IN: monads ! Functors -GENERIC# fmap 1 ( functor quot -- functor' ) inline +GENERIC# fmap 1 ( functor quot -- functor' ) ! Monads @@ -21,7 +21,7 @@ GENERIC: >>= ( mvalue -- quot ) M: monad return monad-of return ; M: monad fail monad-of fail ; -: bind ( mvalue quot -- mvalue' ) swap >>= call ; +: bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ; : >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ; :: lift-m2 ( m1 m2 f monad -- m3 ) @@ -30,14 +30,14 @@ M: monad fail monad-of fail ; :: apply ( mvalue mquot monad -- result ) mvalue [| value | mquot [| quot | - value quot call monad return + value quot call( value -- mvalue ) monad return ] bind ] bind ; M: monad fmap over '[ @ _ return ] bind ; ! 'do' notation -: do ( quots -- result ) unclip dip [ bind ] each ; +: do ( quots -- result ) unclip [ call( -- mvalue ) ] curry dip [ bind ] each ; ! Identity SINGLETON: identity-monad @@ -51,7 +51,7 @@ M: identity monad-of drop identity-monad ; M: identity-monad return drop identity boa ; M: identity-monad fail "Fail" throw ; -M: identity >>= value>> '[ _ swap call ] ; +M: identity >>= value>> '[ _ swap call( x -- y ) ] ; : run-identity ( identity -- value ) value>> ; @@ -73,7 +73,7 @@ M: maybe-monad return drop just ; M: maybe-monad fail 2drop nothing ; M: nothing >>= '[ drop _ ] ; -M: just >>= value>> '[ _ swap call ] ; +M: just >>= value>> '[ _ swap call( x -- y ) ] ; : if-maybe ( maybe just-quot nothing-quot -- ) pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline @@ -97,7 +97,7 @@ M: either-monad return drop right ; M: either-monad fail drop left ; M: left >>= '[ drop _ ] ; -M: right >>= value>> '[ _ swap call ] ; +M: right >>= value>> '[ _ swap call( x -- y ) ] ; : if-either ( value left-quot right-quot -- ) [ [ value>> ] [ left? ] bi ] 2dip if ; inline @@ -140,14 +140,14 @@ M: state monad-of drop state-monad ; M: state-monad return drop '[ _ 2array ] state ; M: state-monad fail "Fail" throw ; -: mcall ( state -- ) quot>> call ; +: mcall ( x state -- y ) quot>> call( x -- y ) ; M: state >>= '[ _ swap '[ _ mcall first2 @ mcall ] state ] ; : get-st ( -- state ) [ dup 2array ] state ; : put-st ( value -- state ) '[ drop _ f 2array ] state ; -: run-st ( state initial -- ) swap mcall second ; +: run-st ( state initial -- value ) swap mcall second ; : return-st ( value -- mvalue ) state-monad return ; @@ -166,7 +166,7 @@ M: reader-monad fail "Fail" throw ; M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] reader ] ; -: run-reader ( reader env -- ) swap mcall ; +: run-reader ( reader env -- value ) swap quot>> call( env -- value ) ; : ask ( -- reader ) [ ] reader ; : local ( reader quot -- reader' ) swap '[ @ _ mcall ] reader ; @@ -187,6 +187,6 @@ M: writer-monad fail "Fail" throw ; M: writer >>= '[ [ _ run-writer ] dip '[ @ run-writer ] dip append writer ] ; -: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call writer ; +: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call( x -- y ) writer ; : listen ( writer -- writer' ) run-writer [ 2array ] keep writer ; : tell ( seq -- writer ) f swap writer ; diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor index bec2761e53..0e193741eb 100755 --- a/extra/promises/promises.factor +++ b/extra/promises/promises.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2006 Chris Double, Matthew Willis. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences math vectors arrays namespaces call +USING: arrays kernel sequences math vectors arrays namespaces make quotations parser effects stack-checker words accessors ; IN: promises diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 982aabe2e8..d7301ca042 100644 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors math.vectors classes.tuple math.rectangles colors -kernel sequences models opengl math math.order namespaces call +kernel sequences models opengl math math.order namespaces ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ; diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 36db5d6c80..7a8e579c62 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -29,7 +29,7 @@ and the callstack top is passed in EDX */ pop %ebp ; \ pop %ebx -#define QUOT_XT_OFFSET 9 +#define QUOT_XT_OFFSET 17 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 7b5b5f3167..8cf8fb9ae7 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -61,7 +61,7 @@ #endif -#define QUOT_XT_OFFSET 21 +#define QUOT_XT_OFFSET 37 /* We pass a function pointer to memcpy to work around a Mac OS X ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/errors.c b/vm/errors.c index 7c06ec1310..9b7b7843d2 100755 --- a/vm/errors.c +++ b/vm/errors.c @@ -144,12 +144,6 @@ void misc_signal_handler_impl(void) signal_error(signal_number,signal_callstack_top); } -void primitive_throw(void) -{ - dpop(); - throw_impl(dpop(),stack_chain->callstack_top); -} - void primitive_call_clear(void) { throw_impl(dpop(),stack_chain->callstack_bottom); diff --git a/vm/errors.h b/vm/errors.h index c7f8bc8712..da3ee8bbe0 100755 --- a/vm/errors.h +++ b/vm/errors.h @@ -32,7 +32,6 @@ void signal_error(int signal, F_STACK_FRAME *native_stack); void type_error(CELL type, CELL tagged); void not_implemented_error(void); -void primitive_throw(void); void primitive_call_clear(void); INLINE void type_check(CELL type, CELL tagged) diff --git a/vm/layouts.h b/vm/layouts.h index 94e2f623a3..5b417f92dd 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -172,6 +172,10 @@ typedef struct { CELL array; /* tagged */ CELL compiledp; + /* tagged */ + CELL cached_effect; + /* tagged */ + CELL cache_counter; /* UNTAGGED */ XT xt; /* UNTAGGED compiled code block */ diff --git a/vm/primitives.c b/vm/primitives.c index 82b0555894..00103ac047 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -102,7 +102,6 @@ void *primitives[] = { primitive_set_alien_double, primitive_alien_cell, primitive_set_alien_cell, - primitive_throw, primitive_alien_address, primitive_set_slot, primitive_string_nth, diff --git a/vm/quotations.c b/vm/quotations.c index ca1a8bb3b5..8ea2d5839b 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -514,6 +514,8 @@ void primitive_array_to_quotation(void) quot->array = dpeek(); quot->xt = lazy_jit_compile; quot->compiledp = F; + quot->cached_effect = F; + quot->cache_counter = F; drepl(tag_object(quot)); } From 135f3bfc7f3eb4d252a3cdcc26cfdff96437548f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 20:48:56 -0500 Subject: [PATCH 06/23] Fix bootstrap --- basis/tools/deploy/deploy-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor index 2db53f2292..4c03047eb8 100644 --- a/basis/tools/deploy/deploy-docs.factor +++ b/basis/tools/deploy/deploy-docs.factor @@ -28,7 +28,7 @@ ARTICLE: "tools.deploy.caveats" "Deploy tool caveats" { $heading "Behavior of " { $link boa } } "In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment." { $heading "Behavior of " { $link POSTPONE: execute( } } -"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-unsafe( } "." +"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "." { $heading "Error reporting" } "If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages." { $heading "Choosing the right deploy flags" } From ead345295702f81f7d6fc70e567f0a6d37570b33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 20:49:09 -0500 Subject: [PATCH 07/23] Fix walker --- basis/ui/tools/walker/walker.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor index 1f427d9405..6728fb8338 100644 --- a/basis/ui/tools/walker/walker.factor +++ b/basis/ui/tools/walker/walker.factor @@ -105,5 +105,5 @@ walker-gadget "multitouch" f { [ dup find-walker-window dup - [ raise-window 3drop ] [ drop [ walker-window ] with-ui ] if + [ raise-window 3drop ] [ drop '[ _ _ _ walker-window ] with-ui ] if ] show-walker-hook set-global From bdec3951307141084479dc2596b430d775f89f33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 20:49:19 -0500 Subject: [PATCH 08/23] Remove predicate-instance? hack; use call( instead --- core/bootstrap/primitives.factor | 3 -- core/classes/predicate/predicate-tests.factor | 8 +---- core/classes/predicate/predicate.factor | 29 ++++--------------- 3 files changed, 7 insertions(+), 33 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5ad693bc86..48aae3667e 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -140,9 +140,6 @@ bootstrapping? on "word" "words" create register-builtin "byte-array" "byte-arrays" create register-builtin -! For predicate classes -"predicate-instance?" "classes.predicate" create drop - ! We need this before defining c-ptr below "f" "syntax" lookup { } define-builtin diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor index d4c929a69b..a947b9ddc0 100644 --- a/core/classes/predicate/predicate-tests.factor +++ b/core/classes/predicate/predicate-tests.factor @@ -18,10 +18,4 @@ M: positive abs ; [ 10 ] [ -10 abs ] unit-test [ 10 ] [ 10 abs ] unit-test -[ 0 ] [ 0 abs ] unit-test - -PREDICATE: blah < word blah eq? ; - -[ f ] [ \ predicate-instance? "compiled-uses" word-prop keys \ blah swap memq? ] unit-test - -FORGET: blah \ No newline at end of file +[ 0 ] [ 0 abs ] unit-test \ No newline at end of file diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 7d757772f4..188a2ed794 100644 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes classes.algebra kernel namespaces make words sequences quotations arrays kernel.private assocs combinators ; @@ -7,21 +7,6 @@ IN: classes.predicate PREDICATE: predicate-class < class "metaclass" word-prop predicate-class eq? ; -DEFER: predicate-instance? ( object class -- ? ) - -: update-predicate-instance ( -- ) - \ predicate-instance? bootstrap-word - classes [ predicate-class? ] filter [ - [ literalize ] - [ - [ superclass 1array [ declare ] curry ] - [ "predicate-definition" word-prop ] - bi compose - ] - bi - ] { } map>assoc [ case ] curry - define ; - : predicate-quot ( class -- quot ) [ \ dup , @@ -38,19 +23,17 @@ DEFER: predicate-instance? ( object class -- ? ) [ dup predicate-quot define-predicate ] [ update-classes ] bi - ] - 3tri - update-predicate-instance ; + ] 3tri ; M: predicate-class reset-class - [ call-next-method ] [ { "predicate-definition" } reset-props ] bi - update-predicate-instance ; + [ call-next-method ] [ { "predicate-definition" } reset-props ] bi ; M: predicate-class rank-class drop 1 ; M: predicate-class instance? - 2dup superclass instance? - [ predicate-instance? ] [ 2drop f ] if ; + 2dup superclass instance? [ + "predicate-definition" word-prop call( object -- ? ) + ] [ 2drop f ] if ; M: predicate-class (flatten-class) superclass (flatten-class) ; From e981090045615814716f8e3fae78c864c6a0726f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 16 Mar 2009 23:02:55 -0500 Subject: [PATCH 09/23] Inline caching for call( --- basis/stack-checker/call-effect/authors.txt | 1 + .../call-effect/call-effect.factor | 91 +++++++++++++++++++ basis/stack-checker/stack-checker.factor | 6 +- .../transforms/transforms.factor | 41 --------- 4 files changed, 96 insertions(+), 43 deletions(-) create mode 100644 basis/stack-checker/call-effect/authors.txt create mode 100644 basis/stack-checker/call-effect/call-effect.factor diff --git a/basis/stack-checker/call-effect/authors.txt b/basis/stack-checker/call-effect/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/stack-checker/call-effect/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor new file mode 100644 index 0000000000..ef9a0305f6 --- /dev/null +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators combinators.private effects fry +kernel kernel.private make sequences continuations +stack-checker stack-checker.transforms ; +IN: stack-checker.call-effect + +! call( and execute( have complex expansions. + +! call( uses the following strategy: +! - Inline caching. If the quotation is the same as last time, just call it unsafely +! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot, +! and compare it with declaration. If matches, call it unsafely. +! - Fallback. If the above doesn't work, call it and compare the datastack before +! and after to make sure it didn't mess anything up. + +! execute( uses a similar strategy. + +TUPLE: inline-cache value ; + +: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline + +SYMBOL: +failed+ + +: cached-effect ( quot -- effect ) + dup cached-effect>> + [ ] [ + [ [ infer ] [ 2drop +failed+ ] recover dup ] keep + (>>cached-effect) + ] ?if ; + +: call-effect-unsafe? ( quot effect -- ? ) + [ cached-effect ] dip + over +failed+ eq? + [ 2drop f ] [ effect<= ] if ; inline + +: (call-effect-slow>quot) ( in out effect -- quot ) + [ + [ [ datastack ] dip dip ] % + [ [ , ] bi@ \ check-datastack , ] dip + '[ _ wrong-values ] , \ unless , + ] [ ] make ; + +: call-effect-slow>quot ( effect -- quot ) + [ in>> length ] [ out>> length ] [ ] tri + [ (call-effect-slow>quot) ] keep add-effect-input + [ call-effect-unsafe ] 2curry ; + +: call-effect-slow ( quot effect -- ) drop call ; + +\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform + +: call-effect-fast ( quot effect inline-cache -- ) + 2over call-effect-unsafe? + [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ] + [ drop call-effect-slow ] + if ; inline + +\ call-effect [ + inline-cache new '[ + _ + 3dup nip cache-hit? [ + drop call-effect-unsafe + ] [ + call-effect-fast + ] if + ] +] 0 define-transform + +: execute-effect-slow ( word effect -- ) + [ '[ _ execute ] ] dip call-effect-slow ; inline + +: execute-effect-unsafe? ( word effect -- ? ) + over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline + +: execute-effect-fast ( word effect inline-cache -- ) + 2over execute-effect-unsafe? + [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ] + [ drop execute-effect-slow ] + if ; inline + +: execute-effect-ic ( word effect inline-cache -- ) + 3dup nip cache-hit? + [ drop execute-effect-unsafe ] + [ execute-effect-fast ] + if ; inline + +: execute-effect>quot ( effect -- quot ) + inline-cache new '[ _ _ execute-effect-ic ] ; + +\ execute-effect [ execute-effect>quot ] 1 define-transform diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor index ff283ce9ca..e18a6f0840 100644 --- a/basis/stack-checker/stack-checker.factor +++ b/basis/stack-checker/stack-checker.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel io effects namespaces sequences quotations vocabs -generic words stack-checker.backend stack-checker.state +vocabs.loader generic words stack-checker.backend stack-checker.state stack-checker.known-words stack-checker.transforms stack-checker.errors stack-checker.inlining stack-checker.visitor.dummy ; @@ -28,3 +28,5 @@ M: callable infer ( quot -- effect ) dup subwords [ f "inferred-effect" set-word-prop ] each f "inferred-effect" set-word-prop ] each ; + +"stack-checker.call-effect" require \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 6c1d391490..3b783ce467 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -51,47 +51,6 @@ IN: stack-checker.transforms [ nip "transform-n" set-word-prop ] 3bi ; -! call( and execute( -: (call-effect>quot) ( in out effect -- quot ) - [ - [ [ datastack ] dip dip ] % - [ [ , ] bi@ \ check-datastack , ] dip - '[ _ wrong-values ] , \ unless , - ] [ ] make ; - -: call-effect>quot ( effect -- quot ) - [ in>> length ] [ out>> length ] [ ] tri - [ (call-effect>quot) ] keep add-effect-input - [ call-effect-unsafe ] 2curry ; - -\ call-effect [ call-effect>quot ] 1 define-transform - -: execute-effect-slow ( word effect -- ) - [ '[ _ execute ] ] dip call-effect ; inline - -TUPLE: inline-cache value ; - -: cache-hit? ( word ic -- ? ) value>> eq? ; inline - -: cache-hit ( word effect ic -- ) drop execute-effect-unsafe ; inline - -: execute-effect-unsafe? ( word effect -- ? ) - over optimized>> [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline - -: cache-miss ( word effect ic -- ) - 2over execute-effect-unsafe? - [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ] - [ drop execute-effect-slow ] if ; inline - -: execute-effect-ic ( word effect ic -- ) - #! ic is a mutable cell { effect } - 3dup nip cache-hit? [ cache-hit ] [ cache-miss ] if ; inline - -: execute-effect>quot ( effect -- quot ) - inline-cache new '[ _ _ execute-effect-ic ] ; - -\ execute-effect [ execute-effect>quot ] 1 define-transform - ! Combinators \ cond [ cond>quot ] 1 define-transform From 786475102d9767b810760f14df1265da802c9c07 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Mar 2009 02:19:50 -0500 Subject: [PATCH 10/23] Make more code infer --- basis/bootstrap/stage2.factor | 2 +- basis/cocoa/subclassing/subclassing.factor | 2 +- basis/command-line/command-line.factor | 2 +- basis/editors/editors.factor | 2 +- basis/functors/functors.factor | 2 +- basis/help/help.factor | 2 +- basis/help/lint/lint.factor | 6 +++--- .../call-effect/call-effect-tests.factor | 7 +++++++ .../stack-checker/transforms/transforms-tests.factor | 11 +++-------- basis/threads/threads.factor | 2 +- basis/tools/annotations/annotations.factor | 4 ++-- basis/tools/deploy/deploy-tests.factor | 9 ++++----- basis/tools/test/test.factor | 2 +- basis/tools/vocabs/browser/browser.factor | 6 +----- basis/tr/tr.factor | 3 ++- core/init/init.factor | 6 +++--- core/io/backend/backend.factor | 2 +- core/syntax/syntax.factor | 4 ++-- core/vocabs/loader/loader.factor | 2 +- 19 files changed, 37 insertions(+), 39 deletions(-) create mode 100644 basis/stack-checker/call-effect/call-effect-tests.factor diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 070618ebb4..6c824b6155 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -30,7 +30,7 @@ SYMBOL: bootstrap-time [ "bootstrap." prepend require ] each ; : count-words ( pred -- ) - all-words swap count number>string write ; + all-words swap count number>string write ; inline : print-time ( ms -- ) 1000 /i diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor index 394f45bef3..c3f1b471e0 100644 --- a/basis/cocoa/subclassing/subclassing.factor +++ b/basis/cocoa/subclassing/subclassing.factor @@ -8,7 +8,7 @@ IN: cocoa.subclassing : init-method ( method -- sel imp types ) first3 swap - [ sel_registerName ] [ execute ] [ utf8 string>alien ] + [ sel_registerName ] [ execute( -- xt ) ] [ utf8 string>alien ] tri* ; : throw-if-false ( obj what -- ) diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor index 38d40d8482..73a01aa352 100644 --- a/basis/command-line/command-line.factor +++ b/basis/command-line/command-line.factor @@ -54,7 +54,7 @@ SYMBOL: main-vocab-hook embedded? [ "alien.remote-control" ] [ - main-vocab-hook get [ call ] [ "listener" ] if* + main-vocab-hook get [ call( -- vocab ) ] [ "listener" ] if* ] if ; : default-cli-args ( -- ) diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor index d060a3dfe6..0003b508fb 100644 --- a/basis/editors/editors.factor +++ b/basis/editors/editors.factor @@ -28,7 +28,7 @@ SYMBOL: edit-hook : edit-location ( file line -- ) [ (normalize-path) ] dip edit-hook get-global - [ call ] [ no-edit-hook edit-location ] if* ; + [ call( file line -- ) ] [ no-edit-hook edit-location ] if* ; ERROR: cannot-find-source definition ; diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 6592a3c4f2..caa41d6c29 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -36,7 +36,7 @@ M: array fake-quotations> [ fake-quotations> ] map ; M: object fake-quotations> ; -: parse-definition* ( -- ) +: parse-definition* ( accum -- accum ) parse-definition >fake-quotations parsed \ fake-quotations> parsed ; : DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ; diff --git a/basis/help/help.factor b/basis/help/help.factor index d8629008d2..6fa4473d97 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -140,7 +140,7 @@ help-hook [ [ print-topic ] ] initialize sort-articles [ \ $subsection swap 2array ] map print-element ; : $index ( element -- ) - first call [ ($index) ] unless-empty ; + first call( -- seq ) [ ($index) ] unless-empty ; : $about ( element -- ) first vocab-help [ 1array $subsection ] when* ; diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index 7942f90e0a..7ec8c59ba6 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -13,14 +13,14 @@ IN: help.lint SYMBOL: vocabs-quot : check-example ( element -- ) - [ - rest [ + '[ + _ rest [ but-last "\n" join [ (eval>string) ] call( code -- output ) "\n" ?tail drop ] keep peek assert= - ] vocabs-quot get call ; + ] vocabs-quot get call( quot -- ) ; : check-examples ( element -- ) \ $example swap elements [ check-example ] each ; diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor new file mode 100644 index 0000000000..e5c0f23b30 --- /dev/null +++ b/basis/stack-checker/call-effect/call-effect-tests.factor @@ -0,0 +1,7 @@ +USING: stack-checker.call-effect tools.test math kernel ; +IN: stack-checker.call-effect.tests + +[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test +[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test +[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test +[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 751e589c28..521cf9fcb7 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -3,8 +3,8 @@ USING: sequences stack-checker.transforms tools.test math kernel quotations stack-checker accessors combinators words arrays classes classes.tuple ; -: compose-n-quot ( word -- quot' ) >quotation ; -: compose-n ( quot -- ) compose-n-quot call ; +: compose-n-quot ( word n -- quot' ) >quotation ; +: compose-n ( quot n -- ) compose-n-quot call ; \ compose-n [ compose-n-quot ] 2 define-transform : compose-n-test ( a b c -- x ) 2 \ + compose-n ; @@ -65,9 +65,4 @@ DEFER: curry-folding-test ( quot -- ) { 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as { 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as -{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as - -[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test -[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test -[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test -[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test \ No newline at end of file +{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as \ No newline at end of file diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 1f25c0e031..cacc628e2a 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -160,7 +160,7 @@ DEFER: next PRIVATE> : stop ( -- ) - self [ exit-handler>> call ] [ unregister-thread ] bi next ; + self [ exit-handler>> call( -- ) ] [ unregister-thread ] bi next ; : suspend ( quot state -- obj ) [ diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 293a22d2bb..8c3d95f2b8 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -39,13 +39,13 @@ ERROR: cannot-annotate-twice word ; dup def>> "unannotated-def" set-word-prop ; : (annotate) ( word quot -- ) - [ dup def>> ] dip call define ; inline + [ dup def>> ] dip call( old -- new ) define ; PRIVATE> : annotate ( word quot -- ) [ method-spec>word check-annotate-twice ] dip - [ over save-unannotated-def (annotate) ] with-compilation-unit ; inline + [ over save-unannotated-def (annotate) ] with-compilation-unit ; vocab-author } cleave ; : keyed-vocabs ( str quot -- seq ) - all-vocabs [ - swap [ - [ [ 2dup ] dip swap call member? ] filter - ] dip swap - ] assoc-map 2nip ; inline + [ all-vocabs ] 2dip '[ [ _ swap @ member? ] filter ] assoc-map ; inline : tagged ( tag -- assoc ) [ vocab-tags ] keyed-vocabs ; diff --git a/basis/tr/tr.factor b/basis/tr/tr.factor index ce535f335a..66c0276055 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -17,7 +17,8 @@ M: bad-tr summary [ [ ascii? ] all? ] both? [ bad-tr ] unless ; : compute-tr ( quot from to -- mapping ) - zip [ 128 ] 2dip '[ [ @ _ at ] keep or ] B{ } map-as ; inline + [ 128 ] 3dip zip + '[ [ _ call( x -- y ) _ at ] keep or ] B{ } map-as ; inline : tr-hints ( word -- ) { { byte-array } { string } } "specializer" set-word-prop ; diff --git a/core/init/init.factor b/core/init/init.factor index 953340b985..5d8e88b85f 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations continuations.private kernel kernel.private sequences assocs namespaces namespaces.private ; @@ -9,10 +9,10 @@ SYMBOL: init-hooks init-hooks global [ drop V{ } clone ] cache drop : do-init-hooks ( -- ) - init-hooks get [ nip call ] assoc-each ; + init-hooks get [ nip call( -- ) ] assoc-each ; : add-init-hook ( quot name -- ) - dup init-hooks get at [ over call ] unless + dup init-hooks get at [ over call( -- ) ] unless init-hooks get set-at ; : boot ( -- ) init-namespaces init-catchstack init-error-handler ; diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index 2f0bb1063f..4c91a519c6 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -39,7 +39,7 @@ M: object normalize-directory normalize-path ; : set-io-backend ( io-backend -- ) io-backend set-global init-io init-stdio - "io.files" init-hooks get at call ; + "io.files" init-hooks get at call( -- ) ; ! Note that we have 'alien' in our using list so that the alien ! init hook runs before this one. diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index f6d124d8da..d01a9ebb2c 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -80,7 +80,7 @@ IN: bootstrap.syntax scan { { [ dup length 1 = ] [ first ] } { [ "\\" ?head ] [ next-escape >string "" assert= ] } - [ name>char-hook get call ] + [ name>char-hook get call( name -- char ) ] } cond parsed ] define-syntax @@ -231,7 +231,7 @@ IN: bootstrap.syntax "<<" [ [ \ >> parse-until >quotation - ] with-nested-compilation-unit call + ] with-nested-compilation-unit call( -- ) ] define-syntax "call-next-method" [ diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index df6d2d02a7..4f9005e110 100644 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -90,7 +90,7 @@ PRIVATE> : run ( vocab -- ) dup load-vocab vocab-main [ - execute + execute( -- ) ] [ "The " write vocab-name write " vocabulary does not define an entry point." print From 2ed97f5a24a294e242e30df631005ac4d14f002e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Mar 2009 18:53:44 -0500 Subject: [PATCH 11/23] Various fixes for call( --- basis/core-foundation/fsevents/fsevents.factor | 2 +- basis/stack-checker/call-effect/call-effect.factor | 14 +++++++++----- basis/tools/deploy/shaker/shaker.factor | 4 +++- basis/tools/deploy/shaker/strip-call.factor | 2 ++ core/combinators/combinators-tests.factor | 8 ++++++++ 5 files changed, 23 insertions(+), 7 deletions(-) diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 06b9c6407b..46f6639ab8 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -167,7 +167,7 @@ SYMBOL: event-stream-callbacks eventFlags numEvents eventIds numEvents 3array flip - info event-stream-callbacks get at [ drop ] or call ; + info event-stream-callbacks get at [ drop ] or call( changes -- ) ; : master-event-source-callback ( -- alien ) "void" diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor index ef9a0305f6..bd1f7c73c3 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/stack-checker/call-effect/call-effect.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.private effects fry -kernel kernel.private make sequences continuations +kernel kernel.private make sequences continuations quotations stack-checker stack-checker.transforms ; IN: stack-checker.call-effect @@ -20,18 +20,22 @@ TUPLE: inline-cache value ; : cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline -SYMBOL: +failed+ +SYMBOL: +unknown+ -: cached-effect ( quot -- effect ) +GENERIC: cached-effect ( quot -- effect ) + +M: object cached-effect drop +unknown+ ; + +M: quotation cached-effect dup cached-effect>> [ ] [ - [ [ infer ] [ 2drop +failed+ ] recover dup ] keep + [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep (>>cached-effect) ] ?if ; : call-effect-unsafe? ( quot effect -- ? ) [ cached-effect ] dip - over +failed+ eq? + over +unknown+ eq? [ 2drop f ] [ effect<= ] if ; inline : (call-effect-slow>quot) ( in out effect -- quot ) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 98fc06a989..239d34b864 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -122,6 +122,7 @@ IN: tools.deploy.shaker "inline" "inlined-block" "input-classes" + "instances" "interval" "intrinsics" "lambda" @@ -344,7 +345,8 @@ IN: tools.deploy.shaker ] 2each ; : compress-quotations ( -- ) - [ quotation? ] [ remain-compiled ] "quotations" compress ; + [ quotation? ] [ remain-compiled ] "quotations" compress + [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ; : compress-strings ( -- ) [ string? ] [ ] "strings" compress ; diff --git a/basis/tools/deploy/shaker/strip-call.factor b/basis/tools/deploy/shaker/strip-call.factor index 4259895936..860a0f3849 100644 --- a/basis/tools/deploy/shaker/strip-call.factor +++ b/basis/tools/deploy/shaker/strip-call.factor @@ -5,4 +5,6 @@ IN: tools.deploy.shaker.call IN: call USE: call.private +: call-effect ( word effect -- ) call-effect-unsafe ; inline + : execute-effect ( word effect -- ) execute-effect-unsafe ; inline \ No newline at end of file diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 1a4ee34fa2..be7d93873e 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -27,6 +27,14 @@ IN: combinators.tests [ -3 ] [ 1 4 \ - compile-execute(-test-2 ] unit-test [ 5 ] [ 1 4 \ + compile-execute(-test-2 ] unit-test +: compile-call(-test-1 ( a b q -- c ) call( a b -- c ) ; + +[ t ] [ \ compile-call(-test-1 optimized>> ] unit-test +[ 4 ] [ 1 3 [ + ] compile-call(-test-1 ] unit-test +[ 7 ] [ 1 3 2 [ * + ] curry compile-call(-test-1 ] unit-test +[ 7 ] [ 1 3 [ 2 * ] [ + ] compose compile-call(-test-1 ] unit-test +[ 4 ] [ 1 3 [ { + } [ ] like call ] compile-call(-test-1 ] unit-test + ! Compiled : cond-test-1 ( obj -- str ) { From 9d44b7620f5190cf35ad8fe8a687513118396f9a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Mar 2009 17:01:26 -0500 Subject: [PATCH 12/23] Fixing the build --- basis/compiler/tests/stack-trace.factor | 2 +- .../generalizations-docs.factor | 20 +++++++++---------- basis/html/streams/streams-tests.factor | 4 +--- basis/tools/deploy/shaker/strip-call.factor | 4 ++-- basis/urls/urls-docs.factor | 6 +++--- core/vocabs/loader/loader-tests.factor | 6 ++---- extra/advice/advice.factor | 2 +- extra/wordtimer/wordtimer.factor | 4 ++-- 8 files changed, 22 insertions(+), 26 deletions(-) diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index cfbea3bcb9..b317ed3eb5 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -14,7 +14,7 @@ words splitting grouping sorting accessors ; [ t ] [ symbolic-stack-trace [ word? ] filter - { baz bar foo throw } tail? + { baz bar foo } tail? ] unit-test : bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ; diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 376ae5bed2..2088e468c6 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -58,7 +58,7 @@ HELP: npick "placed on the top of the stack." } { $examples - { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" } + { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick 5 narray ." "{ 1 2 3 4 1 }" } "Some core words expressed in terms of " { $link npick } ":" { $table { { $link dup } { $snippet "1 npick" } } @@ -75,7 +75,7 @@ HELP: ndup "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup 8 narray ." "{ 1 2 3 4 1 2 3 4 }" } "Some core words expressed in terms of " { $link ndup } ":" { $table { { $link dup } { $snippet "1 ndup" } } @@ -91,7 +91,7 @@ HELP: nnip "for any number of items." } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip ." "4" } "Some core words expressed in terms of " { $link nnip } ":" { $table { { $link nip } { $snippet "1 nnip" } } @@ -106,7 +106,7 @@ HELP: ndrop "for any number of items." } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop ." "1" } "Some core words expressed in terms of " { $link ndrop } ":" { $table { { $link drop } { $snippet "1 ndrop" } } @@ -121,7 +121,7 @@ HELP: nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" } + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 nrot 4array ." "{ 2 3 4 1 }" } "Some core words expressed in terms of " { $link nrot } ":" { $table { { $link swap } { $snippet "1 nrot" } } @@ -135,7 +135,7 @@ HELP: -nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" } + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 4 4 -nrot 4array ." "{ 4 1 2 3 }" } "Some core words expressed in terms of " { $link -nrot } ":" { $table { { $link swap } { $snippet "1 -nrot" } } @@ -151,8 +151,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" } - { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" } + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip 3array ." "{ 1 1 2 }" } + { $example "USING: arrays generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip 2array ." "{ 2 3 }" } "Some core words expressed in terms of " { $link ndip } ":" { $table { { $link dip } { $snippet "1 ndip" } } @@ -168,7 +168,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" } "Some core words expressed in terms of " { $link nslip } ":" { $table { { $link slip } { $snippet "1 nslip" } } @@ -184,7 +184,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep 6 narray ." "{ 99 1 2 3 4 5 }" } "Some core words expressed in terms of " { $link nkeep } ":" { $table { { $link keep } { $snippet "1 nkeep" } } diff --git a/basis/html/streams/streams-tests.factor b/basis/html/streams/streams-tests.factor index 249861b12a..835874cbb7 100644 --- a/basis/html/streams/streams-tests.factor +++ b/basis/html/streams/streams-tests.factor @@ -61,6 +61,4 @@ M: funky url-of "http://www.funky-town.com/" swap town>> append ; [ H{ } [ ] with-nesting nl ] make-html-string ] unit-test -[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test - -[ ] [ [ \ predicate-instance? def>> . ] with-html-writer drop ] unit-test +[ ] [ [ { 1 2 3 } describe ] with-html-writer drop ] unit-test \ No newline at end of file diff --git a/basis/tools/deploy/shaker/strip-call.factor b/basis/tools/deploy/shaker/strip-call.factor index 860a0f3849..d0593b6c15 100644 --- a/basis/tools/deploy/shaker/strip-call.factor +++ b/basis/tools/deploy/shaker/strip-call.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. IN: tools.deploy.shaker.call -IN: call -USE: call.private +IN: combinators +USE: combinators.private : call-effect ( word effect -- ) call-effect-unsafe ; inline diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index 437a9419e3..707caf3188 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -82,9 +82,9 @@ HELP: parse-host { $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." } { $examples { $example - "USING: prettyprint urls kernel ;" - "\"sbcl.org:80\" parse-host .s 2drop" - "\"sbcl.org\"\n80" + "USING: arrays kernel prettyprint urls ;" + "\"sbcl.org:80\" parse-host 2array ." + "{ \"sbcl.org\" 80 }" } } ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index cb4a0b50aa..4241999bcd 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -27,20 +27,18 @@ combinators vocabs.parser grouping ; IN: vocabs.loader.test.2 -: hello 3 ; +: hello ( -- ) ; MAIN: hello IN: vocabs.loader.tests -[ { 3 3 3 } ] [ +[ ] [ "vocabs.loader.test.2" run "vocabs.loader.test.2" vocab run "vocabs.loader.test.2" run - 3array ] unit-test - [ "resource:core/vocabs/loader/test/a/a.factor" forget-source "vocabs.loader.test.a" forget-vocab diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor index fbdfa9c66b..be9835c5b9 100644 --- a/extra/advice/advice.factor +++ b/extra/advice/advice.factor @@ -49,7 +49,7 @@ PRIVATE> in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ; : make-advised ( word -- ) - [ dup [ over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ] + [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ] [ { before after around } [ swap set-word-prop ] with each ] [ t advised set-word-prop ] tri ; diff --git a/extra/wordtimer/wordtimer.factor b/extra/wordtimer/wordtimer.factor index 7abdc149dd..34cd19c34f 100644 --- a/extra/wordtimer/wordtimer.factor +++ b/extra/wordtimer/wordtimer.factor @@ -1,6 +1,6 @@ USING: kernel sequences namespaces make math assocs words arrays tools.annotations vocabs sorting prettyprint io system -math.statistics accessors tools.time ; +math.statistics accessors tools.time fry ; IN: wordtimer SYMBOL: *wordtimes* @@ -40,7 +40,7 @@ SYMBOL: *calling* [ swap time-unless-recursing ] 2curry ; : add-timer ( word -- ) - dup [ (add-timer) ] annotate ; + dup '[ [ _ ] dip (add-timer) ] annotate ; : add-timers ( vocab -- ) words [ add-timer ] each ; From e2fdb0783c5b11e07a208090425b88f62885aa80 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Mar 2009 17:07:19 -0500 Subject: [PATCH 13/23] Separate regexp.prettyprint from regexp to reduce deployed image size --- basis/regexp/prettyprint/authors.txt | 1 + basis/regexp/prettyprint/prettyprint.factor | 13 +++++++++++++ basis/regexp/regexp.factor | 18 +++++++----------- 3 files changed, 21 insertions(+), 11 deletions(-) create mode 100644 basis/regexp/prettyprint/authors.txt create mode 100644 basis/regexp/prettyprint/prettyprint.factor diff --git a/basis/regexp/prettyprint/authors.txt b/basis/regexp/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/regexp/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/regexp/prettyprint/prettyprint.factor b/basis/regexp/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..7af762a34e --- /dev/null +++ b/basis/regexp/prettyprint/prettyprint.factor @@ -0,0 +1,13 @@ +! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel make prettyprint.backend +prettyprint.custom regexp regexp.parser regexp.private ; +IN: regexp.prettyprint + +M: regexp pprint* + [ + [ + [ raw>> dup find-regexp-syntax swap % swap % % ] + [ options>> options>string % ] bi + ] "" make + ] keep present-text ; \ No newline at end of file diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 5889b19e47..33499b1437 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2008, 2009 Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators kernel kernel.private math sequences -sequences.private strings sets assocs prettyprint.backend -prettyprint.custom make lexer namespaces parser arrays fry locals -regexp.parser splitting sorting regexp.ast regexp.negation -regexp.compiler compiler.units words math.ranges ; +sequences.private strings sets assocs make lexer namespaces parser +arrays fry locals regexp.parser splitting sorting regexp.ast +regexp.negation regexp.compiler compiler.units words math.ranges ; IN: regexp TUPLE: regexp @@ -217,11 +216,8 @@ PRIVATE> : R{ CHAR: } parsing-regexp ; parsing : R| CHAR: | parsing-regexp ; parsing -M: regexp pprint* - [ - [ - [ raw>> dup find-regexp-syntax swap % swap % % ] - [ options>> options>string % ] bi - ] "" make - ] keep present-text ; +USING: vocabs vocabs.loader ; +"prettyprint" vocab [ + "regexp.prettyprint" require +] when \ No newline at end of file From 2bb3f782c676da78b8110f52d3f03759a096e67a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:07:46 -0500 Subject: [PATCH 14/23] site-watcher uses the db now --- extra/site-watcher/authors.txt | 2 +- extra/site-watcher/site-watcher-docs.factor | 60 ------ extra/site-watcher/site-watcher.factor | 200 ++++++++++++-------- 3 files changed, 127 insertions(+), 135 deletions(-) delete mode 100644 extra/site-watcher/site-watcher-docs.factor diff --git a/extra/site-watcher/authors.txt b/extra/site-watcher/authors.txt index 7c1b2f2279..b4bd0e7b35 100644 --- a/extra/site-watcher/authors.txt +++ b/extra/site-watcher/authors.txt @@ -1 +1 @@ -Doug Coleman +Doug Coleman \ No newline at end of file diff --git a/extra/site-watcher/site-watcher-docs.factor b/extra/site-watcher/site-watcher-docs.factor deleted file mode 100644 index 37a1cf138d..0000000000 --- a/extra/site-watcher/site-watcher-docs.factor +++ /dev/null @@ -1,60 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs help.markup help.syntax kernel urls alarms calendar ; -IN: site-watcher - -HELP: run-site-watcher -{ $description "Starts the site-watcher on the assoc stored in " { $link sites } "." } ; - -HELP: running-site-watcher -{ $var-description "A symbol storing the alarm of a running site-watcher if started with the " { $link run-site-watcher } " word. To prevent multiple site-watchers from running, this variable is checked before allowing another site-watcher to start." } ; - -HELP: site-watcher-from -{ $var-description "The email address from which site-watcher sends emails." } ; - -HELP: sites -{ $var-description "A symbol storing an assoc of URLs, data about a site, and who to notify if a site goes down." } ; - -HELP: watch-site -{ $values - { "emails" "a string containing an email address, or an array of such" } - { "url" url } -} -{ $description "Adds a new site to the watch assoc stored in " { $link sites } ", or adds email addresses to an already watched site." } ; - -HELP: watch-sites -{ $values - { "assoc" assoc } - { "alarm" alarm } -} -{ $description "Runs the site-watcher on the input assoc and returns the alarm that times the site check loop. This alarm may be turned off with " { $link cancel-alarm } ", thus stopping the site-watcher." } ; - -HELP: site-watcher-frequency -{ $var-description "A " { $link duration } " specifying how long to wait between checking sites." } ; - -HELP: unwatch-site -{ $values - { "emails" "a string containing an email, or an array of such" } - { "url" url } -} -{ $description "Removes an email address from being notified when a site's goes down. If this email was the last one watching the site, removes the site as well." } ; - -HELP: delete-site -{ $values - { "url" url } -} -{ $description "Removes a watched site from the " { $link sites } " assoc." } ; - -ARTICLE: "site-watcher" "Site watcher" -"The " { $vocab-link "site-watcher" } " vocabulary monitors websites and sends email when a site goes down or comes up." $nl -"To monitor a site:" -{ $subsection watch-site } -"To stop email addresses from being notified if a site's status changes:" -{ $subsection unwatch-site } -"To stop monitoring a site for all email addresses:" -{ $subsection delete-site } -"To run site-watcher using the sites variable:" -{ $subsection run-site-watcher } -; - -ABOUT: "site-watcher" diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index c538b12ed1..f1e7acbb5a 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -1,114 +1,166 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alarms assocs calendar combinators -continuations fry http.client io.streams.string kernel init -namespaces prettyprint smtp arrays sequences math math.parser -strings sets ; +USING: db.sqlite db.types db.tuples kernel accessors +db io.files io.files.temp locals io.directories continuations +assocs sequences alarms namespaces http.client init calendar +math math.parser smtp strings io prettyprint combinators arrays +generalizations combinators.smart ; IN: site-watcher -SYMBOL: sites +: ?unparse ( string/object -- string ) + dup string? [ unparse ] unless ; inline + +: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline + +[ site-watcher-path delete-file ] ignore-errors + +: with-sqlite-db ( quot -- ) + site-watcher-path swap with-db ; inline + +TUPLE: account account-id email ; + +: ( email -- account ) + account new + swap >>email ; + +account "ACCOUNT" { + { "account-id" "ACCOUNT_ID" +db-assigned-id+ } + { "email" "EMAIL" VARCHAR } +} define-persistent + +TUPLE: site site-id url up? changed? last-up error last-error ; + +: ( url -- site ) + site new + swap >>url ; + +site "SITE" { + { "site-id" "SITE_ID" INTEGER +db-assigned-id+ } + { "url" "URL" VARCHAR } + { "up?" "UP" BOOLEAN } + { "changed?" "CHANGED" BOOLEAN } + { "last-up" "LAST_UP" TIMESTAMP } + { "error" "ERROR" VARCHAR } + { "last-error" "LAST_ERROR" TIMESTAMP } +} define-persistent + +TUPLE: watching-site account-id site-id ; + +: ( account-id site-id -- watching-site ) + watching-site new + swap >>site-id + swap >>account-id ; + +watching-site "WATCHING_SITE" { + { "account-id" "ACCOUNT_ID" INTEGER +user-assigned-id+ } + { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } +} define-persistent + +: select-account/site ( email url -- account site ) + [ select-tuple account-id>> ] + [ select-tuple site-id>> ] bi* ; + +: watch-site ( email url -- ) + select-account/site insert-tuple ; + +: unwatch-site ( email url -- ) + select-account/site delete-tuples ; SYMBOL: site-watcher-from +"factor-site-watcher@gmail.com" site-watcher-from set-global -sites [ H{ } clone ] initialize - -TUPLE: watching emails url last-up up? send-email? error ; +SYMBOL: site-watcher-frequency +10 seconds site-watcher-frequency set-global + +SYMBOL: running-site-watcher > = [ t >>changed? ] unless ] keep >>up? ; -: ( emails url -- watching ) - watching new - swap >>url - swap ?1array >>emails - now >>last-up - t >>up? ; - -ERROR: not-watching-site url status ; - -: set-site-flags ( watching new-up? -- watching ) - [ over up?>> = [ t >>send-email? ] unless ] keep >>up? ; - -: site-bad ( watching error -- ) - >>error f set-site-flags drop ; - -: site-good ( watching -- ) +: site-good ( site -- ) + t set-notify-site-watchers + now >>last-up f >>error - t set-site-flags - now >>last-up drop ; + f >>last-error + update-tuple ; -: check-sites ( assoc -- ) +: site-bad ( site error -- ) + ?unparse >>error + f set-notify-site-watchers + now >>last-error + update-tuple ; + +: check-sites ( seq -- ) [ - swap '[ _ http-get 2drop site-good ] [ site-bad ] recover - ] assoc-each ; + [ dup url>> http-get 2drop site-good ] [ site-bad ] recover + ] each ; -: site-up-email ( email watching -- email ) +: site-up-email ( email site -- email ) last-up>> now swap time- duration>minutes 60 /mod [ >integer number>string ] bi@ [ " hours, " append ] [ " minutes" append ] bi* append "Site was down for (at least): " prepend >>body ; -: ?unparse ( string/object -- string ) - dup string? [ unparse ] unless ; inline +: site-down-email ( email site -- email ) + error>> >>body ; -: site-down-email ( email watching -- email ) - error>> ?unparse >>body ; - -: send-report ( watching -- ) +: send-report ( site -- ) [ ] dip { - [ emails>> >>to ] + [ email>> 1array >>to ] [ drop site-watcher-from get "factor.site.watcher@gmail.com" or >>from ] [ dup up?>> [ site-up-email ] [ site-down-email ] if ] [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ] - [ f >>send-email? drop ] } cleave send-email ; -: report-sites ( assoc -- ) - [ nip send-email?>> ] assoc-filter - [ nip send-report ] assoc-each ; +: email-accounts ( seq -- ) + [ ] [ [ send-report ] each ] if-empty ; + +TUPLE: reporting-site email url up? changed? last-up? error last-error ; + +: report-sites ( -- ) + "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_id = watching_site.account_id and site.site_id = watching_site.site_id and site.changed = '1'" sql-query + [ [ reporting-site boa ] input -SYMBOL: site-watcher-frequency -site-watcher-frequency [ 5 minutes ] initialize - -: watch-sites ( assoc -- alarm ) - '[ - _ [ check-sites ] [ report-sites ] bi +: watch-sites ( -- alarm ) + [ + [ + f select-tuples check-sites report-sites + ] with-sqlite-db ] site-watcher-frequency get every ; -: watch-site ( emails url -- ) - sites get ?at [ - [ [ ?1array ] dip append prune ] change-emails drop - ] [ - dup url>> sites get set-at - ] if ; +: watch-new-site ( url -- ) + t >>up? insert-tuple ; -: delete-site ( url -- ) - sites get delete-at ; - -: unwatch-site ( emails url -- ) - [ ?1array ] dip - sites get ?at [ - [ diff ] change-emails dup emails>> empty? [ - url>> delete-site - ] [ - drop - ] if - ] [ - nip delete-site - ] if ; - -SYMBOL: running-site-watcher +: insert-account ( email -- ) + insert-tuple ; : run-site-watcher ( -- ) - running-site-watcher get-global [ - sites get-global watch-sites running-site-watcher set-global + running-site-watcher get [ + watch-sites running-site-watcher set-global ] unless ; +: stop-site-watcher ( -- ) + running-site-watcher get [ cancel-alarm ] when* ; + [ f running-site-watcher set-global ] "site-watcher" add-init-hook -MAIN: run-site-watcher + +:: fake-sites ( -- seq ) + [ + account ensure-table + site ensure-table + watching-site ensure-table + + "erg@factorcode.org" insert-account + "http://asdfasdfasdfasdfqwerqqq.com" watch-new-site + "http://fark.com" watch-new-site + + "erg@factorcode.org" "http://asdfasdfasdfasdfqwerqqq.com" watch-site + f select-tuples + ] with-sqlite-db ; From d60e586f481594bd8b7bc995f8045f74f952a2ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Mar 2009 17:08:18 -0500 Subject: [PATCH 15/23] Fix tools.deploy.shaker's call( and execute( stripping --- basis/tools/deploy/shaker/shaker.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 239d34b864..a729e40e2a 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -54,11 +54,8 @@ IN: tools.deploy.shaker ] when ; : strip-call ( -- ) - "call" vocab [ - "Stripping stack effect checking from call( and execute(" show - "vocab:tools/deploy/shaker/strip-call.factor" - run-file - ] when ; + "Stripping stack effect checking from call( and execute(" show + "vocab:tools/deploy/shaker/strip-call.factor" run-file ; : strip-cocoa ( -- ) "cocoa" vocab [ From 1d457205792b223813eccf47426c7fe48feb06d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 18 Mar 2009 17:08:57 -0500 Subject: [PATCH 16/23] Add a deploy test to keep benchmark.regex-dna size down --- basis/tools/deploy/deploy-tests.factor | 2 ++ extra/benchmark/regex-dna/regex-dna.factor | 14 +++++++------- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 3a2f960fc9..0a7549430d 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -26,6 +26,8 @@ os macosx? [ [ t ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test ] when +[ t ] [ "benchmark.regex-dna" shake-and-bake 1200000 small-enough? ] unit-test + { "tools.deploy.test.1" "tools.deploy.test.2" diff --git a/extra/benchmark/regex-dna/regex-dna.factor b/extra/benchmark/regex-dna/regex-dna.factor index 5c11be357f..24e7759783 100644 --- a/extra/benchmark/regex-dna/regex-dna.factor +++ b/extra/benchmark/regex-dna/regex-dna.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors prettyprint io io.encodings.ascii -io.files kernel sequences assocs namespaces regexp ; +USING: accessors io io.encodings.ascii io.files kernel sequences +assocs math.parser namespaces regexp ; IN: benchmark.regex-dna ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=regexdna&lang=ruby&id=1 @@ -22,7 +22,7 @@ IN: benchmark.regex-dna R/ agggtaa[cgt]|[acg]ttaccct/i } [ [ raw>> write bl ] - [ count-matches . ] + [ count-matches number>string print ] bi ] with each ; @@ -50,9 +50,9 @@ SYMBOL: clen dup count-patterns do-replacements nl - ilen get . - clen get . - length . ; + ilen get number>string print + clen get number>string print + length number>string print ; : regex-dna-main ( -- ) "resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" regex-dna ; From 3d5bb95640474972b168c1cf604ec8a21e4b3d30 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:11:54 -0500 Subject: [PATCH 17/23] dont use prettyprinter --- extra/site-watcher/site-watcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index f1e7acbb5a..6bed54432e 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -3,7 +3,7 @@ USING: db.sqlite db.types db.tuples kernel accessors db io.files io.files.temp locals io.directories continuations assocs sequences alarms namespaces http.client init calendar -math math.parser smtp strings io prettyprint combinators arrays +math math.parser smtp strings io combinators arrays generalizations combinators.smart ; IN: site-watcher From 71435f6653d6be6870ab79d8c31930b93820cce3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:12:47 -0500 Subject: [PATCH 18/23] prettyprint was necessary. --- extra/site-watcher/site-watcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 6bed54432e..9784161075 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -4,7 +4,7 @@ USING: db.sqlite db.types db.tuples kernel accessors db io.files io.files.temp locals io.directories continuations assocs sequences alarms namespaces http.client init calendar math math.parser smtp strings io combinators arrays -generalizations combinators.smart ; +generalizations combinators.smart prettyprint ; IN: site-watcher : ?unparse ( string/object -- string ) From d5581b453e3d2a0671717bf64d378633cd0cd868 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:15:54 -0500 Subject: [PATCH 19/23] use error. instead of unparse --- extra/site-watcher/site-watcher.factor | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 9784161075..3697546243 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -3,13 +3,10 @@ USING: db.sqlite db.types db.tuples kernel accessors db io.files io.files.temp locals io.directories continuations assocs sequences alarms namespaces http.client init calendar -math math.parser smtp strings io combinators arrays -generalizations combinators.smart prettyprint ; +math math.parser smtp strings io combinators arrays debugger +generalizations combinators.smart io.streams.string ; IN: site-watcher -: ?unparse ( string/object -- string ) - dup string? [ unparse ] unless ; inline - : site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline [ site-watcher-path delete-file ] ignore-errors @@ -87,7 +84,7 @@ SYMBOL: running-site-watcher update-tuple ; : site-bad ( site error -- ) - ?unparse >>error + [ error. ] with-string-writer >>error f set-notify-site-watchers now >>last-error update-tuple ; From e8f9d48b0830722a6ef83ce47895f600c350d876 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:43:49 -0500 Subject: [PATCH 20/23] move site-watcher db code to new vocab, clean up the site-watcher api --- extra/site-watcher/db/authors.txt | 1 + extra/site-watcher/db/db.factor | 51 +++++++++ extra/site-watcher/site-watcher-tests.factor | 19 ++++ extra/site-watcher/site-watcher.factor | 106 ++++--------------- 4 files changed, 93 insertions(+), 84 deletions(-) create mode 100644 extra/site-watcher/db/authors.txt create mode 100644 extra/site-watcher/db/db.factor create mode 100644 extra/site-watcher/site-watcher-tests.factor diff --git a/extra/site-watcher/db/authors.txt b/extra/site-watcher/db/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/site-watcher/db/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor new file mode 100644 index 0000000000..3527f57074 --- /dev/null +++ b/extra/site-watcher/db/db.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors continuations db db.sqlite db.tuples db.types +io.directories io.files.temp kernel ; +IN: site-watcher.db + +: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline + +[ site-watcher-path delete-file ] ignore-errors + +: with-sqlite-db ( quot -- ) + site-watcher-path swap with-db ; inline + +TUPLE: account account-id email ; + +: ( email -- account ) + account new + swap >>email ; + +account "ACCOUNT" { + { "account-id" "ACCOUNT_ID" +db-assigned-id+ } + { "email" "EMAIL" VARCHAR } +} define-persistent + +TUPLE: site site-id url up? changed? last-up error last-error ; + +: ( url -- site ) + site new + swap >>url ; + +site "SITE" { + { "site-id" "SITE_ID" INTEGER +db-assigned-id+ } + { "url" "URL" VARCHAR } + { "up?" "UP" BOOLEAN } + { "changed?" "CHANGED" BOOLEAN } + { "last-up" "LAST_UP" TIMESTAMP } + { "error" "ERROR" VARCHAR } + { "last-error" "LAST_ERROR" TIMESTAMP } +} define-persistent + +TUPLE: watching-site account-id site-id ; + +: ( account-id site-id -- watching-site ) + watching-site new + swap >>site-id + swap >>account-id ; + +watching-site "WATCHING_SITE" { + { "account-id" "ACCOUNT_ID" INTEGER +user-assigned-id+ } + { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } +} define-persistent diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor new file mode 100644 index 0000000000..d51fa02605 --- /dev/null +++ b/extra/site-watcher/site-watcher-tests.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: db.tuples locals site-watcher site-watcher.db ; +IN: site-watcher.tests + +:: fake-sites ( -- seq ) + [ + account ensure-table + site ensure-table + watching-site ensure-table + + "erg@factorcode.org" insert-account + "http://asdfasdfasdfasdfqwerqqq.com" insert-site + "http://fark.com" insert-site + + "erg@factorcode.org" "http://asdfasdfasdfasdfqwerqqq.com" watch-site + f select-tuples + ] with-sqlite-db ; + diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index 3697546243..c0c740f17e 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -1,68 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: db.sqlite db.types db.tuples kernel accessors -db io.files io.files.temp locals io.directories continuations -assocs sequences alarms namespaces http.client init calendar -math math.parser smtp strings io combinators arrays debugger -generalizations combinators.smart io.streams.string ; +USING: accessors alarms arrays calendar combinators +combinators.smart continuations db db.tuples debugger +http.client init io.streams.string kernel locals math +math.parser namespaces sequences site-watcher.db smtp ; IN: site-watcher -: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline - -[ site-watcher-path delete-file ] ignore-errors - -: with-sqlite-db ( quot -- ) - site-watcher-path swap with-db ; inline - -TUPLE: account account-id email ; - -: ( email -- account ) - account new - swap >>email ; - -account "ACCOUNT" { - { "account-id" "ACCOUNT_ID" +db-assigned-id+ } - { "email" "EMAIL" VARCHAR } -} define-persistent - -TUPLE: site site-id url up? changed? last-up error last-error ; - -: ( url -- site ) - site new - swap >>url ; - -site "SITE" { - { "site-id" "SITE_ID" INTEGER +db-assigned-id+ } - { "url" "URL" VARCHAR } - { "up?" "UP" BOOLEAN } - { "changed?" "CHANGED" BOOLEAN } - { "last-up" "LAST_UP" TIMESTAMP } - { "error" "ERROR" VARCHAR } - { "last-error" "LAST_ERROR" TIMESTAMP } -} define-persistent - -TUPLE: watching-site account-id site-id ; - -: ( account-id site-id -- watching-site ) - watching-site new - swap >>site-id - swap >>account-id ; - -watching-site "WATCHING_SITE" { - { "account-id" "ACCOUNT_ID" INTEGER +user-assigned-id+ } - { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } -} define-persistent - -: select-account/site ( email url -- account site ) - [ select-tuple account-id>> ] - [ select-tuple site-id>> ] bi* ; - -: watch-site ( email url -- ) - select-account/site insert-tuple ; - -: unwatch-site ( email url -- ) - select-account/site delete-tuples ; - SYMBOL: site-watcher-from "factor-site-watcher@gmail.com" site-watcher-from set-global @@ -70,6 +13,7 @@ SYMBOL: site-watcher-frequency 10 seconds site-watcher-frequency set-global SYMBOL: running-site-watcher +[ f running-site-watcher set-global ] "site-watcher" add-init-hook dup select-tuple [ + dup t >>up? insert-tuple + ] unless ; + PRIVATE> +: select-account/site ( email url -- account site ) + [ select-tuple account-id>> ] + [ insert-site site-id>> ] bi* ; + +: watch-site ( email url -- ) + select-account/site insert-tuple ; + +: unwatch-site ( email url -- ) + select-account/site delete-tuples ; + +: insert-account ( email -- ) insert-tuple ; + : watch-sites ( -- alarm ) [ [ @@ -131,12 +92,6 @@ PRIVATE> ] with-sqlite-db ] site-watcher-frequency get every ; -: watch-new-site ( url -- ) - t >>up? insert-tuple ; - -: insert-account ( email -- ) - insert-tuple ; - : run-site-watcher ( -- ) running-site-watcher get [ watch-sites running-site-watcher set-global @@ -144,20 +99,3 @@ PRIVATE> : stop-site-watcher ( -- ) running-site-watcher get [ cancel-alarm ] when* ; - -[ f running-site-watcher set-global ] "site-watcher" add-init-hook - - -:: fake-sites ( -- seq ) - [ - account ensure-table - site ensure-table - watching-site ensure-table - - "erg@factorcode.org" insert-account - "http://asdfasdfasdfasdfqwerqqq.com" watch-new-site - "http://fark.com" watch-new-site - - "erg@factorcode.org" "http://asdfasdfasdfasdfqwerqqq.com" watch-site - f select-tuples - ] with-sqlite-db ; From c1da74f179323c1dda181b09bf4327b9c88ca146 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 17:45:33 -0500 Subject: [PATCH 21/23] futher clean up api --- extra/site-watcher/site-watcher-tests.factor | 7 ++++--- extra/site-watcher/site-watcher.factor | 6 +++--- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor index d51fa02605..405b6cbb1e 100644 --- a/extra/site-watcher/site-watcher-tests.factor +++ b/extra/site-watcher/site-watcher-tests.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: db.tuples locals site-watcher site-watcher.db ; +USING: db.tuples locals site-watcher site-watcher.db +site-watcher.private kernel ; IN: site-watcher.tests :: fake-sites ( -- seq ) @@ -10,8 +11,8 @@ IN: site-watcher.tests watching-site ensure-table "erg@factorcode.org" insert-account - "http://asdfasdfasdfasdfqwerqqq.com" insert-site - "http://fark.com" insert-site + "http://asdfasdfasdfasdfqwerqqq.com" insert-site drop + "http://fark.com" insert-site drop "erg@factorcode.org" "http://asdfasdfasdfasdfqwerqqq.com" watch-site f select-tuples diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index c0c740f17e..aba2d12231 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -71,20 +71,20 @@ TUPLE: reporting-site email url up? changed? last-up? error last-error ; dup t >>up? insert-tuple ] unless ; -PRIVATE> +: insert-account ( email -- ) insert-tuple ; : select-account/site ( email url -- account site ) [ select-tuple account-id>> ] [ insert-site site-id>> ] bi* ; +PRIVATE> + : watch-site ( email url -- ) select-account/site insert-tuple ; : unwatch-site ( email url -- ) select-account/site delete-tuples ; -: insert-account ( email -- ) insert-tuple ; - : watch-sites ( -- alarm ) [ [ From 391d972b66e8efc6f3e9adc97cf79776fc27157f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 18:05:05 -0500 Subject: [PATCH 22/23] major refactoring of site-watcher again --- extra/site-watcher/db/db.factor | 52 +++++++++++++++--- extra/site-watcher/site-watcher-tests.factor | 7 +++ extra/site-watcher/site-watcher.factor | 55 +++----------------- 3 files changed, 57 insertions(+), 57 deletions(-) diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor index 3527f57074..3798b1ae94 100644 --- a/extra/site-watcher/db/db.factor +++ b/extra/site-watcher/db/db.factor @@ -1,16 +1,10 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors continuations db db.sqlite db.tuples db.types -io.directories io.files.temp kernel ; +io.directories io.files.temp kernel io.streams.string calendar +debugger combinators.smart sequences ; IN: site-watcher.db -: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline - -[ site-watcher-path delete-file ] ignore-errors - -: with-sqlite-db ( quot -- ) - site-watcher-path swap with-db ; inline - TUPLE: account account-id email ; : ( email -- account ) @@ -49,3 +43,45 @@ watching-site "WATCHING_SITE" { { "account-id" "ACCOUNT_ID" INTEGER +user-assigned-id+ } { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } } define-persistent + +: set-notify-site-watchers ( site new-up? -- site ) + [ over up?>> = [ t >>changed? ] unless ] keep >>up? ; + +: site-good ( site -- ) + t set-notify-site-watchers + now >>last-up + f >>error + f >>last-error + update-tuple ; + +: site-bad ( site error -- ) + [ error. ] with-string-writer >>error + f set-notify-site-watchers + now >>last-error + update-tuple ; + +TUPLE: reporting-site email url up? changed? last-up? error last-error ; + +: sites-to-report ( -- seq ) + "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_id = watching_site.account_id and site.site_id = watching_site.site_id and site.changed = '1'" sql-query + [ [ reporting-site boa ] input dup select-tuple [ + dup t >>up? insert-tuple + ] unless ; + +: insert-account ( email -- ) insert-tuple ; + +: find-sites ( -- seq ) f select-tuples ; + +: select-account/site ( email url -- account site ) + [ select-tuple account-id>> ] + [ insert-site site-id>> ] bi* ; + +: watch-site ( email url -- ) + select-account/site insert-tuple ; + +: unwatch-site ( email url -- ) + select-account/site delete-tuples ; diff --git a/extra/site-watcher/site-watcher-tests.factor b/extra/site-watcher/site-watcher-tests.factor index 405b6cbb1e..a19c954c25 100644 --- a/extra/site-watcher/site-watcher-tests.factor +++ b/extra/site-watcher/site-watcher-tests.factor @@ -4,6 +4,13 @@ USING: db.tuples locals site-watcher site-watcher.db site-watcher.private kernel ; IN: site-watcher.tests +: site-watcher-path ( -- path ) "site-watcher.db" temp-file ; inline + +[ site-watcher-path delete-file ] ignore-errors + +: with-sqlite-db ( quot -- ) + site-watcher-path swap with-db ; inline + :: fake-sites ( -- seq ) [ account ensure-table diff --git a/extra/site-watcher/site-watcher.factor b/extra/site-watcher/site-watcher.factor index aba2d12231..f47c38c50f 100644 --- a/extra/site-watcher/site-watcher.factor +++ b/extra/site-watcher/site-watcher.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alarms arrays calendar combinators -combinators.smart continuations db db.tuples debugger -http.client init io.streams.string kernel locals math -math.parser namespaces sequences site-watcher.db smtp ; +combinators.smart continuations debugger http.client +init io.streams.string kernel locals math math.parser +namespaces sequences site-watcher.db smtp ; IN: site-watcher SYMBOL: site-watcher-from @@ -17,22 +17,6 @@ SYMBOL: running-site-watcher > = [ t >>changed? ] unless ] keep >>up? ; - -: site-good ( site -- ) - t set-notify-site-watchers - now >>last-up - f >>error - f >>last-error - update-tuple ; - -: site-bad ( site error -- ) - [ error. ] with-string-writer >>error - f set-notify-site-watchers - now >>last-error - update-tuple ; - : check-sites ( seq -- ) [ [ dup url>> http-get 2drop site-good ] [ site-bad ] recover @@ -44,8 +28,7 @@ SYMBOL: running-site-watcher [ " hours, " append ] [ " minutes" append ] bi* append "Site was down for (at least): " prepend >>body ; -: site-down-email ( email site -- email ) - error>> >>body ; +: site-down-email ( email site -- email ) error>> >>body ; : send-report ( site -- ) [ ] dip @@ -56,40 +39,14 @@ SYMBOL: running-site-watcher [ [ url>> ] [ up?>> "up" "down" ? ] bi " is " glue >>subject ] } cleave send-email ; -: email-accounts ( seq -- ) +: send-reports ( seq -- ) [ ] [ [ send-report ] each ] if-empty ; -TUPLE: reporting-site email url up? changed? last-up? error last-error ; - -: report-sites ( -- ) - "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_id = watching_site.account_id and site.site_id = watching_site.site_id and site.changed = '1'" sql-query - [ [ reporting-site boa ] input dup select-tuple [ - dup t >>up? insert-tuple - ] unless ; - -: insert-account ( email -- ) insert-tuple ; - -: select-account/site ( email url -- account site ) - [ select-tuple account-id>> ] - [ insert-site site-id>> ] bi* ; - PRIVATE> -: watch-site ( email url -- ) - select-account/site insert-tuple ; - -: unwatch-site ( email url -- ) - select-account/site delete-tuples ; - : watch-sites ( -- alarm ) [ - [ - f select-tuples check-sites report-sites - ] with-sqlite-db + find-sites check-sites sites-to-report send-reports ] site-watcher-frequency get every ; : run-site-watcher ( -- ) From 87997cc0d2a9b570167471cecb52e8d9296a82f5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 18 Mar 2009 18:06:00 -0500 Subject: [PATCH 23/23] slightly bettar --- extra/site-watcher/db/db.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/site-watcher/db/db.factor b/extra/site-watcher/db/db.factor index 3798b1ae94..6a861ef747 100644 --- a/extra/site-watcher/db/db.factor +++ b/extra/site-watcher/db/db.factor @@ -44,6 +44,10 @@ watching-site "WATCHING_SITE" { { "site-id" "SITE_ID" INTEGER +user-assigned-id+ } } define-persistent +TUPLE: reporting-site email url up? changed? last-up? error last-error ; + +> = [ t >>changed? ] unless ] keep >>up? ; @@ -60,8 +64,6 @@ watching-site "WATCHING_SITE" { now >>last-error update-tuple ; -TUPLE: reporting-site email url up? changed? last-up? error last-error ; - : sites-to-report ( -- seq ) "select account.email, site.url, site.up, site.changed, site.last_up, site.error, site.last_error from account, site, watching_site where account.account_id = watching_site.account_id and site.site_id = watching_site.site_id and site.changed = '1'" sql-query [ [ reporting-site boa ] input select-tuple account-id>> ] [ insert-site site-id>> ] bi* ; +PRIVATE> + : watch-site ( email url -- ) select-account/site insert-tuple ;