From e9e40289999b1e8e9148ced6d6504113e6f271e7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 11:01:58 -0500 Subject: [PATCH 01/35] remove 1+ a couple places, working on compile errors --- extra/advice/advice-tests.factor | 4 ++-- extra/advice/advice.factor | 12 +++++++++--- extra/webapps/counter/counter.factor | 4 ++-- 3 files changed, 13 insertions(+), 7 deletions(-) diff --git a/extra/advice/advice-tests.factor b/extra/advice/advice-tests.factor index a141489a0f..396687e733 100644 --- a/extra/advice/advice-tests.factor +++ b/extra/advice/advice-tests.factor @@ -25,7 +25,7 @@ IN: advice.tests foo ] unit-test - : bar ( a -- b ) 1+ ; + : bar ( a -- b ) 1 + ; \ bar make-advised { 11 } [ @@ -91,4 +91,4 @@ IN: advice.tests ! [ 3 5 quux ] with-string-writer"> eval ! ] unit-test -] with-scope \ No newline at end of file +] with-scope diff --git a/extra/advice/advice.factor b/extra/advice/advice.factor index 9c0963469e..44280456c1 100644 --- a/extra/advice/advice.factor +++ b/extra/advice/advice.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences fry words assocs linked-assocs tools.annotations -coroutines lexer parser quotations arrays namespaces continuations ; +coroutines lexer parser quotations arrays namespaces continuations +summary ; IN: advice SYMBOLS: before after around advised in-advice? ; @@ -45,8 +46,13 @@ PRIVATE> : remove-advice ( name word loc -- ) word-prop delete-at ; +ERROR: ad-do-it-error ; + +M: ad-do-it-error summary + drop "ad-do-it should only be called inside 'around' advice" ; + : ad-do-it ( input -- result ) - in-advice? get [ "ad-do-it should only be called inside 'around' advice" throw ] unless coyield ; + in-advice? get [ ad-do-it-error ] unless coyield ; : make-advised ( word -- ) [ dup '[ [ _ ] dip over dup '[ _ call-before _ _ call-around _ call-after ] ] annotate ] @@ -60,4 +66,4 @@ SYNTAX: ADVISE: ! word adname location => word adname quot loc scan-word scan scan-word parse-definition swap [ spin ] dip advise ; SYNTAX: UNADVISE: - scan-word parsed \ unadvise parsed ; \ No newline at end of file + scan-word parsed \ unadvise parsed ; diff --git a/extra/webapps/counter/counter.factor b/extra/webapps/counter/counter.factor index d62096fffc..2fa9b5fb1d 100644 --- a/extra/webapps/counter/counter.factor +++ b/extra/webapps/counter/counter.factor @@ -25,8 +25,8 @@ M: counter-app init-session* drop 0 count sset ; : ( -- responder ) counter-app new-dispatcher - [ 1+ ] "inc" add-responder - [ 1- ] "dec" add-responder + [ 1 + ] "inc" add-responder + [ 1 - ] "dec" add-responder "" add-responder ; ! Deployment example From d3c87db85f39b2b79f563da0f4b1c99b38974941 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 11:14:16 -0500 Subject: [PATCH 02/35] fixing compiler warnings --- extra/coroutines/coroutines.factor | 7 ++++--- extra/graph-theory/graph-theory.factor | 9 ++++----- .../numerical-integration/numerical-integration.factor | 8 ++++---- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor index 51276336e3..6b334822c0 100644 --- a/extra/coroutines/coroutines.factor +++ b/extra/coroutines/coroutines.factor @@ -19,9 +19,10 @@ TUPLE: coroutine resumecc exitcc originalcc ; : coresume ( v co -- result ) [ >>exitcc - resumecc>> call + resumecc>> call( -- ) #! At this point, the coroutine quotation must have terminated - #! normally (without calling coyield, coreset, or coterminate). This shouldn't happen. + #! normally (without calling coyield, coreset, or coterminate). + #! This shouldn't happen. f over ] callcc1 2nip ; @@ -47,4 +48,4 @@ TUPLE: coroutine resumecc exitcc originalcc ; : coreset ( v -- ) current-coro get dup originalcc>> >>resumecc - exitcc>> continue-with ; \ No newline at end of file + exitcc>> continue-with ; diff --git a/extra/graph-theory/graph-theory.factor b/extra/graph-theory/graph-theory.factor index b14832dc03..1b4224c864 100644 --- a/extra/graph-theory/graph-theory.factor +++ b/extra/graph-theory/graph-theory.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008 William Schlieper ! See http://factorcode.org/license.txt for BSD license. - -USING: kernel combinators fry continuations sequences arrays vectors assocs hashtables heaps namespaces ; - +USING: kernel combinators fry continuations sequences arrays +vectors assocs hashtables heaps namespaces ; IN: graph-theory MIXIN: graph @@ -35,7 +34,7 @@ M: graph num-vertices vertices length ; M: graph num-edges - [ vertices ] [ '[ _ adjlist length ] map sum ] bi ; + [ vertices ] [ '[ _ adjlist length ] sigma ] bi ; M: graph adjlist [ vertices ] [ swapd '[ _ swap _ adj? ] filter ] bi ; @@ -88,5 +87,5 @@ PRIVATE> : topological-sort ( graph -- seq/f ) dup dag? - [ V{ } swap [ drop ] [ prefix ] [ ] full-depth-first drop ] + [ V{ } clone swap [ drop ] [ prefix ] [ ] full-depth-first drop ] [ drop f ] if ; diff --git a/extra/math/numerical-integration/numerical-integration.factor b/extra/math/numerical-integration/numerical-integration.factor index 6b46ba0243..261f33c4f3 100644 --- a/extra/math/numerical-integration/numerical-integration.factor +++ b/extra/math/numerical-integration/numerical-integration.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel sequences namespaces make math math.ranges -math.vectors vectors ; +USING: kernel math math.ranges math.vectors namespaces +sequences ; IN: math.numerical-integration SYMBOL: num-steps @@ -15,7 +15,7 @@ SYMBOL: num-steps length 2 / 2 - { 2 4 } concat { 1 4 } { 1 } surround ; -: integrate-simpson ( from to f -- x ) +: integrate-simpson ( from to quot -- x ) [ setup-simpson-range dup ] dip map dup generate-simpson-weights - v. swap [ third ] keep first - 6 / * ; + v. swap [ third ] keep first - 6 / * ; inline From b994b9a4dc6b588c4fe693d951c861fae86966cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 11:14:41 -0500 Subject: [PATCH 03/35] move graph-theory to unmaintained: no unit tests and compile errors --- {extra => unmaintained}/graph-theory/authors.txt | 0 {extra => unmaintained}/graph-theory/graph-theory-docs.factor | 0 {extra => unmaintained}/graph-theory/graph-theory.factor | 0 {extra => unmaintained}/graph-theory/reversals/reversals.factor | 0 {extra => unmaintained}/graph-theory/sparse/sparse.factor | 0 {extra => unmaintained}/graph-theory/summary.txt | 0 {extra => unmaintained}/graph-theory/tags.txt | 0 7 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/graph-theory/authors.txt (100%) rename {extra => unmaintained}/graph-theory/graph-theory-docs.factor (100%) rename {extra => unmaintained}/graph-theory/graph-theory.factor (100%) rename {extra => unmaintained}/graph-theory/reversals/reversals.factor (100%) rename {extra => unmaintained}/graph-theory/sparse/sparse.factor (100%) rename {extra => unmaintained}/graph-theory/summary.txt (100%) rename {extra => unmaintained}/graph-theory/tags.txt (100%) diff --git a/extra/graph-theory/authors.txt b/unmaintained/graph-theory/authors.txt similarity index 100% rename from extra/graph-theory/authors.txt rename to unmaintained/graph-theory/authors.txt diff --git a/extra/graph-theory/graph-theory-docs.factor b/unmaintained/graph-theory/graph-theory-docs.factor similarity index 100% rename from extra/graph-theory/graph-theory-docs.factor rename to unmaintained/graph-theory/graph-theory-docs.factor diff --git a/extra/graph-theory/graph-theory.factor b/unmaintained/graph-theory/graph-theory.factor similarity index 100% rename from extra/graph-theory/graph-theory.factor rename to unmaintained/graph-theory/graph-theory.factor diff --git a/extra/graph-theory/reversals/reversals.factor b/unmaintained/graph-theory/reversals/reversals.factor similarity index 100% rename from extra/graph-theory/reversals/reversals.factor rename to unmaintained/graph-theory/reversals/reversals.factor diff --git a/extra/graph-theory/sparse/sparse.factor b/unmaintained/graph-theory/sparse/sparse.factor similarity index 100% rename from extra/graph-theory/sparse/sparse.factor rename to unmaintained/graph-theory/sparse/sparse.factor diff --git a/extra/graph-theory/summary.txt b/unmaintained/graph-theory/summary.txt similarity index 100% rename from extra/graph-theory/summary.txt rename to unmaintained/graph-theory/summary.txt diff --git a/extra/graph-theory/tags.txt b/unmaintained/graph-theory/tags.txt similarity index 100% rename from extra/graph-theory/tags.txt rename to unmaintained/graph-theory/tags.txt From e85d8c17ac2e4d6b854d12d360506ffb19bca93c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 11:21:30 -0500 Subject: [PATCH 04/35] fix compile error --- extra/4DNav/file-chooser/file-chooser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor index ad799f75c9..033ae755cb 100755 --- a/extra/4DNav/file-chooser/file-chooser.factor +++ b/extra/4DNav/file-chooser/file-chooser.factor @@ -111,7 +111,7 @@ file-chooser H{ : line-selected-action ( file-chooser -- ) dup list>> list-value dup directory? - [ fc-change-directory ] [ fc-load-file ] if ; + [ fc-change-directory ] [ fc-load-file ] if ; inline : present-dir-element ( element -- string ) [ name>> ] [ directory? ] bi [ "-> " prepend ] when ; From aad6a3d504d6a3bc7c177b5d605c1c6aba73b845 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 12:45:57 -0500 Subject: [PATCH 05/35] fixing compiler error in core --- core/classes/classes-tests.factor | 6 +- core/classes/mixin/mixin-tests.factor | 4 +- core/classes/tuple/parser/parser-tests.factor | 22 ++--- core/classes/tuple/tuple-tests.factor | 88 ++++++++--------- core/classes/union/union-tests.factor | 6 +- core/compiler/units/units-tests.factor | 4 +- core/generic/generic-tests.factor | 20 ++-- core/generic/standard/standard-tests.factor | 2 +- core/memory/memory-tests.factor | 2 +- core/parser/parser-tests.factor | 94 +++++++++---------- core/slots/slots-tests.factor | 4 +- core/vocabs/loader/loader-tests.factor | 2 +- core/words/alias/alias-tests.factor | 4 +- core/words/words-tests.factor | 24 ++--- 14 files changed, 141 insertions(+), 141 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 673c108b27..f5ea84afa5 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -29,10 +29,10 @@ M: method-forget-class method-forget-test ; ] unit-test ! Minor leak -[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval ] unit-test +[ ] [ "IN: classes.tests TUPLE: forget-me ;" (( -- )) eval ] unit-test [ ] [ f \ word set-global ] unit-test -[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval ] unit-test -[ ] [ "IN: classes.tests FORGET: forget-me" eval ] unit-test +[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tests FORGET: forget-me" (( -- )) eval ] unit-test [ 0 ] [ [ word? ] instances [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index 376eace4ed..1beafd003a 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -42,7 +42,7 @@ INSTANCE: integer mx1 [ t ] [ mx1 integer class<= ] unit-test [ t ] [ mx1 number class<= ] unit-test -"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval +"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" (( -- )) eval [ t ] [ array mx1 class<= ] unit-test [ f ] [ mx1 number class<= ] unit-test @@ -118,4 +118,4 @@ MIXIN: move-instance-declaration-mixin [ ] [ "IN: classes.mixin.tests.a" "move-mixin-test-1" parse-stream drop ] unit-test -[ { string } ] [ move-instance-declaration-mixin members ] unit-test \ No newline at end of file +[ { string } ] [ move-instance-declaration-mixin members ] unit-test diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 22b5784269..9d0c268add 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -50,20 +50,20 @@ TUPLE: test-8 { b integer read-only } ; DEFER: foo -[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval ] +[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" (( -- )) eval ] [ error>> invalid-slot-name? ] must-fail-with -[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval ] +[ "IN: classes.tuple.parser.tests TUPLE: foo :" (( -- )) eval ] [ error>> invalid-slot-name? ] must-fail-with -[ "IN: classes.tuple.parser.tests TUPLE: foo" eval ] +[ "IN: classes.tuple.parser.tests TUPLE: foo" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with 2 [ - [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval ] + [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" (( -- )) eval ] [ error>> no-initial-value? ] must-fail-with @@ -71,14 +71,14 @@ must-fail-with ] times 2 [ - [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval ] + [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" (( -- )) eval ] [ error>> bad-initial-value? ] must-fail-with [ f ] [ \ foo tuple-class? ] unit-test ] times -[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval ] +[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" (( -- )) eval ] [ error>> duplicate-slot-names? ] must-fail-with @@ -107,7 +107,7 @@ TUPLE: parsing-corner-case x ; " f" " 3" "}" - } "\n" join eval + } "\n" join (( -- tuple )) eval ] unit-test [ T{ parsing-corner-case f 3 } ] [ @@ -116,7 +116,7 @@ TUPLE: parsing-corner-case x ; "T{ parsing-corner-case" " { x 3 }" "}" - } "\n" join eval + } "\n" join (( -- tuple )) eval ] unit-test [ T{ parsing-corner-case f 3 } ] [ @@ -125,7 +125,7 @@ TUPLE: parsing-corner-case x ; "T{ parsing-corner-case {" " x 3 }" "}" - } "\n" join eval + } "\n" join (( -- tuple )) eval ] unit-test @@ -133,12 +133,12 @@ TUPLE: parsing-corner-case x ; { "USE: classes.tuple.parser.tests T{ parsing-corner-case" " { x 3 }" - } "\n" join eval + } "\n" join (( -- tuple )) eval ] [ error>> unexpected-eof? ] must-fail-with [ { "USE: classes.tuple.parser.tests T{ parsing-corner-case {" " x 3 }" - } "\n" join eval + } "\n" join (( -- tuple )) eval ] [ error>> unexpected-eof? ] must-fail-with diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 75d733b213..451420268d 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -27,7 +27,7 @@ C: redefinition-test [ t ] [ "redefinition-test" get redefinition-test? ] unit-test -"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval +"IN: classes.tuple.tests TUPLE: redefinition-test ;" (( -- )) eval [ t ] [ "redefinition-test" get redefinition-test? ] unit-test @@ -39,7 +39,7 @@ C: point [ ] [ 100 200 "p" set ] unit-test ! Use eval to sequence parsing explicitly -[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" (( -- )) eval ] unit-test [ 100 ] [ "p" get x>> ] unit-test [ 200 ] [ "p" get y>> ] unit-test @@ -51,7 +51,7 @@ C: point [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" (( -- )) eval ] unit-test [ 2 ] [ "p" get tuple-size ] unit-test @@ -89,7 +89,7 @@ C: empty [ t length ] [ object>> t eq? ] must-fail-with [ "" ] -[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval word name>> ] unit-test +[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" (( -- )) eval word name>> ] unit-test TUPLE: size-test a b c d ; @@ -102,7 +102,7 @@ GENERIC: ( a -- b ) TUPLE: yo-momma ; -[ ] [ "IN: classes.tuple.tests C: yo-momma" eval ] unit-test +[ ] [ "IN: classes.tuple.tests C: yo-momma" (( -- )) eval ] unit-test [ f ] [ \ generic? ] unit-test @@ -204,7 +204,7 @@ C: erg's-reshape-problem : cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ; : cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ; -[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" (( -- )) eval ] unit-test [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test @@ -281,13 +281,13 @@ test-server-slot-values ] unit-test [ - "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval + "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" (( -- )) eval ] must-fail ! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" (( -- )) eval ] unit-test [ f ] [ electronic-device laptop class<= ] unit-test [ t ] [ server electronic-device class<= ] unit-test @@ -303,17 +303,17 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" (( -- )) eval ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" (( -- )) eval ] unit-test test-laptop-slot-values test-server-slot-values -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" (( -- )) eval ] unit-test test-laptop-slot-values test-server-slot-values @@ -326,7 +326,7 @@ TUPLE: make-me-some-accessors voltage grounded? ; [ ] [ "laptop" get 220 >>voltage drop ] unit-test [ ] [ "server" get 110 >>voltage drop ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" (( -- )) eval ] unit-test test-laptop-slot-values test-server-slot-values @@ -334,7 +334,7 @@ test-server-slot-values [ 220 ] [ "laptop" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" (( -- )) eval ] unit-test test-laptop-slot-values test-server-slot-values @@ -343,7 +343,7 @@ test-server-slot-values [ 110 ] [ "server" get voltage>> ] unit-test ! Reshaping superclass and subclass simultaneously -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" (( -- )) eval ] unit-test test-laptop-slot-values test-server-slot-values @@ -364,11 +364,11 @@ C: test2 test-a/b -[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" (( -- )) eval ] unit-test test-a/b -[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" (( -- )) eval ] unit-test test-a/b @@ -393,19 +393,19 @@ T{ move-up-2 f "a" "b" "c" } "move-up" set test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" (( -- )) eval ] unit-test test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" (( -- )) eval ] unit-test test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" (( -- )) eval ] unit-test test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" (( -- )) eval ] unit-test ! Constructors must be recompiled when changing superclass TUPLE: constructor-update-1 xxx ; @@ -416,7 +416,7 @@ C: constructor-update-2 { 3 1 } [ ] must-infer-as -[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" (( -- )) eval ] unit-test { 5 1 } [ ] must-infer-as @@ -431,7 +431,7 @@ UNION: redefinition-problem' redefinition-problem integer ; TUPLE: redefinition-problem-2 ; -"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval +"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" (( -- )) eval [ t ] [ 3 redefinition-problem'? ] unit-test @@ -472,7 +472,7 @@ USE: vocabs ] with-compilation-unit ] unit-test -[ "USE: words T{ word }" eval ] +[ "USE: words T{ word }" (( -- )) eval ] [ error>> T{ no-method f word new } = ] must-fail-with @@ -485,7 +485,7 @@ must-fail-with [ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test -: accessor-exists? ( class name -- ? ) +: accessor-exists? ( name -- ? ) [ "forget-accessors-test" "classes.tuple.tests" lookup ] dip ">>" append "accessors" lookup method >boolean ; @@ -520,13 +520,13 @@ TUPLE: another-forget-accessors-test ; [ f ] [ t parser-notes? [ [ - "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval + "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" (( -- )) eval ] with-string-writer empty? ] with-variable ] unit-test ! Missing error check -[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail +[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" (( -- )) eval ] must-fail ! Class forget messyness TUPLE: subclass-forget-test ; @@ -535,7 +535,7 @@ TUPLE: subclass-forget-test-1 < subclass-forget-test ; TUPLE: subclass-forget-test-2 < subclass-forget-test ; TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ; -[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test +[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" (( -- )) eval ] unit-test [ { subclass-forget-test-2 } ] [ subclass-forget-test-2 class-usages ] @@ -549,7 +549,7 @@ unit-test [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test [ subclass-forget-test-3 new ] must-fail -[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval ] must-fail +[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" (( -- )) eval ] must-fail ! More DEFER: subclass-reset-test @@ -562,11 +562,11 @@ GENERIC: break-me ( obj -- ) [ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" "subclass-reset-test" parse-stream drop ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" (( -- )) eval ] unit-test -[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" (( -- )) eval ] unit-test [ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" "subclass-reset-test" parse-stream drop ] unit-test @@ -576,7 +576,7 @@ GENERIC: break-me ( obj -- ) [ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test -[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" (( -- )) eval ] unit-test [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test @@ -632,7 +632,7 @@ TUPLE: reshape-test x ; T{ reshape-test f "hi" } "tuple" set -[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" (( -- )) eval ] unit-test [ f ] [ \ reshape-test \ (>>x) method ] unit-test @@ -640,11 +640,11 @@ T{ reshape-test f "hi" } "tuple" set [ "hi" ] [ "tuple" get x>> ] unit-test -[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" (( -- )) eval ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test -[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" (( -- )) eval ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test @@ -660,20 +660,20 @@ ERROR: error-class-test a b c ; [ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test [ f ] [ \ error-class-test "inline" word-prop ] unit-test -[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval ] +[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" (( -- )) eval ] [ error>> error>> redefine-error? ] must-fail-with DEFER: error-y [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test -[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval ] unit-test +[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" (( -- )) eval ] unit-test [ f ] [ \ error-y tuple-class? ] unit-test [ t ] [ \ error-y generic? ] unit-test -[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" (( -- )) eval ] unit-test [ t ] [ \ error-y tuple-class? ] unit-test @@ -694,7 +694,7 @@ DEFER: error-y ] unit-test [ ] [ - "IN: sequences TUPLE: reversed { seq read-only } ;" eval + "IN: sequences TUPLE: reversed { seq read-only } ;" (( -- )) eval ] unit-test TUPLE: bogus-hashcode-1 x ; @@ -735,14 +735,14 @@ SLOT: kex DEFER: redefine-tuple-twice -[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" (( -- )) eval ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test -[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval ] unit-test +[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" (( -- )) eval ] unit-test [ t ] [ \ redefine-tuple-twice deferred? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" (( -- )) eval ] unit-test -[ t ] [ \ redefine-tuple-twice symbol? ] unit-test \ No newline at end of file +[ t ] [ \ redefine-tuple-twice symbol? ] unit-test diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor index 57b742595f..47f726c03b 100644 --- a/core/classes/union/union-tests.factor +++ b/core/classes/union/union-tests.factor @@ -26,13 +26,13 @@ M: union-1 generic-update-test drop "union-1" ; [ t ] [ union-1 number class<= ] unit-test [ "union-1" ] [ 1.0 generic-update-test ] unit-test -"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval +"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" (( -- )) eval [ t ] [ bignum union-1 class<= ] unit-test [ f ] [ union-1 number class<= ] unit-test [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test -"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval +"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" (( -- )) eval [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test @@ -58,7 +58,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; [ t ] [ fixnum redefine-bug-2 class<= ] unit-test [ t ] [ quotation redefine-bug-2 class<= ] unit-test -[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval ] unit-test +[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" (( -- )) eval ] unit-test [ t ] [ bignum redefine-bug-1 class<= ] unit-test [ f ] [ fixnum redefine-bug-2 class<= ] unit-test diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index 464e17025d..d3a390dc56 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -56,6 +56,6 @@ observer add-definition-observer DEFER: nesting-test -[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval ] unit-test +[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" (( -- )) eval ] unit-test -observer remove-definition-observer \ No newline at end of file +observer remove-definition-observer diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index f28332353e..d0a7b28bc6 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -65,11 +65,11 @@ M: number union-containment drop 2 ; [ 2 ] [ 1.0 union-containment ] unit-test ! Testing recovery from bad method definitions -"IN: generic.tests GENERIC: unhappy ( x -- x )" eval +"IN: generic.tests GENERIC: unhappy ( x -- x )" (( -- )) eval [ - "IN: generic.tests M: dictionary unhappy ;" eval + "IN: generic.tests M: dictionary unhappy ;" (( -- )) eval ] must-fail -[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test +[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" (( -- )) eval ] unit-test GENERIC# complex-combination 1 ( a b -- c ) M: string complex-combination drop ; @@ -177,7 +177,7 @@ M: f generic-forget-test-3 ; [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test +[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" (( -- )) eval ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test @@ -193,7 +193,7 @@ M: integer a-generic a-word ; [ t ] [ "m" get \ a-word usage memq? ] unit-test -[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval ] unit-test +[ ] [ "IN: generic.tests : a-generic ( -- ) ;" (( -- )) eval ] unit-test [ f ] [ "m" get \ a-word usage memq? ] unit-test @@ -207,25 +207,25 @@ M: integer a-generic a-word ; M: boii jeah ; GENERIC: jeah* ( a -- b ) M: boii jeah* jeah ; - "> eval + "> (( -- )) eval <" IN: compiler.tests FORGET: boii - "> eval + "> (( -- )) eval <" IN: compiler.tests TUPLE: boii ; M: boii jeah ; - "> eval + "> (( -- )) eval ] unit-test ! call-next-method cache test GENERIC: c-n-m-cache ( a -- b ) ! Force it to be unoptimized -M: fixnum c-n-m-cache { } [ ] like call call-next-method ; +M: fixnum c-n-m-cache { } [ ] like call( -- ) call-next-method ; M: integer c-n-m-cache 1 + ; M: number c-n-m-cache ; @@ -244,4 +244,4 @@ GENERIC: move-method-generic ( a -- b ) [ ] [ "IN: generic.tests.a" "move-method-test-1" parse-stream drop ] unit-test -[ { string } ] [ \ move-method-generic order ] unit-test \ No newline at end of file +[ { string } ] [ \ move-method-generic order ] unit-test diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index a6269135f4..420dd16991 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -66,7 +66,7 @@ M: circle area radius>> sq pi * ; GENERIC: perimiter ( shape -- n ) -: rectangle-perimiter ( n -- n ) + 2 * ; +: rectangle-perimiter ( l w -- n ) + 2 * ; M: rectangle perimiter [ width>> ] [ height>> ] bi diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index 995c7e6064..670c21d6ff 100644 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -15,7 +15,7 @@ IN: memory.tests [ [ ] instances ] must-infer ! Code GC wasn't kicking in when needed -: leak-step ( -- ) 800000 f 1quotation call drop ; +: leak-step ( -- ) 800000 f 1quotation call( -- obj ) drop ; : leak-loop ( -- ) 100 [ leak-step ] times ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 9e1fcb95bd..491bc1884a 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -10,43 +10,43 @@ IN: parser.tests [ [ 1 [ 2 [ 3 ] 4 ] 5 ] - [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ] + [ "1\n[\n2\n[\n3\n]\n4\n]\n5" (( -- a b c )) eval ] unit-test [ t t f f ] - [ "t t f f" eval ] + [ "t t f f" (( -- ? ? ? ? )) eval ] unit-test [ "hello world" ] - [ "\"hello world\"" eval ] + [ "\"hello world\"" (( -- string )) eval ] unit-test [ "\n\r\t\\" ] - [ "\"\\n\\r\\t\\\\\"" eval ] + [ "\"\\n\\r\\t\\\\\"" (( -- string )) eval ] unit-test [ "hello world" ] [ "IN: parser.tests : hello ( -- str ) \"hello world\" ;" - eval "USE: parser.tests hello" eval + (( -- )) eval "USE: parser.tests hello" (( -- string )) eval ] unit-test [ ] - [ "! This is a comment, people." eval ] + [ "! This is a comment, people." (( -- )) eval ] unit-test ! Test escapes [ " " ] - [ "\"\\u000020\"" eval ] + [ "\"\\u000020\"" (( -- string )) eval ] unit-test [ "'" ] - [ "\"\\u000027\"" eval ] + [ "\"\\u000027\"" (( -- string )) eval ] unit-test ! Test EOL comments in multiline strings. - [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test + [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" (( -- string )) eval ] unit-test [ word ] [ \ f class ] unit-test @@ -68,7 +68,7 @@ IN: parser.tests [ \ baz "declared-effect" word-prop terminated?>> ] unit-test - [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval ] unit-test + [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" (( -- )) eval ] unit-test [ t ] [ "effect-parsing-test" "parser.tests" lookup @@ -79,14 +79,14 @@ IN: parser.tests [ \ effect-parsing-test "declared-effect" word-prop ] unit-test ! Funny bug - [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval ] unit-test + [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." (( -- n )) eval ] unit-test - [ "IN: parser.tests : missing-- ( a b ) ;" eval ] must-fail + [ "IN: parser.tests : missing-- ( a b ) ;" (( -- )) eval ] must-fail ! These should throw errors - [ "HEX: zzz" eval ] must-fail - [ "OCT: 999" eval ] must-fail - [ "BIN: --0" eval ] must-fail + [ "HEX: zzz" (( -- obj )) eval ] must-fail + [ "OCT: 999" (( -- obj )) eval ] must-fail + [ "BIN: --0" (( -- obj )) eval ] must-fail ! Another funny bug [ t ] [ @@ -102,14 +102,14 @@ IN: parser.tests ] unit-test DEFER: foo - "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval + "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" (( -- )) eval - [ ] [ "USE: parser.tests foo" eval ] unit-test + [ ] [ "USE: parser.tests foo" (( -- )) eval ] unit-test - "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval + "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" (( -- )) eval [ t ] [ - "USE: parser.tests \\ foo" eval + "USE: parser.tests \\ foo" (( -- word )) eval "foo" "parser.tests" lookup eq? ] unit-test @@ -269,12 +269,12 @@ IN: parser.tests ] unit-test [ ] [ - "IN: parser.tests : ( -- ) ; : bogus ( -- ) ;" + "IN: parser.tests : ( -- ) ; : bogus ( -- error ) ;" "bogus-error" parse-stream drop ] unit-test [ ] [ - "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ( -- ) ;" + "IN: parser.tests TUPLE: bogus-error ; C: bogus-error : bogus ( -- error ) ;" "bogus-error" parse-stream drop ] unit-test @@ -339,16 +339,16 @@ IN: parser.tests ] [ error>> error>> error>> redefine-error? ] must-fail-with [ ] [ - "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" (( -- )) eval ] unit-test [ - "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval + "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" (( -- )) eval ] must-fail ] with-file-vocabs [ ] [ - "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval + "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" (( -- )) eval ] unit-test [ t ] [ @@ -422,31 +422,31 @@ IN: parser.tests ] unit-test [ - "USE: this-better-not-exist" eval + "USE: this-better-not-exist" (( -- )) eval ] must-fail -[ ": foo ;" eval ] [ error>> error>> no-current-vocab? ] must-fail-with +[ ": foo ;" (( -- )) eval ] [ error>> error>> no-current-vocab? ] must-fail-with -[ 92 ] [ "CHAR: \\" eval ] unit-test -[ 92 ] [ "CHAR: \\\\" eval ] unit-test +[ 92 ] [ "CHAR: \\" (( -- n )) eval ] unit-test +[ 92 ] [ "CHAR: \\\\" (( -- n )) eval ] unit-test [ ] [ { "IN: parser.tests" - "USING: math arrays ;" - "GENERIC: change-combination ( a -- b )" - "M: integer change-combination 1 ;" - "M: array change-combination 2 ;" + "USING: math arrays kernel ;" + "GENERIC: change-combination ( obj a -- b )" + "M: integer change-combination 2drop 1 ;" + "M: array change-combination 2drop 2 ;" } "\n" join "change-combination-test" parse-stream drop ] unit-test [ ] [ { "IN: parser.tests" - "USING: math arrays ;" - "GENERIC# change-combination 1 ( a -- b )" - "M: integer change-combination 1 ;" - "M: array change-combination 2 ;" + "USING: math arrays kernel ;" + "GENERIC# change-combination 1 ( obj a -- b )" + "M: integer change-combination 2drop 1 ;" + "M: array change-combination 2drop 2 ;" } "\n" join "change-combination-test" parse-stream drop ] unit-test @@ -463,7 +463,7 @@ IN: parser.tests ] unit-test [ [ ] ] [ - "IN: parser.tests : staging-problem-test-1 ( -- ) 1 ; : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" + "IN: parser.tests : staging-problem-test-1 ( -- a ) 1 ; : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;" "staging-problem-test" parse-stream ] unit-test @@ -472,7 +472,7 @@ IN: parser.tests [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test [ [ ] ] [ - "IN: parser.tests << : staging-problem-test-1 ( -- ) 1 ; >> : staging-problem-test-2 ( -- ) staging-problem-test-1 ;" + "IN: parser.tests << : staging-problem-test-1 ( -- a ) 1 ; >> : staging-problem-test-2 ( -- a ) staging-problem-test-1 ;" "staging-problem-test" parse-stream ] unit-test @@ -480,10 +480,10 @@ IN: parser.tests [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test -[ "DEFER: blahy" eval ] [ error>> error>> no-current-vocab? ] must-fail-with +[ "DEFER: blahy" (( -- )) eval ] [ error>> error>> no-current-vocab? ] must-fail-with [ - "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval + "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" (( -- )) eval ] [ error>> staging-violation? ] must-fail-with @@ -491,12 +491,12 @@ IN: parser.tests ! Bogus error message DEFER: blahy -[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval ] +[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" (( -- )) eval ] [ error>> error>> def>> \ blahy eq? ] must-fail-with [ ] [ f lexer set f file set "Hello world" note. ] unit-test -[ "CHAR: \\u9999999999999" eval ] must-fail +[ "CHAR: \\u9999999999999" (( -- n )) eval ] must-fail SYMBOLS: a b c ; @@ -506,15 +506,15 @@ SYMBOLS: a b c ; DEFER: blah -[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval ] unit-test -[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval ] unit-test +[ ] [ "IN: parser.tests GENERIC: blah ( -- )" (( -- )) eval ] unit-test +[ ] [ "IN: parser.tests SYMBOLS: blah ;" (( -- )) eval ] unit-test [ f ] [ \ blah generic? ] unit-test [ t ] [ \ blah symbol? ] unit-test DEFER: blah1 -[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval ] +[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" (( -- )) eval ] [ error>> error>> def>> \ blah1 eq? ] must-fail-with @@ -545,10 +545,10 @@ EXCLUDE: qualified.tests.bar => x ; [ 3 ] [ x ] unit-test [ 4 ] [ y ] unit-test -[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval ] +[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" (( -- )) eval ] [ error>> no-word-error? ] must-fail-with -[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ] +[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" (( -- )) eval ] [ error>> no-word-error? ] must-fail-with ! Two similar bugs diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index 767cec4830..d76f1ffb07 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -25,12 +25,12 @@ TUPLE: hello length ; [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test ! See if declarations are cleared on redefinition -[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval ] unit-test +[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" (( -- )) eval ] unit-test [ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test -[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval ] unit-test +[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" (( -- )) eval ] unit-test [ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 87531caee4..b43ab08c2c 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -143,7 +143,7 @@ IN: vocabs.loader.tests forget-junk [ { } ] [ - "IN: xabbabbja" eval "xabbabbja" vocab-files + "IN: xabbabbja" (( -- )) eval "xabbabbja" vocab-files ] unit-test [ "xabbabbja" forget-vocab ] with-compilation-unit diff --git a/core/words/alias/alias-tests.factor b/core/words/alias/alias-tests.factor index 0278a4d4b9..e0bfba5cc1 100644 --- a/core/words/alias/alias-tests.factor +++ b/core/words/alias/alias-tests.factor @@ -2,5 +2,5 @@ USING: math eval tools.test effects ; IN: words.alias.tests ALIAS: foo + -[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test -[ (( -- value )) ] [ \ foo stack-effect ] unit-test \ No newline at end of file +[ ] [ "IN: words.alias.tests CONSTANT: foo 5" (( -- )) eval ] unit-test +[ (( -- value )) ] [ \ foo stack-effect ] unit-test diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 305541119b..7eb1025039 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -6,7 +6,7 @@ IN: words.tests [ 4 ] [ [ - "poo" "words.tests" create [ 2 2 + ] define + "poo" "words.tests" create [ 2 2 + ] (( -- n )) define-declared ] with-compilation-unit "poo" "words.tests" lookup execute ] unit-test @@ -51,7 +51,7 @@ SYMBOL: a-symbol ! See if redefining a generic as a colon def clears some ! word props. GENERIC: testing ( a -- b ) -"IN: words.tests : testing ( -- ) ;" eval +"IN: words.tests : testing ( -- ) ;" (( -- )) eval [ f ] [ \ testing generic? ] unit-test @@ -88,7 +88,7 @@ DEFER: calls-a-gensym [ \ calls-a-gensym gensym dup "x" set 1quotation - define + (( x -- x )) define-declared ] with-compilation-unit ] unit-test @@ -116,10 +116,10 @@ DEFER: x [ ] [ "no-loc" "words.tests" create drop ] unit-test [ f ] [ "no-loc" "words.tests" lookup where ] unit-test -[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" (( -- )) eval ] unit-test [ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test -[ ] [ "IN: words.tests : test-last ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : test-last ( -- ) ;" (( -- )) eval ] unit-test [ "test-last" ] [ word name>> ] unit-test ! regression @@ -146,15 +146,15 @@ SYMBOL: quot-uses-b [ forget ] with-compilation-unit ] when* -[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval ] +[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" (( -- )) eval ] [ error>> undefined? ] must-fail-with [ ] [ - "IN: words.tests GENERIC: symbol-generic ( -- )" eval + "IN: words.tests GENERIC: symbol-generic ( -- )" (( -- )) eval ] unit-test [ ] [ - "IN: words.tests SYMBOL: symbol-generic" eval + "IN: words.tests SYMBOL: symbol-generic" (( -- )) eval ] unit-test [ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test @@ -174,14 +174,14 @@ SYMBOL: quot-uses-b [ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test ! Regressions -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" (( -- )) eval ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" (( -- )) eval ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" (( -- )) eval ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" (( -- )) eval ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ { } ] From dba4c0d58952b196e5eecb681dd8a0e23d939d5b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 12:46:04 -0500 Subject: [PATCH 06/35] fixing compiler errors in basis --- basis/compiler/tests/folding.factor | 4 +-- basis/compiler/tests/redefine1.factor | 12 ++++---- basis/compiler/tests/redefine10.factor | 4 +-- basis/compiler/tests/redefine11.factor | 2 +- basis/compiler/tests/redefine12.factor | 2 +- basis/compiler/tests/redefine2.factor | 2 +- basis/compiler/tests/redefine3.factor | 2 +- basis/compiler/tests/redefine4.factor | 2 +- basis/compiler/tests/redefine5.factor | 4 +-- basis/compiler/tests/redefine6.factor | 4 +-- basis/compiler/tests/redefine7.factor | 4 +-- basis/compiler/tests/redefine8.factor | 4 +-- basis/compiler/tests/redefine9.factor | 4 +-- basis/compiler/tests/simple.factor | 2 +- .../tree/cleanup/cleanup-tests.factor | 4 +-- .../normalization/normalization-tests.factor | 12 ++++---- .../tree/propagation/propagation-tests.factor | 4 +-- .../tree/recursive/recursive-tests.factor | 2 +- basis/delegate/delegate-tests.factor | 12 ++++---- basis/fry/fry-tests.factor | 2 +- basis/help/crossref/crossref-tests.factor | 4 +-- .../help/definitions/definitions-tests.factor | 2 +- basis/help/syntax/syntax-tests.factor | 4 +-- basis/help/topics/topics-tests.factor | 2 +- basis/listener/listener-tests.factor | 4 +-- basis/locals/locals-tests.factor | 28 +++++++++---------- basis/macros/macros-tests.factor | 4 +-- basis/memoize/memoize-tests.factor | 4 +-- basis/peg/ebnf/ebnf-tests.factor | 10 +++---- basis/prettyprint/prettyprint-tests.factor | 26 ++++++++--------- basis/regexp/parser/parser-tests.factor | 2 +- basis/regexp/regexp-tests.factor | 6 ++-- .../stack-checker/stack-checker-tests.factor | 6 ++-- .../annotations/annotations-tests.factor | 4 +-- 34 files changed, 96 insertions(+), 98 deletions(-) diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor index d6868fd034..c2de317e83 100644 --- a/basis/compiler/tests/folding.factor +++ b/basis/compiler/tests/folding.factor @@ -12,7 +12,7 @@ IN: compiler.tests IN: compiler.tests.folding GENERIC: foldable-generic ( a -- b ) foldable M: integer foldable-generic f ; - "> eval + "> (( -- )) eval ] unit-test [ ] [ @@ -20,7 +20,7 @@ IN: compiler.tests USING: math arrays ; IN: compiler.tests.folding : fold-test ( -- x ) 10 foldable-generic ; - "> eval + "> (( -- )) eval ] unit-test [ t ] [ diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index 0875967bd2..db45c6af17 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ; [ 6 ] [ method-redefine-test-1 ] unit-test -[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test +[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" (( -- )) eval ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test @@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ; [ 6 ] [ method-redefine-test-2 ] unit-test -[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test +[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" (( -- )) eval ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test @@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ; [ t ] [ \ hey optimized>> ] unit-test [ t ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test +[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" (( -- )) eval ] unit-test [ f ] [ \ hey optimized>> ] unit-test [ f ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test +[ ] [ "IN: compiler.tests : hey ( -- ) ;" (( -- )) eval ] unit-test [ t ] [ \ there optimized>> ] unit-test : good ( -- ) ; @@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ; [ f ] [ \ good compiled-usage assoc-empty? ] unit-test -[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test +[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" (( -- )) eval ] unit-test [ f ] [ \ good optimized>> ] unit-test [ f ] [ \ bad optimized>> ] unit-test @@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ; [ t ] [ \ good compiled-usage assoc-empty? ] unit-test -[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test +[ ] [ "IN: compiler.tests : good ( -- ) ;" (( -- )) eval ] unit-test [ t ] [ \ good optimized>> ] unit-test [ t ] [ \ bad optimized>> ] unit-test diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index 8a6fb8a313..de14a068ab 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -13,7 +13,7 @@ IN: compiler.tests MIXIN: my-mixin INSTANCE: fixnum my-mixin : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; - "> eval + "> (( -- )) eval ] unit-test [ ] [ @@ -21,7 +21,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine10 INSTANCE: float my-mixin - "> eval + "> (( -- )) eval ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor index 18b1a3a430..2135d31606 100644 --- a/basis/compiler/tests/redefine11.factor +++ b/basis/compiler/tests/redefine11.factor @@ -17,7 +17,7 @@ IN: compiler.tests M: my-mixin my-generic drop 0 ; M: object my-generic drop 1 ; : my-inline ( -- b ) { } my-generic ; - "> eval + "> (( -- )) eval ] unit-test [ ] [ diff --git a/basis/compiler/tests/redefine12.factor b/basis/compiler/tests/redefine12.factor index 87dc4596e9..2ff16f0cca 100644 --- a/basis/compiler/tests/redefine12.factor +++ b/basis/compiler/tests/redefine12.factor @@ -15,6 +15,6 @@ M: object g drop t ; TUPLE: jeah ; -[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval ] unit-test +[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" (( -- )) eval ] unit-test [ f ] [ T{ jeah } h ] unit-test diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index 5a28b28261..b61f53d14c 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ; DEFER: redefine2-test -[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval ] unit-test +[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" (( -- )) eval ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index b25b5a1a5e..0835f8cfba 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ; [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test -[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval ] unit-test +[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" (( -- )) eval ] unit-test [ "wake up" ] [ sheeple-test ] unit-test [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 2f21777801..29d5da6394 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ; [ "" ] [ [ declaration-test ] with-string-writer ] unit-test -[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval ] unit-test +[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" (( -- )) eval ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor index ac1619b857..8db28b52d5 100644 --- a/basis/compiler/tests/redefine5.factor +++ b/basis/compiler/tests/redefine5.factor @@ -14,7 +14,7 @@ IN: compiler.tests GENERIC: my-generic ( a -- b ) M: object my-generic [ <=> ] sort ; : my-inline ( a -- b ) my-generic ; - "> eval + "> (( -- )) eval ] unit-test [ ] [ @@ -23,7 +23,7 @@ IN: compiler.tests IN: compiler.tests.redefine5 TUPLE: my-tuple ; M: my-tuple my-generic drop 0 ; - "> eval + "> (( -- )) eval ] unit-test [ 0 ] [ diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor index 73225c55b8..df9c35dc42 100644 --- a/basis/compiler/tests/redefine6.factor +++ b/basis/compiler/tests/redefine6.factor @@ -14,7 +14,7 @@ IN: compiler.tests MIXIN: my-mixin M: my-mixin my-generic drop 0 ; : my-inline ( a -- b ) { my-mixin } declare my-generic ; - "> eval + "> (( -- )) eval ] unit-test [ ] [ @@ -24,7 +24,7 @@ IN: compiler.tests TUPLE: my-tuple ; M: my-tuple my-generic drop 1 ; INSTANCE: my-tuple my-mixin - "> eval + "> (( -- )) eval ] unit-test [ 1 ] [ diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor index 164a2e3831..fd6d5a9564 100644 --- a/basis/compiler/tests/redefine7.factor +++ b/basis/compiler/tests/redefine7.factor @@ -13,7 +13,7 @@ IN: compiler.tests MIXIN: my-mixin INSTANCE: fixnum my-mixin : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; - "> eval + "> (( -- )) eval ] unit-test [ ] [ @@ -21,7 +21,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine7 INSTANCE: float my-mixin - "> eval + "> (( -- )) eval ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor index c8b3377632..8a8d832dbf 100644 --- a/basis/compiler/tests/redefine8.factor +++ b/basis/compiler/tests/redefine8.factor @@ -16,7 +16,7 @@ IN: compiler.tests ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> eval + "> (( -- )) eval ] unit-test [ ] [ @@ -24,7 +24,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine8 INSTANCE: float my-mixin - "> eval + "> (( -- )) eval ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor index 7b0f8a2e9c..63cf002cc9 100644 --- a/basis/compiler/tests/redefine9.factor +++ b/basis/compiler/tests/redefine9.factor @@ -16,7 +16,7 @@ IN: compiler.tests ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> eval + "> (( -- )) eval ] unit-test [ ] [ @@ -25,7 +25,7 @@ IN: compiler.tests IN: compiler.tests.redefine9 TUPLE: my-tuple ; INSTANCE: my-tuple my-mixin - "> eval + "> (( -- )) eval ] unit-test [ diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index d53b864b06..23fee84ae2 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ; 10 [ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ t ] [ - "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval + "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" (( -- obj )) eval ] unit-test ] times diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 7de092d84a..c533f78916 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -197,7 +197,7 @@ M: fixnum annotate-entry-test-1 drop ; [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) ] if ; inline recursive -: annotate-entry-test-2 ( from to -- ) 0 -rot (annotate-entry-test-2) ; inline +: annotate-entry-test-2 ( from to -- obj ) 0 -rot (annotate-entry-test-2) ; inline [ f ] [ [ { bignum } declare annotate-entry-test-2 ] @@ -519,4 +519,4 @@ cell-bits 32 = [ [ t ] [ [ { integer integer } declare + drop ] { + +-integer-integer } inlined? -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 5ac3c57abe..2097f4ebdd 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -17,7 +17,7 @@ sequences accessors tools.test kernel math ; [ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test -: foo ( -- ) swap ; inline recursive +: foo ( a b -- b a ) swap ; inline recursive : recursive-inputs ( nodes -- n ) [ #recursive? ] find nip child>> first in-d>> length ; @@ -34,18 +34,18 @@ sequences accessors tools.test kernel math ; [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test DEFER: bbb -: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive -: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive +: aaa ( obj x -- obj ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive +: bbb ( obj x -- obj ) [ drop 0 ] dip aaa ; inline recursive [ ] [ [ bbb ] test-normalization ] unit-test -: ccc ( -- ) ccc drop 1 ; inline recursive +: ccc ( obj -- 1 ) ccc drop 1 ; inline recursive [ ] [ [ ccc ] test-normalization ] unit-test DEFER: eee -: ddd ( -- ) eee ; inline recursive -: eee ( -- ) swap ddd ; inline recursive +: ddd ( a b -- a b ) eee ; inline recursive +: eee ( a b -- a b ) swap ddd ; inline recursive [ ] [ [ eee ] test-normalization ] unit-test diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 5dd647ae89..5b9b49811f 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -680,11 +680,11 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; : (littledan-3-test) ( x -- ) length 1+ f (littledan-3-test) ; inline recursive -: littledan-3-test ( x -- ) +: littledan-3-test ( -- ) 0 f (littledan-3-test) ; inline [ ] [ [ littledan-3-test ] final-classes drop ] unit-test [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test -[ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test \ No newline at end of file +[ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor index d548d58bc6..971675d367 100644 --- a/basis/compiler/tree/recursive/recursive-tests.factor +++ b/basis/compiler/tree/recursive/recursive-tests.factor @@ -57,7 +57,7 @@ compiler.tree.combinators ; \ (each-integer) label-is-loop? ] unit-test -: loop-test-2 ( a -- ) +: loop-test-2 ( a b -- a' ) dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive [ t ] [ diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index cf822b40a3..34ff4ba079 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -35,7 +35,7 @@ M: hello bing hello-test ; [ 3 ] [ 1 0 2 whoa ] unit-test [ 3 ] [ 1 0 f 2 whoa ] unit-test -[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test +[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" (( -- )) eval ] times ] unit-test [ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test @@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ; [ 0 ] [ 1 three ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test -[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test +[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" (( -- )) eval ] unit-test [ f ] [ hey \ two method ] unit-test [ f ] [ hey \ four method ] unit-test -[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test +[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" (( -- )) eval ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test [ 2 ] [ 1 one ] unit-test [ 0 ] [ 1 two ] unit-test [ 0 ] [ 1 three ] unit-test [ 0 ] [ 1 four ] unit-test -[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test +[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" (( -- )) eval ] unit-test [ 2 ] [ 1 one ] unit-test [ -1 ] [ 1 two ] unit-test [ -1 ] [ 1 three ] unit-test [ -1 ] [ 1 four ] unit-test -[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test +[ ] [ "IN: delegate.tests FORGET: alpha" (( -- )) eval ] unit-test [ f ] [ hey \ one method ] unit-test TUPLE: slot-protocol-test-1 a b ; @@ -196,4 +196,4 @@ DEFER: seq-delegate seq-delegate sequence-protocol \ protocol-consult word-prop key? -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index d240e6f233..89fbaf31b6 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -56,7 +56,7 @@ sequences eval accessors ; 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call ] unit-test -[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ] +[ "USING: fry locals.backend ; f '[ load-local _ ]" (( -- quot )) eval ] [ error>> >r/r>-in-fry-error? ] must-fail-with [ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [ diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 2e01330d73..44122a3a64 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays io.streams.string continuations debugger compiler.units eval ; [ ] [ - "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" (( -- )) eval ] unit-test [ $subsection ] [ @@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ; ] unit-test [ ] [ - "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" (( -- )) eval ] unit-test [ ] [ diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor index 7bb66eca02..783a95dd5c 100644 --- a/basis/help/definitions/definitions-tests.factor +++ b/basis/help/definitions/definitions-tests.factor @@ -32,7 +32,7 @@ IN: help.definitions.tests "hello" "help.definitions.tests" lookup "help" word-prop ] unit-test - [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval ] unit-test + [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" (( -- )) eval ] unit-test [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test diff --git a/basis/help/syntax/syntax-tests.factor b/basis/help/syntax/syntax-tests.factor index e7438edd4d..db94f53b01 100644 --- a/basis/help/syntax/syntax-tests.factor +++ b/basis/help/syntax/syntax-tests.factor @@ -4,12 +4,12 @@ IN: help.syntax.tests [ [ "foobar" ] [ - "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval + "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" (( -- )) eval "help.syntax.tests" vocab vocab-help ] unit-test [ { "foobar" } ] [ - "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval + "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" (( -- )) eval "help.syntax.tests" vocab vocab-help ] unit-test diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index f53bdee9c7..f4f17a10e5 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -29,7 +29,7 @@ SYMBOL: foo } "\n" join [ "testfile" source-file file set - eval + (( -- )) eval ] with-scope ] unit-test diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor index 0616794939..12b639c262 100644 --- a/basis/listener/listener-tests.factor +++ b/basis/listener/listener-tests.factor @@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ; "\\ + 1 2 3 4" parse-interactive "cont" get continue-with ] ignore-errors - "USE: debugger :1" eval + "USE: debugger :1" (( -- quot )) eval ] callcc1 ] unit-test ] with-file-vocabs @@ -50,7 +50,7 @@ SYNTAX: hello "Hi" print ; [ [ ] [ - "IN: listener.tests : hello ( -- )\n\"world\" ;" parse-interactive + "IN: listener.tests : hello ( -- string )\n\"world\" ;" parse-interactive drop ] unit-test ] with-file-vocabs diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 5e61c1ddfd..42ea3322f1 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -261,7 +261,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" -[ ] [ new-definition eval ] unit-test +[ ] [ new-definition (( -- )) eval ] unit-test [ t ] [ [ \ a-word-with-locals see ] with-string-writer @@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]" - eval call + (( -- )) eval call ] [ error>> >r/r>-in-fry-error? ] must-fail-with :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline @@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ f ] [ 2 funny-macro-test ] unit-test ! Some odd parser corner cases -[ "USE: locals [let" eval ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [let |" eval ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [let | a" eval ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [|" eval ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [let" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [let |" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [let | a" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [|" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test @@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ 3 ] [ 3 [| a | \ a ] call ] unit-test -[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail +[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail -[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail +[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail -[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail +[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail -[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail +[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" (( -- )) eval ] must-fail -[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail +[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" (( -- )) eval ] must-fail -[ "USE: locals [| | { :> a } ]" eval ] must-fail +[ "USE: locals [| | { :> a } ]" (( -- )) eval ] must-fail -[ "USE: locals 3 :> a" eval ] must-fail +[ "USE: locals 3 :> a" (( -- )) eval ] must-fail [ 3 ] [ 3 [| | :> a a ] call ] unit-test @@ -584,4 +584,4 @@ M: integer ed's-bug neg ; :: ed's-test-case ( a -- b ) { [ a ed's-bug ] } && ; -[ t ] [ \ ed's-test-case optimized>> ] unit-test \ No newline at end of file +[ t ] [ \ ed's-test-case optimized>> ] unit-test diff --git a/basis/macros/macros-tests.factor b/basis/macros/macros-tests.factor index 91aa6880e6..40b3d59b39 100644 --- a/basis/macros/macros-tests.factor +++ b/basis/macros/macros-tests.factor @@ -13,11 +13,11 @@ unit-test [ t ] [ \ see-test macro? ] unit-test [ t ] [ - "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval + "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup (( -- )) eval [ \ see-test see ] with-string-writer = ] unit-test [ f ] [ \ see-test macro? ] unit-test -[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval ] unit-test +[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" (( -- )) eval ] unit-test diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 54378bd37e..22b4406f32 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -9,7 +9,7 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail +[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" (( -- )) eval ] must-fail MEMO: see-test ( a -- b ) reverse ; @@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ; [ [ \ see-test see ] with-string-writer ] unit-test -[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval ] unit-test +[ ] [ "IN: memoize.tests : fib ( -- ) ;" (( -- )) eval ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index cc83a55c7e..cc414a798e 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -444,12 +444,12 @@ foo= 'd' "ad" parser4 ] unit-test -{ t } [ - "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF]" eval drop t +{ } [ + "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" (( -- )) eval ] unit-test [ - "USING: peg.ebnf ; " eval drop + "USING: peg.ebnf ; " (( -- )) eval drop ] must-fail { t } [ @@ -521,12 +521,12 @@ Tok = Spaces (Number | Special ) "\\" [EBNF foo="\\" EBNF] ] unit-test -[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail +[ "USE: peg.ebnf [EBNF EBNF]" (( -- )) eval ] must-fail [ <" USE: peg.ebnf [EBNF lol = a lol = b - EBNF] "> eval + EBNF] "> (( -- )) eval ] [ error>> [ redefined-rule? ] [ name>> "lol" = ] bi and ] must-fail-with diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 799d500c18..afec29ff61 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -90,7 +90,7 @@ unit-test [ \ blah see ] with-string-writer "\n" ?tail drop 6 tail* ] unit-test -: check-see ( expect name -- ) +: check-see ( expect name -- ? ) [ use [ clone ] change @@ -105,6 +105,7 @@ unit-test GENERIC: method-layout ( a -- b ) M: complex method-layout + drop "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" ; @@ -116,8 +117,9 @@ M: object method-layout ; [ { - "USING: math prettyprint.tests ;" + "USING: kernel math prettyprint.tests ;" "M: complex method-layout" + " drop" " \"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"" " ;" "" @@ -180,15 +182,15 @@ DEFER: parse-error-file "string-layout-test" string-layout check-see ] unit-test -: narrow-test ( -- str ) +: narrow-test ( -- array ) { "USING: arrays combinators continuations kernel sequences ;" "IN: prettyprint.tests" - ": narrow-layout ( obj -- )" + ": narrow-layout ( obj1 obj2 -- obj3 )" " {" " { [ dup continuation? ] [ append ] }" " { [ dup not ] [ drop reverse ] }" - " { [ dup pair? ] [ delete ] }" + " { [ dup pair? ] [ [ delete ] keep ] }" " } cond ;" } ; @@ -196,7 +198,7 @@ DEFER: parse-error-file "narrow-layout" narrow-test check-see ] unit-test -: another-narrow-test ( -- str ) +: another-narrow-test ( -- array ) { "IN: prettyprint.tests" ": another-narrow-layout ( -- obj )" @@ -252,19 +254,15 @@ M: class-see-layout class-see-layout ; ! Regression [ t ] [ "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n" - dup eval + dup (( -- )) eval "generic-decl-test" "prettyprint.tests" lookup [ see ] with-string-writer = ] unit-test -[ [ + ] ] [ - [ \ + (step-into-execute) ] (remove-breakpoints) -] unit-test - -[ [ (step-into-execute) ] ] [ - [ (step-into-execute) ] (remove-breakpoints) -] unit-test +[ [ + ] ] [ [ \ + (step-into-execute) ] (remove-breakpoints) ] unit-test +[ [ (step-into-execute) ] ] [ [ (step-into-execute) ] (remove-breakpoints) ] unit-test + [ [ 2 2 + . ] ] [ [ 2 2 \ + (step-into-execute) . ] (remove-breakpoints) ] unit-test diff --git a/basis/regexp/parser/parser-tests.factor b/basis/regexp/parser/parser-tests.factor index 5ea9753fba..0e12014eef 100644 --- a/basis/regexp/parser/parser-tests.factor +++ b/basis/regexp/parser/parser-tests.factor @@ -4,7 +4,7 @@ IN: regexp.parser.tests : regexp-parses ( string -- ) [ [ ] ] dip '[ _ parse-regexp drop ] unit-test ; -: regexp-fails ( string -- ) +: regexp-fails ( string -- regexp ) '[ _ parse-regexp ] must-fail ; { diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 2234386803..ae013a7719 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -262,11 +262,11 @@ IN: regexp-tests ! Comment inside a regular expression [ t ] [ "ac" "a(?#boo)c" matches? ] unit-test -[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval ] unit-test +[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" (( -- )) eval ] unit-test -[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval ] unit-test +[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" (( -- )) eval ] unit-test -[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval ] unit-test +[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" (( -- )) eval ] unit-test [ "ab" ] [ "ab" "(a|ab)(bc)?" first-match >string ] unit-test [ "abc" ] [ "abc" "(a|ab)(bc)?" first-match >string ] unit-test diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 117b6845b8..d8f61661d5 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -524,7 +524,7 @@ ERROR: custom-error ; { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval ] unit-test +[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" (( -- )) eval ] unit-test [ 3 ] [ inference-invalidation-c ] unit-test @@ -536,7 +536,7 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ; \ inference-invalidation-d must-infer -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval ] unit-test +[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" (( -- )) eval ] unit-test [ [ inference-invalidation-d ] infer ] must-fail @@ -587,4 +587,4 @@ DEFER: eee' [ forget-test ] must-infer [ ] [ [ \ forget-test forget ] with-compilation-unit ] unit-test -[ forget-test ] must-infer \ No newline at end of file +[ forget-test ] must-infer diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 9fa9d1e2aa..0c92cb567b 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -18,7 +18,7 @@ M: integer some-generic 1+ ; [ 4 ] [ 3 some-generic ] unit-test -[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval ] unit-test +[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" (( -- )) eval ] unit-test [ 2 ] [ 3 some-generic ] unit-test @@ -33,7 +33,7 @@ M: object another-generic ; \ another-generic watch -[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval ] unit-test +[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" (( -- )) eval ] unit-test [ ] [ \ another-generic reset ] unit-test From 364ea217efb9216cce934d131ecc39322ff3f84a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 14:44:08 -0500 Subject: [PATCH 07/35] fix more compiler errors --- .../exchangers/exchangers-tests.factor | 2 +- basis/concurrency/flags/flags-tests.factor | 2 +- basis/furnace/sessions/sessions-tests.factor | 4 ++-- basis/hash2/hash2-tests.factor | 2 +- basis/heaps/heaps-tests.factor | 2 +- basis/math/intervals/intervals-tests.factor | 18 +++++++++--------- basis/mirrors/mirrors-tests.factor | 2 +- .../hashtables/hashtables-tests.factor | 6 +++--- .../mersenne-twister-tests.factor | 2 +- basis/threads/threads-tests.factor | 2 +- basis/tools/deploy/shaker/shaker.factor | 6 +++--- core/combinators/combinators-tests.factor | 2 +- core/continuations/continuations-tests.factor | 4 ++-- core/kernel/kernel-tests.factor | 6 +++--- extra/lint/lint-tests.factor | 2 +- .../partial-continuations-tests.factor | 2 +- 16 files changed, 32 insertions(+), 32 deletions(-) diff --git a/basis/concurrency/exchangers/exchangers-tests.factor b/basis/concurrency/exchangers/exchangers-tests.factor index 569b1a72c2..3b5b014fe3 100644 --- a/basis/concurrency/exchangers/exchangers-tests.factor +++ b/basis/concurrency/exchangers/exchangers-tests.factor @@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers concurrency.count-downs concurrency.promises locals kernel threads ; -:: exchanger-test ( -- ) +:: exchanger-test ( -- string ) [let | ex [ ] c [ 2 ] diff --git a/basis/concurrency/flags/flags-tests.factor b/basis/concurrency/flags/flags-tests.factor index a666293316..05ff74b03f 100644 --- a/basis/concurrency/flags/flags-tests.factor +++ b/basis/concurrency/flags/flags-tests.factor @@ -11,7 +11,7 @@ kernel threads locals accessors calendar ; [ f ] [ flag-test-1 ] unit-test -:: flag-test-2 ( -- ) +:: flag-test-2 ( -- ? ) [let | f [ ] | [ 1 seconds sleep f raise-flag ] "Flag test" spawn drop f lower-flag diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor index b325c778cf..99855c76fa 100644 --- a/basis/furnace/sessions/sessions-tests.factor +++ b/basis/furnace/sessions/sessions-tests.factor @@ -22,7 +22,7 @@ M: foo call-responder* "x" [ 1+ ] schange "x" sget number>string "text/html" ; -: url-responder-mock-test ( -- ) +: url-responder-mock-test ( -- string ) [ "GET" >>method @@ -34,7 +34,7 @@ M: foo call-responder* [ write-response-body drop ] with-string-writer ] with-destructors ; -: sessions-mock-test ( -- ) +: sessions-mock-test ( -- string ) [ "GET" >>method diff --git a/basis/hash2/hash2-tests.factor b/basis/hash2/hash2-tests.factor index 6f97c7c3d5..15bbcb36ef 100644 --- a/basis/hash2/hash2-tests.factor +++ b/basis/hash2/hash2-tests.factor @@ -4,7 +4,7 @@ IN: hash2.tests [ t ] [ 1 2 { 1 2 } 2= ] unit-test [ f ] [ 1 3 { 1 2 } 2= ] unit-test -: sample-hash ( -- ) +: sample-hash ( -- hash ) 5 dup 2 3 "foo" roll set-hash2 dup 4 2 "bar" roll set-hash2 diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor index 7e780cbe5e..b476107562 100644 --- a/basis/heaps/heaps-tests.factor +++ b/basis/heaps/heaps-tests.factor @@ -54,7 +54,7 @@ IN: heaps.tests : sort-entries ( entries -- entries' ) [ [ key>> ] compare ] sort ; -: delete-test ( n -- ? ) +: delete-test ( n -- obj1 obj2 ) [ random-alist [ heap-push-all ] keep diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 378ca2fb4b..8b43456901 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -255,11 +255,11 @@ IN: math.intervals.tests 0 pick interval-contains? over first \ recip eq? and [ 2drop t ] [ - [ [ random-element ] dip first execute ] 2keep - second execute interval-contains? + [ [ random-element ] dip first execute( a -- b ) ] 2keep + second execute( a -- b ) interval-contains? ] if ; -[ t ] [ 80000 [ drop unary-test ] all? ] unit-test +[ t ] [ 80000 iota [ drop unary-test ] all? ] unit-test : random-binary-op ( -- pair ) { @@ -286,11 +286,11 @@ IN: math.intervals.tests 0 pick interval-contains? over first { / /i mod rem } member? and [ 3drop t ] [ - [ [ [ random-element ] bi@ ] dip first execute ] 3keep - second execute interval-contains? + [ [ [ random-element ] bi@ ] dip first execute( a b -- c ) ] 3keep + second execute( a b -- c ) interval-contains? ] if ; -[ t ] [ 80000 [ drop binary-test ] all? ] unit-test +[ t ] [ 80000 iota [ drop binary-test ] all? ] unit-test : random-comparison ( -- pair ) { @@ -305,7 +305,7 @@ IN: math.intervals.tests [ [ [ random-element ] bi@ ] dip first execute ] 3keep second execute dup incomparable eq? [ 2drop t ] [ = ] if ; -[ t ] [ 40000 [ drop comparison-test ] all? ] unit-test +[ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test [ t ] [ -10 10 [a,b] 0 100 [a,b] assume> 0 10 (a,b] = ] unit-test @@ -322,7 +322,7 @@ IN: math.intervals.tests [ t ] [ -10 10 [a,b] interval-abs 0 10 [a,b] = ] unit-test ! Test that commutative interval ops really are -: random-interval-or-empty ( -- ) +: random-interval-or-empty ( -- obj ) 10 random 0 = [ empty-interval ] [ random-interval ] if ; : random-commutative-op ( -- op ) @@ -333,7 +333,7 @@ IN: math.intervals.tests } random ; [ t ] [ - 80000 [ + 80000 iota [ drop random-interval-or-empty random-interval-or-empty random-commutative-op diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor index aad033600a..b5bac614ff 100644 --- a/basis/mirrors/mirrors-tests.factor +++ b/basis/mirrors/mirrors-tests.factor @@ -56,6 +56,6 @@ TUPLE: color ! Test reshaping with a mirror 1 2 3 color boa "mirror" set -[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval ] unit-test +[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" (( -- )) eval ] unit-test [ 1 ] [ "red" "mirror" get at ] unit-test diff --git a/basis/persistent/hashtables/hashtables-tests.factor b/basis/persistent/hashtables/hashtables-tests.factor index 5ed72e5d59..eea31dd34e 100644 --- a/basis/persistent/hashtables/hashtables-tests.factor +++ b/basis/persistent/hashtables/hashtables-tests.factor @@ -83,7 +83,7 @@ M: hash-0-b hashcode* 2drop 0 ; : random-string ( -- str ) 1000000 random ; ! [ CHAR: a CHAR: z [a,b] random ] "" replicate-as ; -: random-assocs ( -- hash phash ) +: random-assocs ( n -- hash phash ) [ random-string ] replicate [ H{ } clone [ '[ swap _ set-at ] each-index ] keep ] [ PH{ } clone swap [ spin new-at ] each-index ] @@ -92,7 +92,7 @@ M: hash-0-b hashcode* 2drop 0 ; : ok? ( assoc1 assoc2 -- ? ) [ assoc= ] [ [ assoc-size ] bi@ = ] 2bi and ; -: test-persistent-hashtables-1 ( n -- ) +: test-persistent-hashtables-1 ( n -- ? ) random-assocs ok? ; [ t ] [ 10 test-persistent-hashtables-1 ] unit-test @@ -106,7 +106,7 @@ M: hash-0-b hashcode* 2drop 0 ; [ t ] [ 10000 test-persistent-hashtables-1 ] unit-test [ t ] [ 50000 test-persistent-hashtables-1 ] unit-test -: test-persistent-hashtables-2 ( n -- ) +: test-persistent-hashtables-2 ( n -- ? ) random-assocs dup keys [ [ nip over delete-at ] [ swap pluck-at nip ] 3bi diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor index fe58e3d07c..c35d7488ac 100644 --- a/basis/random/mersenne-twister/mersenne-twister-tests.factor +++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor @@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests 100 [ 100 random ] replicate ; : test-rng ( seed quot -- ) - [ ] dip with-random ; + [ ] dip with-random ; inline [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test diff --git a/basis/threads/threads-tests.factor b/basis/threads/threads-tests.factor index adac84338d..610a664c7b 100644 --- a/basis/threads/threads-tests.factor +++ b/basis/threads/threads-tests.factor @@ -31,7 +31,7 @@ yield [ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with -:: spawn-namespace-test ( -- ) +:: spawn-namespace-test ( -- ? ) [let | p [ ] g [ gensym ] | [ g "x" set diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 3bb9ae72ac..2fc1ada108 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -374,9 +374,9 @@ SYMBOL: deploy-vocab [:c] [print-error] '[ - [ _ execute ] [ - _ execute nl - _ execute + [ _ execute( obj -- ) ] [ + _ execute( obj -- ) nl + _ execute( obj -- ) ] recover ] % ] if diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 76f9f63c49..a8049f709e 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -357,7 +357,7 @@ DEFER: corner-case-1 [ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test -: test-case-8 ( n -- ) +: test-case-8 ( n -- string ) { { 1 [ "foo" ] } } case ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 34a4ed2879..2111cce358 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -3,7 +3,7 @@ continuations debugger parser memory arrays words kernel.private accessors eval ; IN: continuations.tests -: (callcc1-test) ( -- ) +: (callcc1-test) ( n obj -- n' obj ) [ 1- dup ] dip ?push over 0 = [ "test-cc" get continue-with ] when (callcc1-test) ; @@ -59,7 +59,7 @@ IN: continuations.tests ! : callstack-overflow callstack-overflow f ; ! [ callstack-overflow ] must-fail -: don't-compile-me ( -- ) { } [ ] each ; +: don't-compile-me ( n -- ) { } [ ] each ; : foo ( -- ) callstack "c" set 3 don't-compile-me ; : bar ( -- a b ) 1 foo 2 ; diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 63346f4701..84a356805b 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -27,7 +27,7 @@ IN: kernel.tests [ ] [ :c ] unit-test -: (overflow-d-alt) ( -- ) 3 ; +: (overflow-d-alt) ( -- n ) 3 ; : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; @@ -107,7 +107,7 @@ IN: kernel.tests ! Regression : (loop) ( a b c d -- ) [ pick ] dip swap [ pick ] dip swap - < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline + < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive : loop ( obj obj -- ) H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; @@ -168,4 +168,4 @@ IN: kernel.tests [ 3 -1 5/6 ] [ 1 2 3 4 5 6 [ + ] [ - ] [ / ] 2tri* ] unit-test -[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test \ No newline at end of file +[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 2tri@ ] unit-test diff --git a/extra/lint/lint-tests.factor b/extra/lint/lint-tests.factor index 70035f1854..7326bc65b0 100644 --- a/extra/lint/lint-tests.factor +++ b/extra/lint/lint-tests.factor @@ -2,7 +2,7 @@ USING: io lint kernel math tools.test ; IN: lint.tests ! Don't write code like this -: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when +: lint1 ( obj -- ) [ "hi" print ] [ ] if ; ! when [ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test diff --git a/extra/partial-continuations/partial-continuations-tests.factor b/extra/partial-continuations/partial-continuations-tests.factor index 7e876b0934..d6fdefd1aa 100644 --- a/extra/partial-continuations/partial-continuations-tests.factor +++ b/extra/partial-continuations/partial-continuations-tests.factor @@ -7,7 +7,7 @@ SYMBOL: sum : range ( r from to -- n ) over - 1 + rot [ -rot [ over + pick call drop ] each 2drop f - ] bshift 2nip ; + ] bshift 2nip ; inline [ 55 ] [ 0 sum set From 3fc7b222842b18500394a86e35a95851cfcd7ee1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 15:10:50 -0500 Subject: [PATCH 08/35] undo inline --- extra/4DNav/file-chooser/file-chooser.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor index 033ae755cb..ad799f75c9 100755 --- a/extra/4DNav/file-chooser/file-chooser.factor +++ b/extra/4DNav/file-chooser/file-chooser.factor @@ -111,7 +111,7 @@ file-chooser H{ : line-selected-action ( file-chooser -- ) dup list>> list-value dup directory? - [ fc-change-directory ] [ fc-load-file ] if ; inline + [ fc-change-directory ] [ fc-load-file ] if ; : present-dir-element ( element -- string ) [ name>> ] [ directory? ] bi [ "-> " prepend ] when ; From 7a1841f59b77cc1d2f8f1958c1d9c64e3b51b955 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 15:49:21 -0500 Subject: [PATCH 09/35] (( -- )) eval -> eval( -- ) --- basis/compiler/tests/folding.factor | 4 +- basis/compiler/tests/redefine1.factor | 12 +-- basis/compiler/tests/redefine10.factor | 4 +- basis/compiler/tests/redefine11.factor | 2 +- basis/compiler/tests/redefine12.factor | 2 +- basis/compiler/tests/redefine2.factor | 2 +- basis/compiler/tests/redefine3.factor | 2 +- basis/compiler/tests/redefine4.factor | 2 +- basis/compiler/tests/redefine5.factor | 4 +- basis/compiler/tests/redefine6.factor | 4 +- basis/compiler/tests/redefine7.factor | 4 +- basis/compiler/tests/redefine8.factor | 4 +- basis/compiler/tests/redefine9.factor | 4 +- basis/compiler/tests/simple.factor | 2 +- basis/delegate/delegate-tests.factor | 10 +-- basis/fry/fry-tests.factor | 2 +- basis/help/crossref/crossref-tests.factor | 4 +- .../help/definitions/definitions-tests.factor | 2 +- basis/help/syntax/syntax-tests.factor | 4 +- basis/help/topics/topics-tests.factor | 2 +- basis/listener/listener-tests.factor | 2 +- basis/locals/locals-tests.factor | 26 +++--- basis/macros/macros-tests.factor | 4 +- basis/memoize/memoize-tests.factor | 4 +- basis/mirrors/mirrors-tests.factor | 2 +- basis/peg/ebnf/ebnf-tests.factor | 8 +- basis/prettyprint/prettyprint-tests.factor | 2 +- basis/regexp/regexp-tests.factor | 6 +- .../stack-checker/stack-checker-tests.factor | 4 +- .../annotations/annotations-tests.factor | 4 +- core/classes/classes-tests.factor | 6 +- core/classes/mixin/mixin-tests.factor | 2 +- core/classes/tuple/parser/parser-tests.factor | 22 ++--- core/classes/tuple/tuple-tests.factor | 84 +++++++++---------- core/classes/union/union-tests.factor | 6 +- core/compiler/units/units-tests.factor | 2 +- core/generic/generic-tests.factor | 16 ++-- core/parser/parser-tests.factor | 70 ++++++++-------- core/slots/slots-tests.factor | 4 +- core/vocabs/loader/loader-tests.factor | 2 +- core/words/alias/alias-tests.factor | 2 +- core/words/words-tests.factor | 20 ++--- 42 files changed, 187 insertions(+), 187 deletions(-) diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor index c2de317e83..fe2f801de2 100644 --- a/basis/compiler/tests/folding.factor +++ b/basis/compiler/tests/folding.factor @@ -12,7 +12,7 @@ IN: compiler.tests IN: compiler.tests.folding GENERIC: foldable-generic ( a -- b ) foldable M: integer foldable-generic f ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -20,7 +20,7 @@ IN: compiler.tests USING: math arrays ; IN: compiler.tests.folding : fold-test ( -- x ) 10 foldable-generic ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ t ] [ diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index db45c6af17..8145ad628b 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ; [ 6 ] [ method-redefine-test-1 ] unit-test -[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" (( -- )) eval ] unit-test +[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test @@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ; [ 6 ] [ method-redefine-test-2 ] unit-test -[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" (( -- )) eval ] unit-test +[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test @@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ; [ t ] [ \ hey optimized>> ] unit-test [ t ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" (( -- )) eval ] unit-test +[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test [ f ] [ \ hey optimized>> ] unit-test [ f ] [ \ there optimized>> ] unit-test -[ ] [ "IN: compiler.tests : hey ( -- ) ;" (( -- )) eval ] unit-test +[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test [ t ] [ \ there optimized>> ] unit-test : good ( -- ) ; @@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ; [ f ] [ \ good compiled-usage assoc-empty? ] unit-test -[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" (( -- )) eval ] unit-test +[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test [ f ] [ \ good optimized>> ] unit-test [ f ] [ \ bad optimized>> ] unit-test @@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ; [ t ] [ \ good compiled-usage assoc-empty? ] unit-test -[ ] [ "IN: compiler.tests : good ( -- ) ;" (( -- )) eval ] unit-test +[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test [ t ] [ \ good optimized>> ] unit-test [ t ] [ \ bad optimized>> ] unit-test diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index de14a068ab..faae7b8ed1 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -13,7 +13,7 @@ IN: compiler.tests MIXIN: my-mixin INSTANCE: fixnum my-mixin : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -21,7 +21,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine10 INSTANCE: float my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor index 2135d31606..57f9f9caf0 100644 --- a/basis/compiler/tests/redefine11.factor +++ b/basis/compiler/tests/redefine11.factor @@ -17,7 +17,7 @@ IN: compiler.tests M: my-mixin my-generic drop 0 ; M: object my-generic drop 1 ; : my-inline ( -- b ) { } my-generic ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ diff --git a/basis/compiler/tests/redefine12.factor b/basis/compiler/tests/redefine12.factor index 2ff16f0cca..ccf6c88e70 100644 --- a/basis/compiler/tests/redefine12.factor +++ b/basis/compiler/tests/redefine12.factor @@ -15,6 +15,6 @@ M: object g drop t ; TUPLE: jeah ; -[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" (( -- )) eval ] unit-test +[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test [ f ] [ T{ jeah } h ] unit-test diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index b61f53d14c..6a7b7a6941 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ; DEFER: redefine2-test -[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" (( -- )) eval ] unit-test +[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 0835f8cfba..87ab100879 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ; [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test -[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" (( -- )) eval ] unit-test +[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test [ "wake up" ] [ sheeple-test ] unit-test [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 29d5da6394..88b40f0c5a 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ; [ "" ] [ [ declaration-test ] with-string-writer ] unit-test -[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" (( -- )) eval ] unit-test +[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor index 8db28b52d5..c390f9a1ec 100644 --- a/basis/compiler/tests/redefine5.factor +++ b/basis/compiler/tests/redefine5.factor @@ -14,7 +14,7 @@ IN: compiler.tests GENERIC: my-generic ( a -- b ) M: object my-generic [ <=> ] sort ; : my-inline ( a -- b ) my-generic ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -23,7 +23,7 @@ IN: compiler.tests IN: compiler.tests.redefine5 TUPLE: my-tuple ; M: my-tuple my-generic drop 0 ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 0 ] [ diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor index df9c35dc42..7f1be973e7 100644 --- a/basis/compiler/tests/redefine6.factor +++ b/basis/compiler/tests/redefine6.factor @@ -14,7 +14,7 @@ IN: compiler.tests MIXIN: my-mixin M: my-mixin my-generic drop 0 ; : my-inline ( a -- b ) { my-mixin } declare my-generic ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -24,7 +24,7 @@ IN: compiler.tests TUPLE: my-tuple ; M: my-tuple my-generic drop 1 ; INSTANCE: my-tuple my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 1 ] [ diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor index fd6d5a9564..d6dfdf20fd 100644 --- a/basis/compiler/tests/redefine7.factor +++ b/basis/compiler/tests/redefine7.factor @@ -13,7 +13,7 @@ IN: compiler.tests MIXIN: my-mixin INSTANCE: fixnum my-mixin : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -21,7 +21,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine7 INSTANCE: float my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor index 8a8d832dbf..3499c5070a 100644 --- a/basis/compiler/tests/redefine8.factor +++ b/basis/compiler/tests/redefine8.factor @@ -16,7 +16,7 @@ IN: compiler.tests ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -24,7 +24,7 @@ IN: compiler.tests USE: math IN: compiler.tests.redefine8 INSTANCE: float my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ 2.0 ] [ diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor index 63cf002cc9..25ed5f15db 100644 --- a/basis/compiler/tests/redefine9.factor +++ b/basis/compiler/tests/redefine9.factor @@ -16,7 +16,7 @@ IN: compiler.tests ! We add the bogus quotation here to hinder inlining ! since otherwise we cannot trigger this bug. M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ; - "> (( -- )) eval + "> eval( -- ) ] unit-test [ ] [ @@ -25,7 +25,7 @@ IN: compiler.tests IN: compiler.tests.redefine9 TUPLE: my-tuple ; INSTANCE: my-tuple my-mixin - "> (( -- )) eval + "> eval( -- ) ] unit-test [ diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 23fee84ae2..769182a8b1 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ; 10 [ [ "compiler.tests.foo" forget-vocab ] with-compilation-unit [ t ] [ - "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" (( -- obj )) eval + "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj ) ] unit-test ] times diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor index 34ff4ba079..f6a40d8dc8 100644 --- a/basis/delegate/delegate-tests.factor +++ b/basis/delegate/delegate-tests.factor @@ -35,7 +35,7 @@ M: hello bing hello-test ; [ 3 ] [ 1 0 2 whoa ] unit-test [ 3 ] [ 1 0 f 2 whoa ] unit-test -[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" (( -- )) eval ] times ] unit-test +[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test [ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test [ H{ } ] [ bee protocol-consult ] unit-test @@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ; [ 0 ] [ 1 three ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test -[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" (( -- )) eval ] unit-test +[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test [ f ] [ hey \ two method ] unit-test [ f ] [ hey \ four method ] unit-test -[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" (( -- )) eval ] unit-test +[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test [ { hey } ] [ alpha protocol-users ] unit-test [ { hey } ] [ beta protocol-users ] unit-test [ 2 ] [ 1 one ] unit-test [ 0 ] [ 1 two ] unit-test [ 0 ] [ 1 three ] unit-test [ 0 ] [ 1 four ] unit-test -[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" (( -- )) eval ] unit-test +[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test [ 2 ] [ 1 one ] unit-test [ -1 ] [ 1 two ] unit-test [ -1 ] [ 1 three ] unit-test [ -1 ] [ 1 four ] unit-test -[ ] [ "IN: delegate.tests FORGET: alpha" (( -- )) eval ] unit-test +[ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test [ f ] [ hey \ one method ] unit-test TUPLE: slot-protocol-test-1 a b ; diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor index 89fbaf31b6..88ecae66ad 100644 --- a/basis/fry/fry-tests.factor +++ b/basis/fry/fry-tests.factor @@ -56,7 +56,7 @@ sequences eval accessors ; 3 '[ [ [ _ 1array ] call 1array ] call 1array ] call ] unit-test -[ "USING: fry locals.backend ; f '[ load-local _ ]" (( -- quot )) eval ] +[ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ] [ error>> >r/r>-in-fry-error? ] must-fail-with [ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [ diff --git a/basis/help/crossref/crossref-tests.factor b/basis/help/crossref/crossref-tests.factor index 44122a3a64..95d4612cbe 100644 --- a/basis/help/crossref/crossref-tests.factor +++ b/basis/help/crossref/crossref-tests.factor @@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays io.streams.string continuations debugger compiler.units eval ; [ ] [ - "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" (( -- )) eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- ) ] unit-test [ $subsection ] [ @@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ; ] unit-test [ ] [ - "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" (( -- )) eval + "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- ) ] unit-test [ ] [ diff --git a/basis/help/definitions/definitions-tests.factor b/basis/help/definitions/definitions-tests.factor index 783a95dd5c..c3365fe53f 100644 --- a/basis/help/definitions/definitions-tests.factor +++ b/basis/help/definitions/definitions-tests.factor @@ -32,7 +32,7 @@ IN: help.definitions.tests "hello" "help.definitions.tests" lookup "help" word-prop ] unit-test - [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" (( -- )) eval ] unit-test + [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval( -- ) ] unit-test [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test diff --git a/basis/help/syntax/syntax-tests.factor b/basis/help/syntax/syntax-tests.factor index db94f53b01..7618e9cdeb 100644 --- a/basis/help/syntax/syntax-tests.factor +++ b/basis/help/syntax/syntax-tests.factor @@ -4,12 +4,12 @@ IN: help.syntax.tests [ [ "foobar" ] [ - "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" (( -- )) eval + "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval( -- ) "help.syntax.tests" vocab vocab-help ] unit-test [ { "foobar" } ] [ - "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" (( -- )) eval + "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval( -- ) "help.syntax.tests" vocab vocab-help ] unit-test diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index f4f17a10e5..ac9223b5d2 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -29,7 +29,7 @@ SYMBOL: foo } "\n" join [ "testfile" source-file file set - (( -- )) eval + eval( -- ) ] with-scope ] unit-test diff --git a/basis/listener/listener-tests.factor b/basis/listener/listener-tests.factor index 12b639c262..7ed082234a 100644 --- a/basis/listener/listener-tests.factor +++ b/basis/listener/listener-tests.factor @@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ; "\\ + 1 2 3 4" parse-interactive "cont" get continue-with ] ignore-errors - "USE: debugger :1" (( -- quot )) eval + "USE: debugger :1" eval( -- quot ) ] callcc1 ] unit-test ] with-file-vocabs diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 42ea3322f1..d472a8b22b 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -261,7 +261,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ; CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n" -[ ] [ new-definition (( -- )) eval ] unit-test +[ ] [ new-definition eval( -- ) ] unit-test [ t ] [ [ \ a-word-with-locals see ] with-string-writer @@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]" - (( -- )) eval call + eval( -- ) call ] [ error>> >r/r>-in-fry-error? ] must-fail-with :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline @@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ f ] [ 2 funny-macro-test ] unit-test ! Some odd parser corner cases -[ "USE: locals [let" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [let |" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [let | a" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with -[ "USE: locals [|" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with +[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test @@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ; [ 3 ] [ 3 [| a | \ a ] call ] unit-test -[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail +[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail -[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail +[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail -[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail +[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail -[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" (( -- )) eval ] must-fail +[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail -[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" (( -- )) eval ] must-fail +[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail -[ "USE: locals [| | { :> a } ]" (( -- )) eval ] must-fail +[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail -[ "USE: locals 3 :> a" (( -- )) eval ] must-fail +[ "USE: locals 3 :> a" eval( -- ) ] must-fail [ 3 ] [ 3 [| | :> a a ] call ] unit-test diff --git a/basis/macros/macros-tests.factor b/basis/macros/macros-tests.factor index 40b3d59b39..bf483f72ea 100644 --- a/basis/macros/macros-tests.factor +++ b/basis/macros/macros-tests.factor @@ -13,11 +13,11 @@ unit-test [ t ] [ \ see-test macro? ] unit-test [ t ] [ - "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup (( -- )) eval + "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- ) [ \ see-test see ] with-string-writer = ] unit-test [ f ] [ \ see-test macro? ] unit-test -[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" (( -- )) eval ] unit-test +[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test diff --git a/basis/memoize/memoize-tests.factor b/basis/memoize/memoize-tests.factor index 22b4406f32..d82abe5b07 100644 --- a/basis/memoize/memoize-tests.factor +++ b/basis/memoize/memoize-tests.factor @@ -9,7 +9,7 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" (( -- )) eval ] must-fail +[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail MEMO: see-test ( a -- b ) reverse ; @@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ; [ [ \ see-test see ] with-string-writer ] unit-test -[ ] [ "IN: memoize.tests : fib ( -- ) ;" (( -- )) eval ] unit-test +[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test diff --git a/basis/mirrors/mirrors-tests.factor b/basis/mirrors/mirrors-tests.factor index b5bac614ff..ed1f423bb0 100644 --- a/basis/mirrors/mirrors-tests.factor +++ b/basis/mirrors/mirrors-tests.factor @@ -56,6 +56,6 @@ TUPLE: color ! Test reshaping with a mirror 1 2 3 color boa "mirror" set -[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" (( -- )) eval ] unit-test +[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test [ 1 ] [ "red" "mirror" get at ] unit-test diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index cc414a798e..58102cffc3 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -445,11 +445,11 @@ foo= 'd' ] unit-test { } [ - "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" (( -- )) eval + "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" eval( -- ) ] unit-test [ - "USING: peg.ebnf ; " (( -- )) eval drop + "USING: peg.ebnf ; " eval( -- ) drop ] must-fail { t } [ @@ -521,12 +521,12 @@ Tok = Spaces (Number | Special ) "\\" [EBNF foo="\\" EBNF] ] unit-test -[ "USE: peg.ebnf [EBNF EBNF]" (( -- )) eval ] must-fail +[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail [ <" USE: peg.ebnf [EBNF lol = a lol = b - EBNF] "> (( -- )) eval + EBNF] "> eval( -- ) ] [ error>> [ redefined-rule? ] [ name>> "lol" = ] bi and ] must-fail-with diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index afec29ff61..1be836fcc6 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -254,7 +254,7 @@ M: class-see-layout class-see-layout ; ! Regression [ t ] [ "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n" - dup (( -- )) eval + dup eval( -- ) "generic-decl-test" "prettyprint.tests" lookup [ see ] with-string-writer = ] unit-test diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index ae013a7719..0479b104cc 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -262,11 +262,11 @@ IN: regexp-tests ! Comment inside a regular expression [ t ] [ "ac" "a(?#boo)c" matches? ] unit-test -[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" (( -- )) eval ] unit-test +[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval( -- ) ] unit-test -[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" (( -- )) eval ] unit-test +[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval( -- ) ] unit-test -[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" (( -- )) eval ] unit-test +[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval( -- ) ] unit-test [ "ab" ] [ "ab" "(a|ab)(bc)?" first-match >string ] unit-test [ "abc" ] [ "abc" "(a|ab)(bc)?" first-match >string ] unit-test diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index d8f61661d5..6b9e9fd8b6 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -524,7 +524,7 @@ ERROR: custom-error ; { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" (( -- )) eval ] unit-test +[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval( -- ) ] unit-test [ 3 ] [ inference-invalidation-c ] unit-test @@ -536,7 +536,7 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ; \ inference-invalidation-d must-infer -[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" (( -- )) eval ] unit-test +[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval( -- ) ] unit-test [ [ inference-invalidation-d ] infer ] must-fail diff --git a/basis/tools/annotations/annotations-tests.factor b/basis/tools/annotations/annotations-tests.factor index 0c92cb567b..bbd2ac2ca8 100644 --- a/basis/tools/annotations/annotations-tests.factor +++ b/basis/tools/annotations/annotations-tests.factor @@ -18,7 +18,7 @@ M: integer some-generic 1+ ; [ 4 ] [ 3 some-generic ] unit-test -[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" (( -- )) eval ] unit-test +[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test [ 2 ] [ 3 some-generic ] unit-test @@ -33,7 +33,7 @@ M: object another-generic ; \ another-generic watch -[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" (( -- )) eval ] unit-test +[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval( -- ) ] unit-test [ ] [ \ another-generic reset ] unit-test diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index f5ea84afa5..08746d1ba7 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -29,10 +29,10 @@ M: method-forget-class method-forget-test ; ] unit-test ! Minor leak -[ ] [ "IN: classes.tests TUPLE: forget-me ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tests TUPLE: forget-me ;" eval( -- ) ] unit-test [ ] [ f \ word set-global ] unit-test -[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" (( -- )) eval ] unit-test -[ ] [ "IN: classes.tests FORGET: forget-me" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tests USE: kernel USE: classes.algebra forget-me tuple class<= drop" eval( -- ) ] unit-test +[ ] [ "IN: classes.tests FORGET: forget-me" eval( -- ) ] unit-test [ 0 ] [ [ word? ] instances [ [ name>> "forget-me" = ] [ vocabulary>> "classes.tests" = ] bi and ] count diff --git a/core/classes/mixin/mixin-tests.factor b/core/classes/mixin/mixin-tests.factor index 1beafd003a..cd11591d6c 100644 --- a/core/classes/mixin/mixin-tests.factor +++ b/core/classes/mixin/mixin-tests.factor @@ -42,7 +42,7 @@ INSTANCE: integer mx1 [ t ] [ mx1 integer class<= ] unit-test [ t ] [ mx1 number class<= ] unit-test -"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" (( -- )) eval +"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- ) [ t ] [ array mx1 class<= ] unit-test [ f ] [ mx1 number class<= ] unit-test diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 9d0c268add..b95507c78b 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -50,20 +50,20 @@ TUPLE: test-8 { b integer read-only } ; DEFER: foo -[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" (( -- )) eval ] +[ "IN: classes.tuple.parser.tests TUPLE: foo < test-1 < ;" eval( -- ) ] [ error>> invalid-slot-name? ] must-fail-with -[ "IN: classes.tuple.parser.tests TUPLE: foo :" (( -- )) eval ] +[ "IN: classes.tuple.parser.tests TUPLE: foo :" eval( -- ) ] [ error>> invalid-slot-name? ] must-fail-with -[ "IN: classes.tuple.parser.tests TUPLE: foo" (( -- )) eval ] +[ "IN: classes.tuple.parser.tests TUPLE: foo" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with 2 [ - [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" (( -- )) eval ] + [ "IN: classes.tuple.parser.tests USE: alien TUPLE: foo { slot dll } ;" eval( -- ) ] [ error>> no-initial-value? ] must-fail-with @@ -71,14 +71,14 @@ must-fail-with ] times 2 [ - [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" (( -- )) eval ] + [ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo { slot array initial: 5 } ;" eval( -- ) ] [ error>> bad-initial-value? ] must-fail-with [ f ] [ \ foo tuple-class? ] unit-test ] times -[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" (( -- )) eval ] +[ "IN: classes.tuple.parser.tests USE: arrays TUPLE: foo slot { slot array } ;" eval( -- ) ] [ error>> duplicate-slot-names? ] must-fail-with @@ -107,7 +107,7 @@ TUPLE: parsing-corner-case x ; " f" " 3" "}" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] unit-test [ T{ parsing-corner-case f 3 } ] [ @@ -116,7 +116,7 @@ TUPLE: parsing-corner-case x ; "T{ parsing-corner-case" " { x 3 }" "}" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] unit-test [ T{ parsing-corner-case f 3 } ] [ @@ -125,7 +125,7 @@ TUPLE: parsing-corner-case x ; "T{ parsing-corner-case {" " x 3 }" "}" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] unit-test @@ -133,12 +133,12 @@ TUPLE: parsing-corner-case x ; { "USE: classes.tuple.parser.tests T{ parsing-corner-case" " { x 3 }" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] [ error>> unexpected-eof? ] must-fail-with [ { "USE: classes.tuple.parser.tests T{ parsing-corner-case {" " x 3 }" - } "\n" join (( -- tuple )) eval + } "\n" join eval( -- tuple ) ] [ error>> unexpected-eof? ] must-fail-with diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 451420268d..68cdc20c53 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -27,7 +27,7 @@ C: redefinition-test [ t ] [ "redefinition-test" get redefinition-test? ] unit-test -"IN: classes.tuple.tests TUPLE: redefinition-test ;" (( -- )) eval +"IN: classes.tuple.tests TUPLE: redefinition-test ;" eval( -- ) [ t ] [ "redefinition-test" get redefinition-test? ] unit-test @@ -39,7 +39,7 @@ C: point [ ] [ 100 200 "p" set ] unit-test ! Use eval to sequence parsing explicitly -[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: point x y z ;" eval( -- ) ] unit-test [ 100 ] [ "p" get x>> ] unit-test [ 200 ] [ "p" get y>> ] unit-test @@ -51,7 +51,7 @@ C: point [ 300 ] [ "p" get "z>>" "accessors" lookup execute ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: point z y ;" eval( -- ) ] unit-test [ 2 ] [ "p" get tuple-size ] unit-test @@ -89,7 +89,7 @@ C: empty [ t length ] [ object>> t eq? ] must-fail-with [ "" ] -[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" (( -- )) eval word name>> ] unit-test +[ "IN: classes.tuple.test TUPLE: constructor-test ; C: constructor-test" eval( -- ) word name>> ] unit-test TUPLE: size-test a b c d ; @@ -102,7 +102,7 @@ GENERIC: ( a -- b ) TUPLE: yo-momma ; -[ ] [ "IN: classes.tuple.tests C: yo-momma" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests C: yo-momma" eval( -- ) ] unit-test [ f ] [ \ generic? ] unit-test @@ -204,7 +204,7 @@ C: erg's-reshape-problem : cons-test-1 ( -- tuple ) \ erg's-reshape-problem new ; : cons-test-2 ( a b c d -- tuple ) \ erg's-reshape-problem boa ; -[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: erg's-reshape-problem a b c d e f ;" eval( -- ) ] unit-test [ ] [ 1 2 3 4 5 6 cons-test-2 "a" set ] unit-test @@ -281,13 +281,13 @@ test-server-slot-values ] unit-test [ - "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" (( -- )) eval + "IN: classes.tuple.tests TUPLE: bad-superclass < word ;" eval( -- ) ] must-fail ! Dynamically changing inheritance hierarchy TUPLE: electronic-device ; -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test [ f ] [ electronic-device laptop class<= ] unit-test [ t ] [ server electronic-device class<= ] unit-test @@ -303,17 +303,17 @@ TUPLE: electronic-device ; [ f ] [ "server" get laptop? ] unit-test [ t ] [ "server" get server? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer cpu ram ;" eval( -- ) ] unit-test [ f ] [ "laptop" get electronic-device? ] unit-test [ t ] [ "laptop" get computer? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: computer < electronic-device cpu ram disk ;" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ;" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -326,7 +326,7 @@ TUPLE: make-me-some-accessors voltage grounded? ; [ ] [ "laptop" get 220 >>voltage drop ] unit-test [ ] [ "server" get 110 >>voltage drop ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage grounded? ;" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -334,7 +334,7 @@ test-server-slot-values [ 220 ] [ "laptop" get voltage>> ] unit-test [ 110 ] [ "server" get voltage>> ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device grounded? voltage ;" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -343,7 +343,7 @@ test-server-slot-values [ 110 ] [ "server" get voltage>> ] unit-test ! Reshaping superclass and subclass simultaneously -[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: electronic-device voltage ; TUPLE: computer < electronic-device cpu ram ;" eval( -- ) ] unit-test test-laptop-slot-values test-server-slot-values @@ -364,11 +364,11 @@ C: test2 test-a/b -[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a x ; TUPLE: test2 < test1 b y ;" eval( -- ) ] unit-test test-a/b -[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: test1 a ; TUPLE: test2 < test1 b ;" eval( -- ) ] unit-test test-a/b @@ -393,19 +393,19 @@ T{ move-up-2 f "a" "b" "c" } "move-up" set test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a b c ; TUPLE: move-up-2 < move-up-1 ;" eval( -- ) ] unit-test test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 a c ; TUPLE: move-up-2 < move-up-1 b ;" eval( -- ) ] unit-test test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 c ; TUPLE: move-up-2 < move-up-1 b a ;" eval( -- ) ] unit-test test-move-up -[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: move-up-1 ; TUPLE: move-up-2 < move-up-1 a b c ;" eval( -- ) ] unit-test ! Constructors must be recompiled when changing superclass TUPLE: constructor-update-1 xxx ; @@ -416,7 +416,7 @@ C: constructor-update-2 { 3 1 } [ ] must-infer-as -[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: constructor-update-1 xxx ttt www ;" eval( -- ) ] unit-test { 5 1 } [ ] must-infer-as @@ -431,7 +431,7 @@ UNION: redefinition-problem' redefinition-problem integer ; TUPLE: redefinition-problem-2 ; -"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" (( -- )) eval +"IN: classes.tuple.tests TUPLE: redefinition-problem < redefinition-problem-2 ;" eval( -- ) [ t ] [ 3 redefinition-problem'? ] unit-test @@ -472,7 +472,7 @@ USE: vocabs ] with-compilation-unit ] unit-test -[ "USE: words T{ word }" (( -- )) eval ] +[ "USE: words T{ word }" eval( -- ) ] [ error>> T{ no-method f word new } = ] must-fail-with @@ -520,13 +520,13 @@ TUPLE: another-forget-accessors-test ; [ f ] [ t parser-notes? [ [ - "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" (( -- )) eval + "IN: classes.tuple.tests TUPLE: shadow-1 a b ; TUPLE: shadow-2 < shadow-1 a b ;" eval( -- ) ] with-string-writer empty? ] with-variable ] unit-test ! Missing error check -[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" (( -- )) eval ] must-fail +[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail ! Class forget messyness TUPLE: subclass-forget-test ; @@ -535,7 +535,7 @@ TUPLE: subclass-forget-test-1 < subclass-forget-test ; TUPLE: subclass-forget-test-2 < subclass-forget-test ; TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ; -[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval( -- ) ] unit-test [ { subclass-forget-test-2 } ] [ subclass-forget-test-2 class-usages ] @@ -549,7 +549,7 @@ unit-test [ f ] [ subclass-forget-test-2 tuple-class? ] unit-test [ subclass-forget-test-3 new ] must-fail -[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" (( -- )) eval ] must-fail +[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval( -- ) ] must-fail ! More DEFER: subclass-reset-test @@ -562,11 +562,11 @@ GENERIC: break-me ( obj -- ) [ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test [ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" "subclass-reset-test" parse-stream drop ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" (( -- )) eval ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" (( -- )) eval ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval( -- ) ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval( -- ) ] unit-test -[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval( -- ) ] unit-test [ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" "subclass-reset-test" parse-stream drop ] unit-test @@ -576,7 +576,7 @@ GENERIC: break-me ( obj -- ) [ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test -[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval( -- ) ] unit-test [ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test @@ -632,7 +632,7 @@ TUPLE: reshape-test x ; T{ reshape-test f "hi" } "tuple" set -[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: reshape-test { x read-only } ;" eval( -- ) ] unit-test [ f ] [ \ reshape-test \ (>>x) method ] unit-test @@ -640,11 +640,11 @@ T{ reshape-test f "hi" } "tuple" set [ "hi" ] [ "tuple" get x>> ] unit-test -[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x integer read-only } ;" eval( -- ) ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test -[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests USE: math TUPLE: reshape-test { x fixnum initial: 4 read-only } ;" eval( -- ) ] unit-test [ 0 ] [ "tuple" get x>> ] unit-test @@ -660,20 +660,20 @@ ERROR: error-class-test a b c ; [ "( a b c -- * )" ] [ \ error-class-test stack-effect effect>string ] unit-test [ f ] [ \ error-class-test "inline" word-prop ] unit-test -[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" (( -- )) eval ] +[ "IN: classes.tuple.tests ERROR: error-x ; : error-x 3 ;" eval( -- ) ] [ error>> error>> redefine-error? ] must-fail-with DEFER: error-y [ ] [ [ \ error-y dup class? [ forget-class ] [ drop ] if ] with-compilation-unit ] unit-test -[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests GENERIC: error-y ( a -- b )" eval( -- ) ] unit-test [ f ] [ \ error-y tuple-class? ] unit-test [ t ] [ \ error-y generic? ] unit-test -[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests ERROR: error-y ;" eval( -- ) ] unit-test [ t ] [ \ error-y tuple-class? ] unit-test @@ -694,7 +694,7 @@ DEFER: error-y ] unit-test [ ] [ - "IN: sequences TUPLE: reversed { seq read-only } ;" (( -- )) eval + "IN: sequences TUPLE: reversed { seq read-only } ;" eval( -- ) ] unit-test TUPLE: bogus-hashcode-1 x ; @@ -735,14 +735,14 @@ SLOT: kex DEFER: redefine-tuple-twice -[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test -[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests DEFER: redefine-tuple-twice" eval( -- ) ] unit-test [ t ] [ \ redefine-tuple-twice deferred? ] unit-test -[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test diff --git a/core/classes/union/union-tests.factor b/core/classes/union/union-tests.factor index 47f726c03b..52550b2356 100644 --- a/core/classes/union/union-tests.factor +++ b/core/classes/union/union-tests.factor @@ -26,13 +26,13 @@ M: union-1 generic-update-test drop "union-1" ; [ t ] [ union-1 number class<= ] unit-test [ "union-1" ] [ 1.0 generic-update-test ] unit-test -"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" (( -- )) eval +"IN: classes.union.tests USE: math USE: arrays UNION: union-1 rational array ;" eval( -- ) [ t ] [ bignum union-1 class<= ] unit-test [ f ] [ union-1 number class<= ] unit-test [ "union-1" ] [ { 1.0 } generic-update-test ] unit-test -"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" (( -- )) eval +"IN: classes.union.tests USE: math PREDICATE: union-1 < integer even? ;" eval( -- ) [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test @@ -58,7 +58,7 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; [ t ] [ fixnum redefine-bug-2 class<= ] unit-test [ t ] [ quotation redefine-bug-2 class<= ] unit-test -[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" (( -- )) eval ] unit-test +[ ] [ "IN: classes.union.tests USE: math UNION: redefine-bug-1 bignum ;" eval( -- ) ] unit-test [ t ] [ bignum redefine-bug-1 class<= ] unit-test [ f ] [ fixnum redefine-bug-2 class<= ] unit-test diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index d3a390dc56..03c68815cc 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -56,6 +56,6 @@ observer add-definition-observer DEFER: nesting-test -[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" (( -- )) eval ] unit-test +[ ] [ "IN: compiler.units.tests << : nesting-test ( -- ) ; >>" eval( -- ) ] unit-test observer remove-definition-observer diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index d0a7b28bc6..37f5cf40ae 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -65,11 +65,11 @@ M: number union-containment drop 2 ; [ 2 ] [ 1.0 union-containment ] unit-test ! Testing recovery from bad method definitions -"IN: generic.tests GENERIC: unhappy ( x -- x )" (( -- )) eval +"IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) [ - "IN: generic.tests M: dictionary unhappy ;" (( -- )) eval + "IN: generic.tests M: dictionary unhappy ;" eval( -- ) ] must-fail -[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" (( -- )) eval ] unit-test +[ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval( -- ) ] unit-test GENERIC# complex-combination 1 ( a b -- c ) M: string complex-combination drop ; @@ -177,7 +177,7 @@ M: f generic-forget-test-3 ; [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test -[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" (( -- )) eval ] unit-test +[ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval( -- ) ] unit-test [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test @@ -193,7 +193,7 @@ M: integer a-generic a-word ; [ t ] [ "m" get \ a-word usage memq? ] unit-test -[ ] [ "IN: generic.tests : a-generic ( -- ) ;" (( -- )) eval ] unit-test +[ ] [ "IN: generic.tests : a-generic ( -- ) ;" eval( -- ) ] unit-test [ f ] [ "m" get \ a-word usage memq? ] unit-test @@ -207,18 +207,18 @@ M: integer a-generic a-word ; M: boii jeah ; GENERIC: jeah* ( a -- b ) M: boii jeah* jeah ; - "> (( -- )) eval + "> eval( -- ) <" IN: compiler.tests FORGET: boii - "> (( -- )) eval + "> eval( -- ) <" IN: compiler.tests TUPLE: boii ; M: boii jeah ; - "> (( -- )) eval + "> eval( -- ) ] unit-test ! call-next-method cache test diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 491bc1884a..2add8663d8 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -10,43 +10,43 @@ IN: parser.tests [ [ 1 [ 2 [ 3 ] 4 ] 5 ] - [ "1\n[\n2\n[\n3\n]\n4\n]\n5" (( -- a b c )) eval ] + [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval( -- a b c ) ] unit-test [ t t f f ] - [ "t t f f" (( -- ? ? ? ? )) eval ] + [ "t t f f" eval( -- ? ? ? ? ) ] unit-test [ "hello world" ] - [ "\"hello world\"" (( -- string )) eval ] + [ "\"hello world\"" eval( -- string ) ] unit-test [ "\n\r\t\\" ] - [ "\"\\n\\r\\t\\\\\"" (( -- string )) eval ] + [ "\"\\n\\r\\t\\\\\"" eval( -- string ) ] unit-test [ "hello world" ] [ "IN: parser.tests : hello ( -- str ) \"hello world\" ;" - (( -- )) eval "USE: parser.tests hello" (( -- string )) eval + eval( -- ) "USE: parser.tests hello" eval( -- string ) ] unit-test [ ] - [ "! This is a comment, people." (( -- )) eval ] + [ "! This is a comment, people." eval( -- ) ] unit-test ! Test escapes [ " " ] - [ "\"\\u000020\"" (( -- string )) eval ] + [ "\"\\u000020\"" eval( -- string ) ] unit-test [ "'" ] - [ "\"\\u000027\"" (( -- string )) eval ] + [ "\"\\u000027\"" eval( -- string ) ] unit-test ! Test EOL comments in multiline strings. - [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" (( -- string )) eval ] unit-test + [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval( -- string ) ] unit-test [ word ] [ \ f class ] unit-test @@ -68,7 +68,7 @@ IN: parser.tests [ \ baz "declared-effect" word-prop terminated?>> ] unit-test - [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" (( -- )) eval ] unit-test + [ ] [ "IN: parser.tests USE: math : effect-parsing-test ( a b -- d ) - ;" eval( -- ) ] unit-test [ t ] [ "effect-parsing-test" "parser.tests" lookup @@ -79,14 +79,14 @@ IN: parser.tests [ \ effect-parsing-test "declared-effect" word-prop ] unit-test ! Funny bug - [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." (( -- n )) eval ] unit-test + [ 2 ] [ "IN: parser.tests : \0. ( -- x ) 2 ; \0." eval( -- n ) ] unit-test - [ "IN: parser.tests : missing-- ( a b ) ;" (( -- )) eval ] must-fail + [ "IN: parser.tests : missing-- ( a b ) ;" eval( -- ) ] must-fail ! These should throw errors - [ "HEX: zzz" (( -- obj )) eval ] must-fail - [ "OCT: 999" (( -- obj )) eval ] must-fail - [ "BIN: --0" (( -- obj )) eval ] must-fail + [ "HEX: zzz" eval( -- obj ) ] must-fail + [ "OCT: 999" eval( -- obj ) ] must-fail + [ "BIN: --0" eval( -- obj ) ] must-fail ! Another funny bug [ t ] [ @@ -102,14 +102,14 @@ IN: parser.tests ] unit-test DEFER: foo - "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" (( -- )) eval + "IN: parser.tests USING: math prettyprint ; SYNTAX: foo 2 2 + . ;" eval( -- ) - [ ] [ "USE: parser.tests foo" (( -- )) eval ] unit-test + [ ] [ "USE: parser.tests foo" eval( -- ) ] unit-test - "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" (( -- )) eval + "IN: parser.tests USING: math prettyprint ; : foo ( -- ) 2 2 + . ;" eval( -- ) [ t ] [ - "USE: parser.tests \\ foo" (( -- word )) eval + "USE: parser.tests \\ foo" eval( -- word ) "foo" "parser.tests" lookup eq? ] unit-test @@ -339,16 +339,16 @@ IN: parser.tests ] [ error>> error>> error>> redefine-error? ] must-fail-with [ ] [ - "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" (( -- )) eval + "IN: parser.tests : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval( -- ) ] unit-test [ - "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" (( -- )) eval + "IN: parser.tests : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval( -- ) ] must-fail ] with-file-vocabs [ ] [ - "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" (( -- )) eval + "IN: parser.tests USE: kernel PREDICATE: foo < object ( x -- y ) ;" eval( -- ) ] unit-test [ t ] [ @@ -422,13 +422,13 @@ IN: parser.tests ] unit-test [ - "USE: this-better-not-exist" (( -- )) eval + "USE: this-better-not-exist" eval( -- ) ] must-fail -[ ": foo ;" (( -- )) eval ] [ error>> error>> no-current-vocab? ] must-fail-with +[ ": foo ;" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with -[ 92 ] [ "CHAR: \\" (( -- n )) eval ] unit-test -[ 92 ] [ "CHAR: \\\\" (( -- n )) eval ] unit-test +[ 92 ] [ "CHAR: \\" eval( -- n ) ] unit-test +[ 92 ] [ "CHAR: \\\\" eval( -- n ) ] unit-test [ ] [ { @@ -480,10 +480,10 @@ IN: parser.tests [ t ] [ "staging-problem-test-2" "parser.tests" lookup >boolean ] unit-test -[ "DEFER: blahy" (( -- )) eval ] [ error>> error>> no-current-vocab? ] must-fail-with +[ "DEFER: blahy" eval( -- ) ] [ error>> error>> no-current-vocab? ] must-fail-with [ - "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" (( -- )) eval + "IN: parser.tests SYNTAX: blahy ; FORGET: blahy" eval( -- ) ] [ error>> staging-violation? ] must-fail-with @@ -491,12 +491,12 @@ IN: parser.tests ! Bogus error message DEFER: blahy -[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" (( -- )) eval ] +[ "IN: parser.tests USE: kernel TUPLE: blahy < tuple ; : blahy ( -- ) ; TUPLE: blahy < tuple ; : blahy ( -- ) ;" eval( -- ) ] [ error>> error>> def>> \ blahy eq? ] must-fail-with [ ] [ f lexer set f file set "Hello world" note. ] unit-test -[ "CHAR: \\u9999999999999" (( -- n )) eval ] must-fail +[ "CHAR: \\u9999999999999" eval( -- n ) ] must-fail SYMBOLS: a b c ; @@ -506,15 +506,15 @@ SYMBOLS: a b c ; DEFER: blah -[ ] [ "IN: parser.tests GENERIC: blah ( -- )" (( -- )) eval ] unit-test -[ ] [ "IN: parser.tests SYMBOLS: blah ;" (( -- )) eval ] unit-test +[ ] [ "IN: parser.tests GENERIC: blah ( -- )" eval( -- ) ] unit-test +[ ] [ "IN: parser.tests SYMBOLS: blah ;" eval( -- ) ] unit-test [ f ] [ \ blah generic? ] unit-test [ t ] [ \ blah symbol? ] unit-test DEFER: blah1 -[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" (( -- )) eval ] +[ "IN: parser.tests SINGLETONS: blah1 blah1 blah1 ;" eval( -- ) ] [ error>> error>> def>> \ blah1 eq? ] must-fail-with @@ -545,10 +545,10 @@ EXCLUDE: qualified.tests.bar => x ; [ 3 ] [ x ] unit-test [ 4 ] [ y ] unit-test -[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" (( -- )) eval ] +[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval( -- ) ] [ error>> no-word-error? ] must-fail-with -[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" (( -- )) eval ] +[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval( -- ) ] [ error>> no-word-error? ] must-fail-with ! Two similar bugs diff --git a/core/slots/slots-tests.factor b/core/slots/slots-tests.factor index d76f1ffb07..7ac8446842 100644 --- a/core/slots/slots-tests.factor +++ b/core/slots/slots-tests.factor @@ -25,12 +25,12 @@ TUPLE: hello length ; [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test ! See if declarations are cleared on redefinition -[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" (( -- )) eval ] unit-test +[ ] [ "IN: slots.tests TUPLE: r/w-test { foo read-only } ;" eval( -- ) ] unit-test [ t ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test -[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" (( -- )) eval ] unit-test +[ ] [ "IN: slots.tests TUPLE: r/w-test foo ;" eval( -- ) ] unit-test [ f ] [ r/w-test \ foo>> method "foldable" word-prop ] unit-test [ t ] [ r/w-test \ foo>> method "flushable" word-prop ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index b43ab08c2c..f7c8a89e8c 100644 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -143,7 +143,7 @@ IN: vocabs.loader.tests forget-junk [ { } ] [ - "IN: xabbabbja" (( -- )) eval "xabbabbja" vocab-files + "IN: xabbabbja" eval( -- ) "xabbabbja" vocab-files ] unit-test [ "xabbabbja" forget-vocab ] with-compilation-unit diff --git a/core/words/alias/alias-tests.factor b/core/words/alias/alias-tests.factor index e0bfba5cc1..c4bc8519a9 100644 --- a/core/words/alias/alias-tests.factor +++ b/core/words/alias/alias-tests.factor @@ -2,5 +2,5 @@ USING: math eval tools.test effects ; IN: words.alias.tests ALIAS: foo + -[ ] [ "IN: words.alias.tests CONSTANT: foo 5" (( -- )) eval ] unit-test +[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval( -- ) ] unit-test [ (( -- value )) ] [ \ foo stack-effect ] unit-test diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 7eb1025039..3ba5e1f693 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -51,7 +51,7 @@ SYMBOL: a-symbol ! See if redefining a generic as a colon def clears some ! word props. GENERIC: testing ( a -- b ) -"IN: words.tests : testing ( -- ) ;" (( -- )) eval +"IN: words.tests : testing ( -- ) ;" eval( -- ) [ f ] [ \ testing generic? ] unit-test @@ -116,10 +116,10 @@ DEFER: x [ ] [ "no-loc" "words.tests" create drop ] unit-test [ f ] [ "no-loc" "words.tests" lookup where ] unit-test -[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" (( -- )) eval ] unit-test +[ ] [ "IN: words.tests : no-loc-2 ( -- ) ;" eval( -- ) ] unit-test [ f ] [ "no-loc-2" "words.tests" lookup where ] unit-test -[ ] [ "IN: words.tests : test-last ( -- ) ;" (( -- )) eval ] unit-test +[ ] [ "IN: words.tests : test-last ( -- ) ;" eval( -- ) ] unit-test [ "test-last" ] [ word name>> ] unit-test ! regression @@ -146,15 +146,15 @@ SYMBOL: quot-uses-b [ forget ] with-compilation-unit ] when* -[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" (( -- )) eval ] +[ "IN: words.tests : undef-test ( -- ) ; << undef-test >>" eval( -- ) ] [ error>> undefined? ] must-fail-with [ ] [ - "IN: words.tests GENERIC: symbol-generic ( -- )" (( -- )) eval + "IN: words.tests GENERIC: symbol-generic ( -- )" eval( -- ) ] unit-test [ ] [ - "IN: words.tests SYMBOL: symbol-generic" (( -- )) eval + "IN: words.tests SYMBOL: symbol-generic" eval( -- ) ] unit-test [ t ] [ "symbol-generic" "words.tests" lookup symbol? ] unit-test @@ -174,14 +174,14 @@ SYMBOL: quot-uses-b [ f ] [ "symbol-generic" "words.tests" lookup generic? ] unit-test ! Regressions -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" (( -- )) eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; foldable" eval( -- ) ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" (( -- )) eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "foldable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" (( -- )) eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ; flushable" eval( -- ) ] unit-test [ t ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test -[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" (( -- )) eval ] unit-test +[ ] [ "IN: words.tests : decl-forget-test ( -- ) ;" eval( -- ) ] unit-test [ f ] [ "decl-forget-test" "words.tests" lookup "flushable" word-prop ] unit-test [ { } ] From cd97d3f59064a1fa06f09f3dfc8db7c11e4e351f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 15:49:36 -0500 Subject: [PATCH 10/35] Fix -e switch --- basis/bootstrap/finish-bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor index 36f6291bc6..ab08aa87a9 100644 --- a/basis/bootstrap/finish-bootstrap.factor +++ b/basis/bootstrap/finish-bootstrap.factor @@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ; (command-line) parse-command-line load-vocab-roots run-user-init - "e" get [ eval ] when* + "e" get [ eval( -- ) ] when* ignore-cli-args? not script get and [ run-script ] [ "run" get run ] if* output-stream get [ stream-flush ] when* From ce76331fd6e1ec5f23e245998dbec0d3851d6bfe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 15:50:03 -0500 Subject: [PATCH 11/35] Fixing more unit tests --- .../compiler/tree/normalization/normalization-tests.factor | 6 +++--- basis/eval/eval-tests.factor | 2 ++ basis/prettyprint/prettyprint-tests.factor | 4 ++-- basis/ui/gadgets/paragraphs/paragraphs-tests.factor | 2 +- basis/ui/tools/error-list/error-list.factor | 2 +- 5 files changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index 2097f4ebdd..680ae0b170 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -17,13 +17,13 @@ sequences accessors tools.test kernel math ; [ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test -: foo ( a b -- b a ) swap ; inline recursive +: foo ( quot: ( -- ) -- ) call ; inline recursive : recursive-inputs ( nodes -- n ) [ #recursive? ] find nip child>> first in-d>> length ; -[ 0 2 ] [ - [ foo ] build-tree +[ 1 3 ] [ + [ [ swap ] foo ] build-tree [ recursive-inputs ] [ analyze-recursive normalize recursive-inputs ] bi ] unit-test diff --git a/basis/eval/eval-tests.factor b/basis/eval/eval-tests.factor index 675921944a..d27e661193 100644 --- a/basis/eval/eval-tests.factor +++ b/basis/eval/eval-tests.factor @@ -1,4 +1,6 @@ IN: eval.tests USING: eval tools.test ; +[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test +[ "USE: math 2 2 +" eval( -- ) ] must-fail [ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index afec29ff61..428699032b 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -2,8 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex kernel math namespaces parser prettyprint prettyprint.config prettyprint.sections sequences tools.test vectors words effects splitting generic.standard prettyprint.private -continuations generic compiler.units tools.walker eval -accessors make vocabs.parser see ; +continuations generic compiler.units tools.continuations +tools.continuations.private eval accessors make vocabs.parser see ; IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test diff --git a/basis/ui/gadgets/paragraphs/paragraphs-tests.factor b/basis/ui/gadgets/paragraphs/paragraphs-tests.factor index fcc121e584..c8494216b4 100644 --- a/basis/ui/gadgets/paragraphs/paragraphs-tests.factor +++ b/basis/ui/gadgets/paragraphs/paragraphs-tests.factor @@ -27,7 +27,7 @@ INSTANCE: fake-break word-break [ { 0 0 } ] [ "a" get loc>> ] unit-test -[ { 45 15 } ] [ "b" get loc>> ] unit-test +[ { 45 7 } ] [ "b" get loc>> ] unit-test [ { 0 30 } ] [ "c" get loc>> ] unit-test diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 7efe023f9a..2b1b0dabcd 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -80,7 +80,7 @@ M: error-renderer row-columns { [ error-type error-icon ] [ line#>> [ number>string ] [ "" ] if* ] - [ asset>> unparse-short ] + [ asset>> [ unparse-short ] [ "" ] if* ] [ error>> summary ] } cleave ] output>array ; From 50ed1f5a9f12a18462afa6d7d2e802724a4183c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 15:50:11 -0500 Subject: [PATCH 12/35] Better error printing --- basis/tools/errors/errors.factor | 24 ++++++++---------------- basis/tools/test/test.factor | 12 ++++++------ 2 files changed, 14 insertions(+), 22 deletions(-) diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index a8708fd229..b4b6a3ec1e 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -7,29 +7,21 @@ IN: tools.errors #! Tools for source-files.errors. Used by tools.tests and others #! for error reporting -M: source-file-error summary - error>> summary ; - M: source-file-error compute-restarts error>> compute-restarts ; M: source-file-error error-help error>> error-help ; -M: source-file-error error. +M: source-file-error summary [ - [ - [ - [ file>> [ % ": " % ] when* ] - [ line#>> [ # "\n" % ] when* ] bi - ] "" make - ] [ - [ - presented set - bold font-style set - ] H{ } make-assoc - ] bi format - ] [ error>> error. ] bi ; + [ file>> [ % ": " % ] [ "" % ] if* ] + [ line#>> [ # ] when* ] bi + ] "" make + ; + +M: source-file-error error. + [ summary print nl ] [ error>> error. ] bi ; : errors. ( errors -- ) group-by-source-file sort-errors diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 0741b90984..b98f58b143 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -129,13 +129,13 @@ TEST: must-infer TEST: must-fail-with TEST: must-fail -M: test-failure summary - asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ; - M: test-failure error. ( error -- ) - [ call-next-method ] - [ traceback-button. ] - bi ; + { + [ summary print nl ] + [ asset>> [ experiment. nl ] when* ] + [ error>> error. ] + [ traceback-button. ] + } cleave ; : :test-failures ( -- ) test-failures get errors. ; From f80c89f1286540f0e76c686c81b4a3a25e15e700 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 16:16:12 -0500 Subject: [PATCH 13/35] Add fatal? flag to error types; non-fatal errors are hidden by default in error list, not shown in summary --- basis/compiler/errors/errors.factor | 1 + basis/ui/tools/error-list/error-list.factor | 2 +- basis/ui/tools/listener/listener.factor | 5 ++--- core/source-files/errors/errors.factor | 10 +++++----- 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index e3174470fb..d9e2a27560 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -44,6 +44,7 @@ T{ error-type { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" } { quot [ +linkage-error+ errors-of-type values ] } { forget-quot [ compiler-errors get delete-at ] } + { fatal? f } } define-error-type : ( error word -- compiler-error ) diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 2b1b0dabcd..6a63a70cf8 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -26,7 +26,7 @@ MEMO: error-icon ( type -- image-name ) : ( -- model gadget ) #! Linkage errors are not shown by default. - error-types get keys [ dup +linkage-error+ eq? not ] { } map>assoc + error-types get [ fatal?>> ] assoc-map [ [ [ error-icon ] dip ] assoc-map ] [ ] bi ; diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 57689b002b..6484b8e1c4 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -358,9 +358,8 @@ interactor "completion" f { } define-command-map : ui-error-summary ( -- ) - all-errors [ - [ error-type ] map prune - [ error-icon-path 1array \ $image prefix " " 2array ] { } map-as + error-counts keys [ + [ icon>> 1array \ $image prefix " " 2array ] { } map-as { "Press " { $command tool "common" show-error-list } " to view errors." } append print-element nl ] unless-empty ; diff --git a/core/source-files/errors/errors.factor b/core/source-files/errors/errors.factor index e179c99913..f6f4f4825a 100644 --- a/core/source-files/errors/errors.factor +++ b/core/source-files/errors/errors.factor @@ -12,7 +12,7 @@ TUPLE: source-file-error error asset file line# ; : group-by-source-file ( errors -- assoc ) H{ } clone [ [ push-at ] curry [ dup file>> ] prepose each ] keep ; -TUPLE: error-type type word plural icon quot forget-quot ; +TUPLE: error-type type word plural icon quot forget-quot { fatal? initial: t } ; GENERIC: error-type ( error -- type ) @@ -34,12 +34,12 @@ error-types [ V{ } clone ] initialize error-types get at icon>> ; : error-counts ( -- alist ) - error-types get [ nip dup quot>> call( -- seq ) length ] assoc-map ; + error-types get + [ nip dup quot>> call( -- seq ) length ] assoc-map + [ [ fatal?>> ] [ 0 > ] bi* and ] assoc-filter ; : error-summary ( -- ) - error-counts - [ nip 0 > ] assoc-filter - [ + error-counts [ over [ word>> write ] [ " - show " write number>string write bl ] From 332bde417314d3aebbeb580afef445fd7b371f8f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 16:17:11 -0500 Subject: [PATCH 14/35] use iota in a few places --- basis/compiler/tree/cleanup/cleanup-tests.factor | 2 +- extra/project-euler/018/018.factor | 2 +- extra/project-euler/032/032.factor | 4 +++- extra/project-euler/150/150.factor | 4 ++-- 4 files changed, 7 insertions(+), 5 deletions(-) diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index c533f78916..c596be263a 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -302,7 +302,7 @@ cell-bits 32 = [ ] unit-test [ t ] [ - [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? + [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined? ] unit-test : rec ( a -- b ) diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor index a4aded7096..9c7c4fee74 100644 --- a/extra/project-euler/018/018.factor +++ b/extra/project-euler/018/018.factor @@ -66,7 +66,7 @@ IN: project-euler.018 91 71 52 38 17 14 91 43 58 50 27 29 48 63 66 04 68 89 53 67 30 73 16 69 87 40 31 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23 - } 15 [ 1+ cut swap ] map nip ; + } 15 iota [ 1+ cut swap ] map nip ; PRIVATE> diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 5ff5234679..64c9ec445e 100755 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -27,7 +27,9 @@ IN: project-euler.032 integer ] map ; + 9 factorial iota [ + 9 permutation [ 1+ ] map 10 digits>integer + ] map ; : 1and4 ( n -- ? ) number>string 1 cut-slice 4 cut-slice diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index e013e16575..314698534f 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -50,13 +50,13 @@ IN: project-euler.150 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline : sums-triangle ( -- seq ) - 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ; + 0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ; :: (euler150) ( m -- n ) [let | table [ sums-triangle ] | m [| x | x 1+ [| y | - m x - [| z | + m x - iota [| z | x z + table nth-unsafe [ y z + 1+ swap nth-unsafe ] [ y swap nth-unsafe ] bi - From 86e97b0d9c4e3eb2d03b413393138febc285e74e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 17:52:22 -0500 Subject: [PATCH 15/35] io.crlf: add some unit tests; read-crlf now returns f on EOF --- basis/io/crlf/crlf-tests.factor | 8 ++++++ basis/io/crlf/crlf.factor | 4 +-- extra/benchmark/benchmark.factor | 44 ++++++++++++++++++++++++-------- 3 files changed, 43 insertions(+), 13 deletions(-) create mode 100644 basis/io/crlf/crlf-tests.factor diff --git a/basis/io/crlf/crlf-tests.factor b/basis/io/crlf/crlf-tests.factor new file mode 100644 index 0000000000..2412945ab3 --- /dev/null +++ b/basis/io/crlf/crlf-tests.factor @@ -0,0 +1,8 @@ +IN: io.crlf.tests +USING: io.crlf tools.test io.streams.string io ; + +[ "Hello, world." ] [ "Hello, world." [ read-crlf ] with-string-reader ] unit-test +[ "Hello, world." ] [ "Hello, world.\r\n" [ read-crlf ] with-string-reader ] unit-test +[ "Hello, world.\r" [ read-crlf ] with-string-reader ] must-fail +[ f ] [ "" [ read-crlf ] with-string-reader ] unit-test +[ "" ] [ "\r\n" [ read-crlf ] with-string-reader ] unit-test diff --git a/basis/io/crlf/crlf.factor b/basis/io/crlf/crlf.factor index 53dddce199..29f10300de 100644 --- a/basis/io/crlf/crlf.factor +++ b/basis/io/crlf/crlf.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: io kernel ; +USING: io kernel sequences ; IN: io.crlf : crlf ( -- ) @@ -8,4 +8,4 @@ IN: io.crlf : read-crlf ( -- seq ) "\r" read-until - [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ; + [ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ; diff --git a/extra/benchmark/benchmark.factor b/extra/benchmark/benchmark.factor index 489dc5e73f..ca48e6208c 100755 --- a/extra/benchmark/benchmark.factor +++ b/extra/benchmark/benchmark.factor @@ -1,21 +1,35 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel vocabs vocabs.loader tools.time tools.vocabs arrays assocs io.styles io help.markup prettyprint sequences -continuations debugger math ; +continuations debugger math namespaces ; IN: benchmark -: run-benchmark ( vocab -- result ) + + +: run-benchmark ( vocab -- ) [ "=== " write vocab-name print flush ] [ - [ [ require ] [ [ run ] benchmark ] bi ] curry - [ error. f ] recover + [ [ require ] [ [ run ] benchmark ] [ ] tri timings ] + [ swap errors ] + recover get set-at ] bi ; -: run-benchmarks ( -- assoc ) - "benchmark" all-child-vocabs-seq - [ dup run-benchmark ] { } map>assoc ; +: run-benchmarks ( -- timings errors ) + [ + V{ } clone timings set + V{ } clone errors set + "benchmark" all-child-vocabs-seq + [ run-benchmark ] each + timings get + errors get + ] with-scope ; -: benchmarks. ( assoc -- ) +: timings. ( assocs -- ) standard-table-style [ [ [ "Benchmark" write ] with-cell @@ -24,13 +38,21 @@ IN: benchmark [ [ [ [ 1array $vocab-link ] with-cell ] - [ [ 1000000 /f pprint-cell ] [ [ "failed" write ] with-cell ] if* ] bi* + [ 1000000 /f pprint-cell ] + bi* ] with-row ] assoc-each ] tabular-output nl ; +: benchmark-errors. ( errors -- ) + [ + [ "=== " write vocab-name print ] + [ error. ] + bi* + ] assoc-each ; + : benchmarks ( -- ) - run-benchmarks benchmarks. ; + run-benchmarks [ timings. ] [ benchmark-errors. ] bi* ; MAIN: benchmarks From 4c3d5cffac325e2a61a44d0087afd0f1629197e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 17:52:41 -0500 Subject: [PATCH 16/35] smtp: make content-type configurable --- basis/smtp/authors.txt | 2 ++ basis/smtp/server/server.factor | 1 + basis/smtp/smtp-docs.factor | 6 +++-- basis/smtp/smtp-tests.factor | 4 ++-- basis/smtp/smtp.factor | 41 +++++++++++++++++---------------- 5 files changed, 30 insertions(+), 24 deletions(-) diff --git a/basis/smtp/authors.txt b/basis/smtp/authors.txt index 159b1e91e9..ad5e36ed58 100644 --- a/basis/smtp/authors.txt +++ b/basis/smtp/authors.txt @@ -1,3 +1,5 @@ Elie Chaftari Dirk Vleugels Slava Pestov +Doug Coleman +Daniel Ehrenberg diff --git a/basis/smtp/server/server.factor b/basis/smtp/server/server.factor index 5d7791292b..dbff4fd214 100644 --- a/basis/smtp/server/server.factor +++ b/basis/smtp/server/server.factor @@ -36,6 +36,7 @@ SYMBOL: data-mode : process ( -- ) read-crlf { + { [ dup not ] [ f ] } { [ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ] [ "220 and..?\r\n" write flush t ] diff --git a/basis/smtp/smtp-docs.factor b/basis/smtp/smtp-docs.factor index 453f4009e2..0b13113427 100644 --- a/basis/smtp/smtp-docs.factor +++ b/basis/smtp/smtp-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel quotations help.syntax help.markup -io.sockets strings calendar ; +io.sockets strings calendar io.encodings.utf8 ; IN: smtp HELP: smtp-domain @@ -41,7 +41,9 @@ HELP: email { { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." } { { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." } { { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." } - { { $slot "subject" } " The subject of the e-mail. A string." } + { { $slot "subject" } "The subject of the e-mail. A string." } + { { $slot "content-type" } { "The MIME type of the body. A string, default is " { $snippet "text/plain" } "." } } + { { $slot "encoding" } { "An encoding to send the body as. Default is " { $link utf8 } "." } } { { $slot "body" } " The body of the e-mail. A string." } } "The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional." diff --git a/basis/smtp/smtp-tests.factor b/basis/smtp/smtp-tests.factor index 8a9107b905..df6510afbf 100644 --- a/basis/smtp/smtp-tests.factor +++ b/basis/smtp/smtp-tests.factor @@ -16,7 +16,7 @@ IN: smtp.tests [ { "hello" "." "world" } validate-message ] must-fail [ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [ - "hello\nworld" [ send-body ] with-string-writer + T{ email { body "hello\nworld" } } [ send-body ] with-string-writer ] unit-test [ { "500 syntax error" } check-response ] @@ -51,7 +51,7 @@ IN: smtp.tests [ { { "Content-Transfer-Encoding" "base64" } - { "Content-Type" "Text/plain; charset=utf-8" } + { "Content-Type" "text/plain; charset=UTF-8" } { "From" "Doug " } { "MIME-Version" "1.0" } { "Subject" "Factor rules" } diff --git a/basis/smtp/smtp.factor b/basis/smtp/smtp.factor index 03b9d8af11..822fc92090 100644 --- a/basis/smtp/smtp.factor +++ b/basis/smtp/smtp.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, -! Slava Pestov, Doug Coleman. +! Slava Pestov, Doug Coleman, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays namespaces make io io.encodings.string -io.encodings.utf8 io.timeouts io.sockets io.sockets.secure -io.encodings.ascii kernel logging sequences combinators -splitting assocs strings math.order math.parser random system -calendar summary calendar.format accessors sets hashtables -base64 debugger classes prettyprint io.crlf ; +USING: arrays namespaces make io io.encodings.string io.encodings.utf8 +io.encodings.iana io.timeouts io.sockets io.sockets.secure +io.encodings.ascii kernel logging sequences combinators splitting +assocs strings math.order math.parser random system calendar summary +calendar.format accessors sets hashtables base64 debugger classes +prettyprint io.crlf words ; IN: smtp SYMBOL: smtp-domain @@ -44,6 +44,8 @@ TUPLE: email { cc array } { bcc array } { subject string } + { content-type string initial: "text/plain" } + { encoding word initial: utf8 } { body string } ; : ( -- email ) email new ; inline @@ -85,8 +87,8 @@ M: message-contains-dot summary ( obj -- string ) "." over member? [ message-contains-dot ] when ; -: send-body ( body -- ) - utf8 encode +: send-body ( email -- ) + [ body>> ] [ encoding>> ] bi encode >base64-lines write crlf "." command ; @@ -195,24 +197,23 @@ ERROR: invalid-header-string string ; ! This could be much smarter. " " split1-last swap or "<" ?head drop ">" ?tail drop ; -: utf8-mime-header ( -- alist ) - { - { "MIME-Version" "1.0" } - { "Content-Transfer-Encoding" "base64" } - { "Content-Type" "Text/plain; charset=utf-8" } - } ; +: email-content-type ( email -- content-type ) + [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ; -: email>headers ( email -- hashtable ) +: email>headers ( email -- assoc ) [ + now timestamp>rfc822 "Date" set + message-id "Message-Id" set + "1.0" "MIME-Version" set + "base64" "Content-Transfer-Encoding" set { [ from>> "From" set ] [ to>> ", " join "To" set ] [ cc>> ", " join [ "Cc" set ] unless-empty ] [ subject>> "Subject" set ] + [ email-content-type "Content-Type" set ] } cleave - now timestamp>rfc822 "Date" set - message-id "Message-Id" set - ] { } make-assoc utf8-mime-header append ; + ] { } make-assoc ; : (send-email) ( headers email -- ) [ @@ -227,7 +228,7 @@ ERROR: invalid-header-string string ; data get-ok swap write-headers crlf - body>> send-body get-ok + send-body get-ok quit get-ok ] with-smtp-connection ; From 0f0218b209149420132976824751468adfacbad3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 17:53:26 -0500 Subject: [PATCH 17/35] Fix some compile warnings in bootstrap --- basis/cpu/ppc/bootstrap.factor | 4 ++-- basis/cpu/x86/bootstrap.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index ec7bf8f341..1431d471c1 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -310,7 +310,7 @@ CONSTANT: rs-reg 30 4 ds-reg 0 LWZ 5 ds-reg -4 LWZU 5 0 4 CMP - 2 swap execute ! magic number + 2 swap execute( offset -- ) ! magic number \ f tag-number 3 LI 3 ds-reg 0 STW ; @@ -341,7 +341,7 @@ CONSTANT: rs-reg 30 : jit-math ( insn -- ) 3 ds-reg 0 LWZ 4 ds-reg -4 LWZU - [ 5 3 4 ] dip execute + [ 5 3 4 ] dip execute( dst src1 src2 -- ) 5 ds-reg 0 STW ; [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index f5829d76ea..b63d31364b 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -334,7 +334,7 @@ big-endian off ! compare with second value ds-reg [] temp0 CMP ! move t if true - [ temp1 temp3 ] dip execute + [ temp1 temp3 ] dip execute( dst src -- ) ! store ds-reg [] temp1 MOV ; @@ -355,7 +355,7 @@ big-endian off ! pop stack ds-reg bootstrap-cell SUB ! compute result - [ ds-reg [] temp0 ] dip execute ; + [ ds-reg [] temp0 ] dip execute( dst src -- ) ; [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive From 9dc7b4b95aab6e177dc87064c3fbb9980922193b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 17:55:01 -0500 Subject: [PATCH 18/35] Tweak some benchmark parameters --- extra/benchmark/base64/base64.factor | 2 +- extra/benchmark/beust1/beust1.factor | 2 +- extra/benchmark/beust2/beust2.factor | 2 +- extra/benchmark/fib6/fib6.factor | 2 +- extra/benchmark/md5/md5.factor | 4 ++-- extra/benchmark/random/random.factor | 2 +- extra/benchmark/sha1/sha1.factor | 4 ++-- extra/benchmark/sum-file/sum-file.factor | 2 +- 8 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/benchmark/base64/base64.factor b/extra/benchmark/base64/base64.factor index f6e5f7ca39..350a29f865 100644 --- a/extra/benchmark/base64/base64.factor +++ b/extra/benchmark/base64/base64.factor @@ -5,7 +5,7 @@ IN: benchmark.base64 : base64-benchmark ( -- ) 65535 [ 255 bitand ] "" map-as - 100 [ >base64 base64> ] times + 20 [ >base64 base64> ] times drop ; MAIN: base64-benchmark diff --git a/extra/benchmark/beust1/beust1.factor b/extra/benchmark/beust1/beust1.factor index 9849ac2dbe..d94c1d1335 100644 --- a/extra/benchmark/beust1/beust1.factor +++ b/extra/benchmark/beust1/beust1.factor @@ -8,7 +8,7 @@ IN: benchmark.beust1 1 [a,b] [ number>string all-unique? ] count ; inline : beust ( -- ) - 10000000 count-numbers + 2000000 count-numbers number>string " unique numbers." append print ; MAIN: beust diff --git a/extra/benchmark/beust2/beust2.factor b/extra/benchmark/beust2/beust2.factor index f96dc77961..d269ef3503 100755 --- a/extra/benchmark/beust2/beust2.factor +++ b/extra/benchmark/beust2/beust2.factor @@ -34,7 +34,7 @@ IN: benchmark.beust2 :: beust ( -- ) [let | i! [ 0 ] | - 10000000000 [ i 1+ i! ] count-numbers + 5000000000 [ i 1+ i! ] count-numbers i number>string " unique numbers." append print ] ; diff --git a/extra/benchmark/fib6/fib6.factor b/extra/benchmark/fib6/fib6.factor index 64d1b6c533..f81b6a21a2 100755 --- a/extra/benchmark/fib6/fib6.factor +++ b/extra/benchmark/fib6/fib6.factor @@ -9,6 +9,6 @@ USING: math kernel alien ; ] alien-callback "int" { "int" } "cdecl" alien-indirect ; -: fib-main ( -- ) 34 fib drop ; +: fib-main ( -- ) 32 fib drop ; MAIN: fib-main diff --git a/extra/benchmark/md5/md5.factor b/extra/benchmark/md5/md5.factor index 5030cb6904..de60049c84 100644 --- a/extra/benchmark/md5/md5.factor +++ b/extra/benchmark/md5/md5.factor @@ -1,7 +1,7 @@ -USING: checksums checksums.md5 io.files kernel ; +USING: checksums checksums.md5 sequences byte-arrays kernel ; IN: benchmark.md5 : md5-file ( -- ) - "vocab:mime/multipart/multipart-tests.factor" md5 checksum-file drop ; + 2000000 iota >byte-array md5 checksum-bytes drop ; MAIN: md5-file diff --git a/extra/benchmark/random/random.factor b/extra/benchmark/random/random.factor index d2eb4cdab5..4eab7c1669 100755 --- a/extra/benchmark/random/random.factor +++ b/extra/benchmark/random/random.factor @@ -11,6 +11,6 @@ IN: benchmark.random ] with-file-writer ; : random-main ( -- ) - 1000000 write-random-numbers ; + 300000 write-random-numbers ; MAIN: random-main diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor index 8e19ba9a8f..c1a7af2966 100644 --- a/extra/benchmark/sha1/sha1.factor +++ b/extra/benchmark/sha1/sha1.factor @@ -1,7 +1,7 @@ -USING: checksums checksums.sha1 io.files kernel ; +USING: checksums checksums.sha1 sequences byte-arrays kernel ; IN: benchmark.sha1 : sha1-file ( -- ) - "vocab:mime/multipart/multipart-tests.factor" sha1 checksum-file drop ; + 2000000 iota >byte-array sha1 checksum-bytes drop ; MAIN: sha1-file diff --git a/extra/benchmark/sum-file/sum-file.factor b/extra/benchmark/sum-file/sum-file.factor index bb7aebba62..b1f27830ee 100644 --- a/extra/benchmark/sum-file/sum-file.factor +++ b/extra/benchmark/sum-file/sum-file.factor @@ -9,6 +9,6 @@ IN: benchmark.sum-file ascii [ 0 sum-file-loop ] with-file-reader . ; : sum-file-main ( -- ) - random-numbers-path sum-file ; + 5 [ random-numbers-path sum-file ] times ; MAIN: sum-file-main From b579d32e5c86523917408304e9e4a50ca1c3468b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 17:55:33 -0500 Subject: [PATCH 19/35] mason: send HTML e-mails; if benchmarks fail build fails --- extra/mason/child/child.factor | 1 + extra/mason/common/common.factor | 2 + extra/mason/email/email.factor | 14 +-- extra/mason/report/report-tests.factor | 2 + extra/mason/report/report.factor | 151 ++++++++++++++++--------- extra/mason/test/test.factor | 8 +- 6 files changed, 115 insertions(+), 63 deletions(-) diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index feb11933fb..aa44088c2d 100755 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -66,6 +66,7 @@ IN: mason.child [ test-all-vocabs-file eval-file empty? ] [ help-lint-vocabs-file eval-file empty? ] [ compiler-errors-file eval-file empty? ] + [ benchmark-error-vocabs-file eval-file empty? ] } 0&& ; : build-child ( -- ) diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index 1aade3bcae..a3ff1a8ff5 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -98,6 +98,8 @@ CONSTANT: benchmark-time-file "benchmark-time" CONSTANT: html-help-time-file "html-help-time" CONSTANT: benchmarks-file "benchmarks" +CONSTANT: benchmark-error-messages-file "benchmark-error-messages" +CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs" SYMBOL: status diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index f25f7e5cfa..55edfcb30b 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -1,18 +1,18 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces accessors combinators make smtp -debugger prettyprint io io.streams.string io.encodings.utf8 -io.files io.sockets +USING: kernel namespaces accessors combinators make smtp debugger +prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets mason.common mason.platform mason.config ; IN: mason.email : prefix-subject ( str -- str' ) [ "mason on " % platform % ": " % % ] "" make ; -: email-status ( body subject -- ) +: email-status ( body content-type subject -- ) builder-from get >>from builder-recipients get >>to + swap >>content-type swap prefix-subject >>subject swap >>body send-email ; @@ -25,11 +25,11 @@ IN: mason.email } case ; : email-report ( -- ) - "report" utf8 file-contents subject email-status ; + "report" utf8 file-contents "text/html" subject email-status ; : email-error ( error callstack -- ) [ "Fatal error on " write host-name print nl [ error. ] [ callstack. ] bi* - ] with-string-writer "fatal error" + ] with-string-writer "text/plain" "fatal error" email-status ; diff --git a/extra/mason/report/report-tests.factor b/extra/mason/report/report-tests.factor index 7f5c4f1d30..a9e8e2802b 100644 --- a/extra/mason/report/report-tests.factor +++ b/extra/mason/report/report-tests.factor @@ -1,2 +1,4 @@ IN: mason.report.tests USING: mason.report tools.test ; + +{ 0 0 } [ [ ] with-report ] must-infer-as \ No newline at end of file diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 52e1608885..79ec15651d 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -1,74 +1,117 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces debugger fry io io.files io.sockets -io.encodings.utf8 prettyprint benchmark mason.common -mason.platform mason.config sequences ; +USING: benchmark combinators.smart debugger fry io assocs +io.encodings.utf8 io.files io.sockets io.streams.string kernel +locals mason.common mason.config mason.platform math namespaces +prettyprint sequences xml.syntax xml.writer ; IN: mason.report -: time. ( file -- ) - [ write ": " write ] [ eval-file milli-seconds>time print ] bi ; - -: common-report ( -- ) - "Build machine: " write host-name print - "CPU: " write target-cpu get print - "OS: " write target-os get print - "Build directory: " write build-dir print - "git id: " write "git-id" eval-file print nl ; +: common-report ( -- xml ) + target-os get + target-cpu get + host-name + build-dir + "git-id" eval-file + [XML +

Build report for <->/<->

+ + + + +
Build machine:<->
Build directory:<->
GIT ID:<->
+ XML] ; : with-report ( quot -- ) - [ "report" utf8 ] dip '[ common-report @ ] with-file-writer ; inline + [ "report" utf8 ] dip + '[ + common-report + _ call( -- xml ) + [XML <-><-> XML] + pprint-xml + ] with-file-writer ; inline + +:: failed-report ( error file what -- ) + [ + error [ error. ] with-string-writer :> error + file utf8 file-contents 400 short tail* :> output + + [XML +

<-what->

+ Build output: + 
<-output->
+ Launcher error: + 
<-error->
+ XML] + ] with-report ; : compile-failed-report ( error -- ) - [ - "VM compile failed:" print nl - "compile-log" cat nl - error. - ] with-report ; + "compile-log" "VM compilation failed" failed-report ; : boot-failed-report ( error -- ) - [ - "Bootstrap failed:" print nl - "boot-log" 100 cat-n nl - error. - ] with-report ; + "boot-log" "Bootstrap failed" failed-report ; : test-failed-report ( error -- ) + "test-log" "Tests failed" failed-report ; + +: timings-table ( -- xml ) + { + boot-time-file + load-time-file + test-time-file + help-lint-time-file + benchmark-time-file + html-help-time-file + } [ + dup utf8 file-contents milli-seconds>time + [XML <-><-> XML] + ] map [XML

Timings

<->
XML] ; + +: fail-dump ( heading vocabs-file messages-file -- xml ) + [ eval-file ] dip over empty? [ 3drop f ] [ + [ ] + [ [ [XML
  • <->
    • XML] ] map [XML
      <->
    XML] ] + [ utf8 file-contents ] + tri* + [XML

    <->

    <-> Details: 
    <->
    XML] + ] if ; + +: benchmarks-table ( assoc -- xml ) [ - "Tests failed:" print nl - "test-log" 100 cat-n nl - error. - ] with-report ; + 1000000 /f + [XML <-><-> XML] + ] { } assoc>map [XML

    Benchmarks

    <->
    XML] ; : successful-report ( -- ) [ - boot-time-file time. - load-time-file time. - test-time-file time. - help-lint-time-file time. - benchmark-time-file time. - html-help-time-file time. + [ + timings-table - nl + "Load failures" + load-everything-vocabs-file + load-everything-errors-file + fail-dump - load-everything-vocabs-file eval-file [ - "== Did not pass load-everything:" print . - load-everything-errors-file cat - ] unless-empty + "Compiler warnings and errors" + compiler-errors-file + compiler-error-messages-file + fail-dump - compiler-errors-file eval-file [ - "== Vocabularies with compiler errors:" print . - ] unless-empty + "Unit test failures" + test-all-vocabs-file + test-all-errors-file + fail-dump + + "Help lint failures" + help-lint-vocabs-file + help-lint-errors-file + fail-dump - test-all-vocabs-file eval-file [ - "== Did not pass test-all:" print . - test-all-errors-file cat - ] unless-empty - - help-lint-vocabs-file eval-file [ - "== Did not pass help-lint:" print . - help-lint-errors-file cat - ] unless-empty - - "== Benchmarks:" print - benchmarks-file eval-file benchmarks. + "Benchmark errors" + benchmark-error-vocabs-file + benchmark-error-messages-file + fail-dump + + "Benchmark timings" + benchmarks-file eval-file benchmarks-table + ] output>array ] with-report ; \ No newline at end of file diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 4c212b07fb..11a15328fb 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs benchmark bootstrap.stage2 compiler.errors generic help.html help.lint io.directories @@ -42,7 +42,11 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; do-step ; : do-benchmarks ( -- ) - run-benchmarks benchmarks-file to-file ; + run-benchmarks + [ + [ keys benchmark-error-vocabs-file to-file ] + [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi + ] [ benchmarks-file to-file ] bi* ; : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline From 7eaa20a4c5cc2d376112bdc5c0ef921c588594dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 18:04:41 -0500 Subject: [PATCH 20/35] fix stack effect of n*quot, use iota in core/slots --- basis/generalizations/generalizations-docs.factor | 4 ++-- basis/generalizations/generalizations.factor | 4 ++-- core/slots/slots.factor | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 2088e468c6..3671511194 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -272,8 +272,8 @@ HELP: nweave HELP: n*quot { $values - { "n" integer } { "seq" sequence } - { "seq'" sequence } + { "n" integer } { "quot" quotation } + { "quot'" quotation } } { $examples { $example "USING: generalizations prettyprint math ;" diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 0aa042d4f2..637f958eb5 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -7,7 +7,7 @@ IN: generalizations << -: n*quot ( n seq -- seq' ) concat >quotation ; +: n*quot ( n quot -- seq' ) concat >quotation ; : repeat ( n obj quot -- ) swapd times ; inline @@ -94,4 +94,4 @@ MACRO: nweave ( n -- ) : nappend-as ( n exemplar -- seq ) [ narray concat ] dip like ; inline -: nappend ( n -- seq ) narray concat ; inline \ No newline at end of file +: nappend ( n -- seq ) narray concat ; inline diff --git a/core/slots/slots.factor b/core/slots/slots.factor index a353f50947..63c0319c1c 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -222,7 +222,7 @@ M: slot-spec make-slot [ make-slot ] map ; : finalize-slots ( specs base -- specs ) - over length [ + ] with map [ >>offset ] 2map ; + over length iota [ + ] with map [ >>offset ] 2map ; : slot-named ( name specs -- spec/f ) [ name>> = ] with find nip ; From a6ea915e09ee6be408207a71ed302927fff503e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:21:51 -0500 Subject: [PATCH 21/35] mason: filter out linakge errors from build reports --- extra/mason/test/test.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 11a15328fb..88ccf93942 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs benchmark bootstrap.stage2 -compiler.errors generic help.html help.lint io.directories +USING: accessors assocs benchmark bootstrap.stage2 compiler.errors +source-files.errors generic help.html help.lint io.directories io.encodings.utf8 io.files kernel mason.common math namespaces -prettyprint sequences sets sorting tools.test tools.time -tools.vocabs words system io tools.errors locals ; +prettyprint sequences sets sorting tools.test tools.time tools.vocabs +words system io tools.errors locals ; IN: mason.test : do-load ( -- ) @@ -20,7 +20,9 @@ M: word word-vocabulary vocabulary>> ; M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; :: do-step ( errors summary-file details-file -- ) - errors [ file>> ] map prune natural-sort summary-file to-file + errors + [ error-type +linkage-error+ eq? not ] filter + [ file>> ] map prune natural-sort summary-file to-file errors details-file utf8 [ errors. ] with-file-writer ; : do-compile-errors ( -- ) From f4cdcaa1ce3ef2c86f26e833c91fd68ccea39eb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:38:55 -0500 Subject: [PATCH 22/35] Fix compiler warnings in tools.deploy.shaker --- basis/tools/deploy/shaker/shaker.factor | 6 +++--- vm/data_gc.c | 3 ++- vm/data_gc.h | 1 + vm/image.c | 2 ++ 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 2fc1ada108..37eec5eae2 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -357,7 +357,7 @@ IN: tools.deploy.shaker V{ } set-namestack V{ } set-catchstack "Saving final image" show - [ save-image-and-exit ] call-clear ; + save-image-and-exit ; SYMBOL: deploy-vocab @@ -421,10 +421,10 @@ SYMBOL: deploy-vocab : deploy-error-handler ( quot -- ) [ strip-debugger? - [ error-continuation get call>> callstack>array die ] + [ error-continuation get call>> callstack>array die 1 exit ] ! Don't reference these words literally, if we're stripping the ! debugger out we don't want to load the prettyprinter at all - [ [:c] execute nl [print-error] execute flush ] if + [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if 1 exit ] recover ; inline diff --git a/vm/data_gc.c b/vm/data_gc.c index a91eff6783..11c1639fea 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -160,7 +160,8 @@ void copy_roots(void) copy_handle(&stacks->catchstack_save); copy_handle(&stacks->current_callback_save); - mark_active_blocks(stacks); + if(!performing_compaction) + mark_active_blocks(stacks); stacks = stacks->next; } diff --git a/vm/data_gc.h b/vm/data_gc.h index 354c9398a5..feae26706d 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -5,6 +5,7 @@ DLLEXPORT void minor_gc(void); F_ZONE *newspace; bool performing_gc; +bool performing_compaction; CELL collecting_gen; /* if true, we collecting AGING space for the second time, so if it is still diff --git a/vm/image.c b/vm/image.c index a1987180d0..9cc97df0d9 100755 --- a/vm/image.c +++ b/vm/image.c @@ -187,7 +187,9 @@ void primitive_save_image_and_exit(void) userenv[i] = F; /* do a full GC + code heap compaction */ + performing_compaction = true; compact_code_heap(); + performing_compaction = false; UNREGISTER_C_STRING(path); From bbd496e3043fb7cbff9d2a58706054b4db277bfd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:42:51 -0500 Subject: [PATCH 23/35] 4DNav.file-chooser: fix compiler warning --- extra/4DNav/file-chooser/file-chooser.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/extra/4DNav/file-chooser/file-chooser.factor b/extra/4DNav/file-chooser/file-chooser.factor index ad799f75c9..51bebc3877 100755 --- a/extra/4DNav/file-chooser/file-chooser.factor +++ b/extra/4DNav/file-chooser/file-chooser.factor @@ -92,11 +92,9 @@ file-chooser H{ ; : fc-load-file ( file-chooser file -- ) - dupd [ selected-file>> ] [ name>> ] bi* swap set-model - [ path>> value>> ] - [ selected-file>> value>> append ] - [ hook>> ] tri - call + over [ name>> ] [ selected-file>> ] bi* set-model + [ [ path>> value>> ] [ selected-file>> value>> ] bi append ] [ hook>> ] bi + call( path -- ) ; inline ! : fc-ok-action ( file-chooser -- quot ) From 7db33912a0419a74a85f9962e4134f7d894c50b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:42:58 -0500 Subject: [PATCH 24/35] bank: fix compiler warning --- extra/bank/bank.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor index f06bc2fb81..31a4b75eb2 100644 --- a/extra/bank/bank.factor +++ b/extra/bank/bank.factor @@ -54,7 +54,7 @@ C: transaction : process-day ( account date -- ) 2dup accumulate-interest ?pay-interest ; -: each-day ( quot start end -- ) +: each-day ( quot: ( -- ) start end -- ) 2dup before? [ [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day ] [ @@ -63,7 +63,7 @@ C: transaction : process-to-date ( account date -- account ) over interest-last-paid>> 1 days time+ - [ dupd process-day ] spin each-day ; inline + [ dupd process-day ] spin each-day ; : inserting-transactions ( account transactions -- account ) [ [ date>> process-to-date ] keep >>transaction ] each ; From f36a3c47133798232a5d55ccec45c7a3349ccbb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:49:36 -0500 Subject: [PATCH 25/35] fuel: Fix compiler warnings --- extra/fuel/eval/eval.factor | 15 +++++++-------- extra/fuel/fuel.factor | 2 +- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index c3b1a8a3f2..b4a138459f 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays compiler.units continuations debugger fuel.pprint io io.streams.string kernel namespaces parser sequences -vectors vocabs.parser ; +vectors vocabs.parser eval fry ; IN: fuel.eval @@ -55,21 +55,20 @@ t fuel-eval-res-flag set-global : (fuel-end-eval) ( output -- ) fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline -: (fuel-eval) ( lines -- ) - [ [ parse-lines ] with-compilation-unit call ] curry - [ print-error ] recover ; inline +: (fuel-eval) ( string -- ) + '[ _ eval( -- ) ] try ; : (fuel-eval-each) ( lines -- ) - [ 1vector (fuel-eval) ] each ; inline + [ (fuel-eval) ] each ; : (fuel-eval-usings) ( usings -- ) - [ "USING: " prepend " ;" append ] map + [ "USE: " prepend ] map (fuel-eval-each) fuel-forget-error fuel-forget-output ; : (fuel-eval-in) ( in -- ) - [ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline + [ dup "IN: " prepend (fuel-eval) in set ] when* ; : (fuel-eval-in-context) ( lines in usings -- ) (fuel-begin-eval) - [ (fuel-eval-usings) (fuel-eval-in) (fuel-eval) ] with-string-writer + [ (fuel-eval-usings) (fuel-eval-in) "\n" join (fuel-eval) ] with-string-writer (fuel-end-eval) ; diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 403708e880..413aefdc76 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -104,7 +104,7 @@ PRIVATE> : fuel-vocab-summary ( name -- ) (fuel-vocab-summary) fuel-eval-set-result ; -: fuel-index ( quot -- ) call format-index fuel-eval-set-result ; +: fuel-index ( quot -- ) call( -- seq ) format-index fuel-eval-set-result ; : fuel-get-vocabs/tag ( tag -- ) (fuel-get-vocabs/tag) fuel-eval-set-result ; From d929134ad712736b4f0506a04787edd04e43f08e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:49:46 -0500 Subject: [PATCH 26/35] dns: Fix compiler warning --- extra/dns/util/util.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/dns/util/util.factor b/extra/dns/util/util.factor index 5b2e63838a..f47eb7010c 100644 --- a/extra/dns/util/util.factor +++ b/extra/dns/util/util.factor @@ -28,4 +28,4 @@ TUPLE: packet data addr socket ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: forever ( quot -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file +: forever ( quot: ( -- ) -- ) [ call ] [ forever ] bi ; inline recursive \ No newline at end of file From aff996a58fdb4edde75b1ff894aaa86dbd33ec45 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:49:59 -0500 Subject: [PATCH 27/35] math.function-tools: Fix compiler warning --- extra/math/function-tools/function-tools.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor index 11e57d2639..78c726d370 100644 --- a/extra/math/function-tools/function-tools.factor +++ b/extra/math/function-tools/function-tools.factor @@ -9,10 +9,10 @@ IN: math.function-tools [ bi - ] 2curry ; inline : eval ( x func -- pt ) - dupd call 2array ; inline + dupd call( x -- y ) 2array ; inline : eval-inverse ( y func -- pt ) - dupd call swap 2array ; inline + dupd call( y -- x ) swap 2array ; inline : eval3d ( x y func -- pt ) - [ 2dup ] dip call 3array ; inline + [ 2dup ] dip call( x y -- z ) 3array ; inline From 1b4e778102c68fd05213cb35ca7a36f2bed247fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:50:14 -0500 Subject: [PATCH 28/35] advice: move to unmaintained --- {extra => unmaintained}/advice/advice-docs.factor | 0 {extra => unmaintained}/advice/advice-tests.factor | 0 {extra => unmaintained}/advice/advice.factor | 0 {extra => unmaintained}/advice/authors.txt | 0 {extra => unmaintained}/advice/summary.txt | 0 {extra => unmaintained}/advice/tags.txt | 0 6 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/advice/advice-docs.factor (100%) rename {extra => unmaintained}/advice/advice-tests.factor (100%) rename {extra => unmaintained}/advice/advice.factor (100%) rename {extra => unmaintained}/advice/authors.txt (100%) rename {extra => unmaintained}/advice/summary.txt (100%) rename {extra => unmaintained}/advice/tags.txt (100%) diff --git a/extra/advice/advice-docs.factor b/unmaintained/advice/advice-docs.factor similarity index 100% rename from extra/advice/advice-docs.factor rename to unmaintained/advice/advice-docs.factor diff --git a/extra/advice/advice-tests.factor b/unmaintained/advice/advice-tests.factor similarity index 100% rename from extra/advice/advice-tests.factor rename to unmaintained/advice/advice-tests.factor diff --git a/extra/advice/advice.factor b/unmaintained/advice/advice.factor similarity index 100% rename from extra/advice/advice.factor rename to unmaintained/advice/advice.factor diff --git a/extra/advice/authors.txt b/unmaintained/advice/authors.txt similarity index 100% rename from extra/advice/authors.txt rename to unmaintained/advice/authors.txt diff --git a/extra/advice/summary.txt b/unmaintained/advice/summary.txt similarity index 100% rename from extra/advice/summary.txt rename to unmaintained/advice/summary.txt diff --git a/extra/advice/tags.txt b/unmaintained/advice/tags.txt similarity index 100% rename from extra/advice/tags.txt rename to unmaintained/advice/tags.txt From c6072d7b4b24a585fb28a26d1eced500ff4922e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:55:59 -0500 Subject: [PATCH 29/35] fuel.eval: fix --- extra/fuel/eval/eval.factor | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/extra/fuel/eval/eval.factor b/extra/fuel/eval/eval.factor index b4a138459f..ae1c5863a8 100644 --- a/extra/fuel/eval/eval.factor +++ b/extra/fuel/eval/eval.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays compiler.units continuations debugger fuel.pprint io io.streams.string kernel namespaces parser sequences -vectors vocabs.parser eval fry ; +vectors vocabs.parser ; IN: fuel.eval @@ -21,7 +21,7 @@ SYMBOL: fuel-eval-res-flag t fuel-eval-res-flag set-global : fuel-eval-restartable? ( -- ? ) - fuel-eval-res-flag get-global ; inline + fuel-eval-res-flag get-global ; : fuel-push-status ( -- ) in get use get clone restarts get-global clone @@ -29,7 +29,7 @@ t fuel-eval-res-flag set-global fuel-status-stack get push ; : fuel-pop-restarts ( restarts -- ) - fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; inline + fuel-eval-restartable? [ drop ] [ clone restarts set-global ] if ; : fuel-pop-status ( -- ) fuel-status-stack get empty? [ @@ -39,24 +39,25 @@ t fuel-eval-res-flag set-global [ restarts>> fuel-pop-restarts ] tri ] unless ; -: fuel-forget-error ( -- ) f error set-global ; inline -: fuel-forget-result ( -- ) f fuel-eval-result set-global ; inline -: fuel-forget-output ( -- ) f fuel-eval-output set-global ; inline +: fuel-forget-error ( -- ) f error set-global ; +: fuel-forget-result ( -- ) f fuel-eval-result set-global ; +: fuel-forget-output ( -- ) f fuel-eval-output set-global ; : fuel-forget-status ( -- ) - fuel-forget-error fuel-forget-result fuel-forget-output ; inline + fuel-forget-error fuel-forget-result fuel-forget-output ; : fuel-send-retort ( -- ) error get fuel-eval-result get-global fuel-eval-output get-global 3array fuel-pprint flush nl "<~FUEL~>" write nl flush ; : (fuel-begin-eval) ( -- ) - fuel-push-status fuel-forget-status ; inline + fuel-push-status fuel-forget-status ; : (fuel-end-eval) ( output -- ) - fuel-eval-output set-global fuel-send-retort fuel-pop-status ; inline + fuel-eval-output set-global fuel-send-retort fuel-pop-status ; -: (fuel-eval) ( string -- ) - '[ _ eval( -- ) ] try ; +: (fuel-eval) ( lines -- ) + [ [ parse-lines ] with-compilation-unit call( -- ) ] curry + [ print-error ] recover ; : (fuel-eval-each) ( lines -- ) [ (fuel-eval) ] each ; From 394a4ec315df0dc7b0567f90a1d61b929f6e4000 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:58:58 -0500 Subject: [PATCH 30/35] io.launcher.windows.nt: update for eval( --- basis/io/launcher/windows/nt/nt-tests.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 04202365fd..53b3d3ce7e 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests +replace-environment+ >>environment-mode os-envs >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) os-envs = ] unit-test @@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "A" swap at ] unit-test @@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode ascii contents - ] with-directory eval + ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = ] unit-test From 3586736b34181ecb09e1e157e268c0cd69fbe9eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:59:11 -0500 Subject: [PATCH 31/35] mason.test: benchmark files were read in wrong order --- extra/mason/test/test.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 88ccf93942..912fbaa17a 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -45,10 +45,10 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; : do-benchmarks ( -- ) run-benchmarks - [ + [ benchmarks-file to-file ] [ [ keys benchmark-error-vocabs-file to-file ] [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi - ] [ benchmarks-file to-file ] bi* ; + ] bi* ; : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline From af600d5aacbb32dd6de7eb680f41ad02fdd65317 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 17 Apr 2009 20:59:59 -0500 Subject: [PATCH 32/35] mason: working on a big overhaul of mason. Status updates sent to a web service, binary upload notification via Twitter --- extra/mason/build/build.factor | 20 +++++---- extra/mason/child/child-tests.factor | 20 +++++++++ extra/mason/child/child.factor | 43 ++++++++----------- extra/mason/cleanup/cleanup.factor | 9 ++-- extra/mason/common/common.factor | 22 +++++++--- extra/mason/config/config.factor | 15 ++++++- extra/mason/email/email.factor | 10 ++--- extra/mason/help/help.factor | 11 ++--- extra/mason/mason.factor | 3 +- extra/mason/notify/authors.txt | 1 + extra/mason/notify/notify.factor | 48 ++++++++++++++++++++++ extra/mason/release/archive/archive.factor | 22 +++++----- extra/mason/release/release.factor | 19 +++++---- extra/mason/release/upload/upload.factor | 11 +++-- extra/mason/report/report.factor | 39 ++++++++++++------ extra/mason/twitter/authors.txt | 1 + extra/mason/twitter/twitter.factor | 14 +++++++ 17 files changed, 208 insertions(+), 100 deletions(-) create mode 100644 extra/mason/notify/authors.txt create mode 100644 extra/mason/notify/notify.factor create mode 100644 extra/mason/twitter/authors.txt create mode 100644 extra/mason/twitter/twitter.factor diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 90ca1d31ff..199d48dec0 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar io.directories io.encodings.utf8 +USING: arrays kernel calendar io.directories io.encodings.utf8 io.files io.launcher mason.child mason.cleanup mason.common -mason.help mason.release mason.report namespaces prettyprint ; +mason.help mason.release mason.report mason.email mason.notify +namespaces prettyprint ; IN: mason.build QUALIFIED: continuations @@ -14,20 +15,21 @@ QUALIFIED: continuations : enter-build-dir ( -- ) build-dir set-current-directory ; : clone-builds-factor ( -- ) - "git" "clone" builds/factor 3array try-process ; + "git" "clone" builds/factor 3array try-output-process ; -: record-id ( -- ) - "factor" [ git-id ] with-directory "git-id" to-file ; +: begin-build ( -- ) + "factor" [ git-id ] with-directory + [ "git-id" to-file ] [ notify-begin-build ] bi ; : build ( -- ) create-build-dir enter-build-dir clone-builds-factor [ - record-id + begin-build build-child - upload-help - release + [ notify-report ] + [ status-clean eq? [ upload-help release ] when ] bi ] [ cleanup ] [ ] continuations:cleanup ; MAIN: build diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor index 27bb42ed07..a83e7282da 100644 --- a/extra/mason/child/child-tests.factor +++ b/extra/mason/child/child-tests.factor @@ -40,3 +40,23 @@ USING: mason.child mason.config tools.test namespaces ; boot-cmd ] with-scope ] unit-test + +[ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] must-infer + +[ 4 ] [ [ "Hi" print ] [ drop 3 ] [ 4 ] recover-else ] unit-test + +[ 3 ] [ [ "Hi" throw ] [ drop 3 ] [ 4 ] recover-else ] unit-test + +[ "A" ] [ + { + { [ 3 throw ] [ { "X" "Y" "Z" "A" } nth ] } + [ "B" ] + } recover-cond +] unit-test + +[ "B" ] [ + { + { [ ] [ ] } + [ "B" ] + } recover-cond +] unit-test \ No newline at end of file diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor index aa44088c2d..8132e62078 100755 --- a/extra/mason/child/child.factor +++ b/extra/mason/child/child.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays calendar combinators.short-circuit +USING: accessors arrays calendar combinators.short-circuit fry continuations debugger io.directories io.files io.launcher io.pathnames io.encodings.ascii kernel make mason.common mason.config -mason.platform mason.report mason.email namespaces sequences ; +mason.platform mason.report mason.notify namespaces sequences +quotations macros ; IN: mason.child : make-cmd ( -- args ) @@ -58,30 +59,18 @@ IN: mason.child try-process ] with-directory ; -: return-with ( obj -- * ) return-continuation get continue-with ; +: recover-else ( try catch else -- ) + [ [ '[ @ f t ] ] [ '[ @ f ] ] bi* recover ] dip '[ drop @ ] when ; inline -: build-clean? ( -- ? ) +MACRO: recover-cond ( alist -- ) + dup { [ length 1 = ] [ first callable? ] } 1&& + [ first ] [ [ first first2 ] [ rest ] bi '[ _ _ [ _ recover-cond ] recover-else ] ] if ; + +: build-child ( -- status ) + copy-image { - [ load-everything-vocabs-file eval-file empty? ] - [ test-all-vocabs-file eval-file empty? ] - [ help-lint-vocabs-file eval-file empty? ] - [ compiler-errors-file eval-file empty? ] - [ benchmark-error-vocabs-file eval-file empty? ] - } 0&& ; - -: build-child ( -- ) - [ - return-continuation set - - copy-image - - [ make-vm ] [ compile-failed-report status-error return-with ] recover - [ boot ] [ boot-failed-report status-error return-with ] recover - [ test ] [ test-failed-report status-error return-with ] recover - - successful-report - - build-clean? status-clean status-dirty ? return-with - ] callcc1 - status set - email-report ; \ No newline at end of file + { [ notify-make-vm make-vm ] [ compile-failed ] } + { [ notify-boot boot ] [ boot-failed ] } + { [ notify-test test ] [ test-failed ] } + [ success ] + } recover-cond ; \ No newline at end of file diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor index a273696f51..3e6209fed0 100755 --- a/extra/mason/cleanup/cleanup.factor +++ b/extra/mason/cleanup/cleanup.factor @@ -5,13 +5,14 @@ io.directories.hierarchy io.files io.launcher kernel mason.common mason.config mason.platform namespaces ; IN: mason.cleanup +: compress ( filename -- ) + dup exists? [ "bzip2" swap 2array try-output-process ] [ drop ] if ; + : compress-image ( -- ) - "bzip2" boot-image-name 2array try-process ; + boot-image-name compress ; : compress-test-log ( -- ) - "test-log" exists? [ - { "bzip2" "test-log" } try-process - ] when ; + "test-log" compress ; : cleanup ( -- ) builder-debug get [ diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index a3ff1a8ff5..285a684f06 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -4,15 +4,27 @@ USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar -calendar.format arrays mason.config locals system ; +calendar.format arrays mason.config locals system debugger ; IN: mason.common +ERROR: output-process-error output process ; + +M: output-process-error error. + [ "Process:" print process>> . nl ] + [ "Output:" print output>> print ] + bi ; + +: try-output-process ( command -- ) + >process +stdout+ >>stderr utf8 + [ contents ] [ dup wait-for-process ] bi* + 0 = [ 2drop ] [ output-process-error ] if ; + HOOK: really-delete-tree os ( path -- ) M: windows really-delete-tree #! Workaround: Cygwin GIT creates read-only files for #! some reason. - [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-process ] + [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ] [ delete-tree ] bi ; @@ -23,7 +35,7 @@ M: unix really-delete-tree delete-tree ; swap >>command 15 minutes >>timeout - try-process ; + try-output-process ; :: upload-safely ( local username host remote -- ) [let* | temp [ remote ".incomplete" append ] @@ -68,7 +80,7 @@ SYMBOL: stamp : prepare-build-machine ( -- ) builds-dir get make-directories builds-dir get - [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-process ] + [ { "git" "clone" "git://factorcode.org/git/factor.git" } try-output-process ] with-directory ; : git-id ( -- id ) @@ -101,8 +113,6 @@ CONSTANT: benchmarks-file "benchmarks" CONSTANT: benchmark-error-messages-file "benchmark-error-messages" CONSTANT: benchmark-error-vocabs-file "benchmark-error-vocabs" -SYMBOL: status - SYMBOL: status-error ! didn't bootstrap, or crashed SYMBOL: status-dirty ! bootstrapped but not all tests passed SYMBOL: status-clean ! everything good diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index 51b09543f4..5ec44df0a9 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -11,12 +11,17 @@ builds-dir get-global [ home "builds" append-path builds-dir set-global ] unless -! Who sends build reports. +! Who sends build report e-mails. SYMBOL: builder-from -! Who receives build reports. +! Who receives build report e-mails. SYMBOL: builder-recipients +! (Optional) twitter credentials for status updates. +SYMBOL: builder-twitter-username + +SYMBOL: builder-twitter-password + ! (Optional) CPU architecture to build for. SYMBOL: target-cpu @@ -34,6 +39,12 @@ target-os get-global [ ! Keep test-log around? SYMBOL: builder-debug +! Host to send status notifications to. +SYMBOL: status-host + +! Username to log in. +SYMBOL: status-username + SYMBOL: upload-help? ! The below are only needed if upload-help is true. diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index 55edfcb30b..23203e5222 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -12,20 +12,20 @@ IN: mason.email builder-from get >>from builder-recipients get >>to - swap >>content-type swap prefix-subject >>subject + swap >>content-type swap >>body send-email ; -: subject ( -- str ) - status get { +: subject ( status -- str ) + { { status-clean [ "clean" ] } { status-dirty [ "dirty" ] } { status-error [ "error" ] } } case ; -: email-report ( -- ) - "report" utf8 file-contents "text/html" subject email-status ; +: email-report ( report status -- ) + [ "text/html" ] dip subject email-status ; : email-error ( error callstack -- ) [ diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor index 9a4e2be996..9ed9653a08 100644 --- a/extra/mason/help/help.factor +++ b/extra/mason/help/help.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: arrays help.html io.directories io.files io.launcher kernel make mason.common mason.config namespaces sequences ; @@ -6,7 +6,7 @@ IN: mason.help : make-help-archive ( -- ) "factor/temp" [ - { "tar" "cfz" "docs.tar.gz" "docs" } try-process + { "tar" "cfz" "docs.tar.gz" "docs" } try-output-process ] with-directory ; : upload-help-archive ( -- ) @@ -16,11 +16,8 @@ IN: mason.help help-directory get "/docs.tar.gz" append upload-safely ; -: (upload-help) ( -- ) +: upload-help ( -- ) upload-help? get [ make-help-archive upload-help-archive - ] when ; - -: upload-help ( -- ) - status get status-clean eq? [ (upload-help) ] when ; + ] when ; \ No newline at end of file diff --git a/extra/mason/mason.factor b/extra/mason/mason.factor index 299a2f4e1f..d425985e76 100644 --- a/extra/mason/mason.factor +++ b/extra/mason/mason.factor @@ -6,7 +6,8 @@ mason.email mason.updates namespaces threads ; IN: mason : build-loop-error ( error -- ) - error-continuation get call>> email-error ; + [ "Build loop error:" print flush error. flush ] + [ error-continuation get call>> email-error ] bi ; : build-loop-fatal ( error -- ) "FATAL BUILDER ERROR:" print diff --git a/extra/mason/notify/authors.txt b/extra/mason/notify/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/notify/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor new file mode 100644 index 0000000000..6bf4ae090d --- /dev/null +++ b/extra/mason/notify/notify.factor @@ -0,0 +1,48 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays accessors io io.sockets io.encodings.utf8 io.files +io.launcher kernel make mason.config mason.common mason.email +mason.twitter namespaces sequences ; +IN: mason.notify + +: status-notify ( input-file args -- ) + status-host get [ + [ + "ssh" , status-host get , "-l" , status-username get , + "./mason-notify" , + host-name , + target-cpu get , + target-os get , + ] { } make prepend + + swap >>command + swap [ +closed+ ] unless* >>stdin + try-output-process + ] [ 2drop ] if ; + +: notify-begin-build ( git-id -- ) + [ "Starting build of GIT ID " write print flush ] + [ f swap "git-id" swap 2array status-notify ] + bi ; + +: notify-make-vm ( -- ) + "Compiling VM" print flush + f { "make-vm" } status-notify ; + +: notify-boot ( -- ) + "Bootstrapping" print flush + f { "boot" } status-notify ; + +: notify-test ( -- ) + "Running tests" print flush + f { "test" } status-notify ; + +: notify-report ( status -- ) + [ "Build finished with status: " write print flush ] + [ + [ "report" utf8 file-contents ] dip email-report + "report" { "report" } status-notify + ] bi ; + +: notify-release ( archive-name -- ) + "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ; \ No newline at end of file diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor index fff8b83c23..79d6993a91 100755 --- a/extra/mason/release/archive/archive.factor +++ b/extra/mason/release/archive/archive.factor @@ -18,23 +18,23 @@ IN: mason.release.archive : archive-name ( -- string ) base-name extension append ; -: make-windows-archive ( -- ) - [ "zip" , "-r" , archive-name , "factor" , ] { } make try-process ; +: make-windows-archive ( archive-name -- ) + [ "zip" , "-r" , , "factor" , ] { } make try-output-process ; -: make-macosx-archive ( -- ) - { "mkdir" "dmg-root" } try-process - { "cp" "-R" "factor" "dmg-root" } try-process +: make-macosx-archive ( archive-name -- ) + { "mkdir" "dmg-root" } try-output-process + { "cp" "-R" "factor" "dmg-root" } try-output-process { "hdiutil" "create" "-srcfolder" "dmg-root" "-fs" "HFS+" "-volname" "factor" } - archive-name suffix try-process + swap suffix try-output-process "dmg-root" really-delete-tree ; -: make-unix-archive ( -- ) - [ "tar" , "-cvzf" , archive-name , "factor" , ] { } make try-process ; +: make-unix-archive ( archive-name -- ) + [ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ; -: make-archive ( -- ) +: make-archive ( archive-name -- ) target-os get { { "winnt" [ make-windows-archive ] } { "macosx" [ make-macosx-archive ] } @@ -44,5 +44,5 @@ IN: mason.release.archive : releases ( -- path ) builds-dir get "releases" append-path dup make-directories ; -: save-archive ( -- ) - archive-name releases move-file-into ; \ No newline at end of file +: save-archive ( archive-name -- ) + releases move-file-into ; \ No newline at end of file diff --git a/extra/mason/release/release.factor b/extra/mason/release/release.factor index bbb47ba0d3..fc4ad0b08a 100644 --- a/extra/mason/release/release.factor +++ b/extra/mason/release/release.factor @@ -1,16 +1,17 @@ -! Copyright (C) 2008 Eduardo Cavazos. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel debugger namespaces sequences splitting +USING: kernel debugger namespaces sequences splitting combinators combinators io io.files io.launcher prettyprint bootstrap.image mason.common mason.release.branch mason.release.tidy -mason.release.archive mason.release.upload ; +mason.release.archive mason.release.upload mason.notify ; IN: mason.release -: (release) ( -- ) +: release ( -- ) update-clean-branch tidy - make-archive - upload - save-archive ; - -: release ( -- ) status get status-clean eq? [ (release) ] when ; \ No newline at end of file + archive-name { + [ make-archive ] + [ upload ] + [ save-archive ] + [ notify-release ] + } cleave ; \ No newline at end of file diff --git a/extra/mason/release/upload/upload.factor b/extra/mason/release/upload/upload.factor index 68f2ffcdb5..d3e11c3fc3 100644 --- a/extra/mason/release/upload/upload.factor +++ b/extra/mason/release/upload/upload.factor @@ -8,14 +8,13 @@ IN: mason.release.upload : remote-location ( -- dest ) upload-directory get "/" platform 3append ; -: remote-archive-name ( -- dest ) - remote-location "/" archive-name 3append ; +: remote-archive-name ( archive-name -- dest ) + [ remote-location "/" ] dip 3append ; -: upload ( -- ) +: upload ( archive-name -- ) upload-to-factorcode? get [ - archive-name upload-username get upload-host get - remote-archive-name + pick remote-archive-name upload-safely - ] when ; + ] [ drop ] if ; diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 79ec15651d..d6732adb1d 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -3,7 +3,7 @@ USING: benchmark combinators.smart debugger fry io assocs io.encodings.utf8 io.files io.sockets io.streams.string kernel locals mason.common mason.config mason.platform math namespaces -prettyprint sequences xml.syntax xml.writer ; +prettyprint sequences xml.syntax xml.writer combinators.short-circuit ; IN: mason.report : common-report ( -- xml ) @@ -30,7 +30,7 @@ IN: mason.report pprint-xml ] with-file-writer ; inline -:: failed-report ( error file what -- ) +:: failed-report ( error file what -- status ) [ error [ error. ] with-string-writer :> error file utf8 file-contents 400 short tail* :> output @@ -42,15 +42,16 @@ IN: mason.report Launcher error: 
    <-error->
    XML] - ] with-report ; + ] with-report + status-error ; -: compile-failed-report ( error -- ) +: compile-failed ( error -- status ) "compile-log" "VM compilation failed" failed-report ; -: boot-failed-report ( error -- ) +: boot-failed ( error -- status ) "boot-log" "Bootstrap failed" failed-report ; -: test-failed-report ( error -- ) +: test-failed ( error -- status ) "test-log" "Tests failed" failed-report ; : timings-table ( -- xml ) @@ -66,7 +67,7 @@ IN: mason.report [XML <-><-> XML] ] map [XML

    Timings

    <->
    XML] ; -: fail-dump ( heading vocabs-file messages-file -- xml ) +: error-dump ( heading vocabs-file messages-file -- xml ) [ eval-file ] dip over empty? [ 3drop f ] [ [ ] [ [ [XML
  • <->
    • XML] ] map [XML
      <->
    XML] ] @@ -89,29 +90,41 @@ IN: mason.report "Load failures" load-everything-vocabs-file load-everything-errors-file - fail-dump + error-dump "Compiler warnings and errors" compiler-errors-file compiler-error-messages-file - fail-dump + error-dump "Unit test failures" test-all-vocabs-file test-all-errors-file - fail-dump + error-dump "Help lint failures" help-lint-vocabs-file help-lint-errors-file - fail-dump + error-dump "Benchmark errors" benchmark-error-vocabs-file benchmark-error-messages-file - fail-dump + error-dump "Benchmark timings" benchmarks-file eval-file benchmarks-table ] output>array - ] with-report ; \ No newline at end of file + ] with-report ; + +: build-clean? ( -- ? ) + { + [ load-everything-vocabs-file eval-file empty? ] + [ test-all-vocabs-file eval-file empty? ] + [ help-lint-vocabs-file eval-file empty? ] + [ compiler-errors-file eval-file empty? ] + [ benchmark-error-vocabs-file eval-file empty? ] + } 0&& ; + +: success ( -- status ) + successful-report build-clean? status-clean status-dirty ? ; \ No newline at end of file diff --git a/extra/mason/twitter/authors.txt b/extra/mason/twitter/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/twitter/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/twitter/twitter.factor b/extra/mason/twitter/twitter.factor new file mode 100644 index 0000000000..21f1bcabc3 --- /dev/null +++ b/extra/mason/twitter/twitter.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: debugger fry kernel mason.config namespaces twitter ; +IN: mason.twitter + +: mason-tweet ( message -- ) + builder-twitter-username get builder-twitter-password get and + [ + [ + builder-twitter-username get twitter-username set + builder-twitter-password get twitter-password set + '[ _ tweet ] try + ] with-scope + ] [ drop ] if ; \ No newline at end of file From 549ddcd2dff1907115d72274f4af01644f3a150c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 21:24:36 -0500 Subject: [PATCH 33/35] make some words not macros --- basis/sorting/slots/slots-docs.factor | 4 ++-- basis/sorting/slots/slots-tests.factor | 12 ++++++++++++ basis/sorting/slots/slots.factor | 20 +++++++++++--------- 3 files changed, 25 insertions(+), 11 deletions(-) diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor index cc89d497e7..b427cf2956 100644 --- a/basis/sorting/slots/slots-docs.factor +++ b/basis/sorting/slots/slots-docs.factor @@ -14,7 +14,7 @@ HELP: compare-slots HELP: sort-by-slots { $values { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" } - { "sortedseq" sequence } + { "seq'" sequence } } { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." } { $examples @@ -42,7 +42,7 @@ HELP: split-by-slots HELP: sort-by { $values { "seq" sequence } { "sort-seq" "a sequence of comparators" } - { "sortedseq" sequence } + { "seq'" sequence } } { $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ; diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor index 83900461c3..e31b9be359 100644 --- a/basis/sorting/slots/slots-tests.factor +++ b/basis/sorting/slots/slots-tests.factor @@ -159,3 +159,15 @@ TUPLE: tuple2 d ; { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } } { length-test<=> <=> } sort-by ] unit-test + +[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ] +[ + { { 3 2 } { 1 2 } { 0 1 } { 1 1 } } + { length-test<=> <=> } sort-keys-by +] unit-test + +[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ] +[ + { { 3 2 } { 1 2 } { 0 1 } { 1 1 } } + { length-test<=> <=> } sort-values-by +] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor index efec960c27..9a0455c3a7 100644 --- a/basis/sorting/slots/slots.factor +++ b/basis/sorting/slots/slots.factor @@ -8,12 +8,13 @@ IN: sorting.slots ) #! sort-spec: { accessors comparator } [ slot-comparator ] map '[ _ 2|| +eq+ or ] ; -MACRO: sort-by-slots ( sort-specs -- quot ) - '[ [ _ compare-slots ] sort ] ; +: sort-by-slots ( seq sort-specs -- seq' ) + '[ _ compare-slots ] sort ; MACRO: compare-seq ( seq -- quot ) [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ; -MACRO: sort-by ( sort-seq -- quot ) - '[ [ _ compare-seq ] sort ] ; +: sort-by ( seq sort-seq -- seq' ) + '[ _ compare-seq ] sort ; -MACRO: sort-keys-by ( sort-seq -- quot ) +: sort-keys-by ( seq sort-seq -- seq' ) '[ [ first ] bi@ _ compare-seq ] sort ; -MACRO: sort-values-by ( sort-seq -- quot ) +: sort-values-by ( seq sort-seq -- seq' ) '[ [ second ] bi@ _ compare-seq ] sort ; MACRO: split-by-slots ( accessor-seqs -- quot ) - [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map + [ [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat + [ = ] compose ] map '[ [ _ 2&& ] slice monotonic-slice ] ; From 5e6cc3bf46a1177a697e5c73808da31e5a61faf9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 21:37:20 -0500 Subject: [PATCH 34/35] more api work for windows --- basis/windows/advapi32/advapi32.factor | 243 +++++++++++++++++++++++-- basis/windows/gdi32/gdi32.factor | 1 - basis/windows/kernel32/kernel32.factor | 2 +- basis/windows/user32/user32.factor | 2 +- 4 files changed, 227 insertions(+), 21 deletions(-) diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index f76e389dce..5b62f54795 100644 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,5 +1,6 @@ USING: alien.syntax kernel math windows.types math.bitwise ; IN: windows.advapi32 + LIBRARY: advapi32 CONSTANT: PROV_RSA_FULL 1 @@ -122,6 +123,34 @@ C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE +C-STRUCT: SECURITY_DESCRIPTOR + { "UCHAR" "Revision" } + { "UCHAR" "Sbz1" } + { "WORD" "Control" } + { "PVOID" "Owner" } + { "PVOID" "Group" } + { "PACL" "Sacl" } + { "PACL" "Dacl" } ; + +TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR + +CONSTANT: SE_OWNER_DEFAULTED 1 +CONSTANT: SE_GROUP_DEFAULTED 2 +CONSTANT: SE_DACL_PRESENT 4 +CONSTANT: SE_DACL_DEFAULTED 8 +CONSTANT: SE_SACL_PRESENT 16 +CONSTANT: SE_SACL_DEFAULTED 32 +CONSTANT: SE_DACL_AUTO_INHERIT_REQ 256 +CONSTANT: SE_SACL_AUTO_INHERIT_REQ 512 +CONSTANT: SE_DACL_AUTO_INHERITED 1024 +CONSTANT: SE_SACL_AUTO_INHERITED 2048 +CONSTANT: SE_DACL_PROTECTED 4096 +CONSTANT: SE_SACL_PROTECTED 8192 +CONSTANT: SE_SELF_RELATIVE 32768 + +TYPEDEF: DWORD SECURITY_DESCRIPTOR_CONTROL +TYPEDEF: SECURITY_DESCRIPTOR_CONTROL* PSECURITY_DESCRIPTOR_CONTROL + ! typedef enum _TOKEN_INFORMATION_CLASS { CONSTANT: TokenUser 1 @@ -141,6 +170,140 @@ CONSTANT: TokenSessionReference 14 CONSTANT: TokenSandBoxInert 15 ! } TOKEN_INFORMATION_CLASS; +TYPEDEF: DWORD ACCESS_MODE +C-ENUM: + NOT_USED_ACCESS + GRANT_ACCESS + SET_ACCESS + DENY_ACCESS + REVOKE_ACCESS + SET_AUDIT_SUCCESS + SET_AUDIT_FAILURE ; + +TYPEDEF: DWORD MULTIPLE_TRUSTEE_OPERATION +C-ENUM: + NO_MULTIPLE_TRUSTEE + TRUSTEE_IS_IMPERSONATE ; + +TYPEDEF: DWORD TRUSTEE_FORM +C-ENUM: + TRUSTEE_IS_SID + TRUSTEE_IS_NAME + TRUSTEE_BAD_FORM + TRUSTEE_IS_OBJECTS_AND_SID + TRUSTEE_IS_OBJECTS_AND_NAME ; + +TYPEDEF: DWORD TRUSTEE_TYPE +C-ENUM: + TRUSTEE_IS_UNKNOWN + TRUSTEE_IS_USER + TRUSTEE_IS_GROUP + TRUSTEE_IS_DOMAIN + TRUSTEE_IS_ALIAS + TRUSTEE_IS_WELL_KNOWN_GROUP + TRUSTEE_IS_DELETED + TRUSTEE_IS_INVALID + TRUSTEE_IS_COMPUTER ; + +TYPEDEF: DWORD SE_OBJECT_TYPE +C-ENUM: + SE_UNKNOWN_OBJECT_TYPE + SE_FILE_OBJECT + SE_SERVICE + SE_PRINTER + SE_REGISTRY_KEY + SE_LMSHARE + SE_KERNEL_OBJECT + SE_WINDOW_OBJECT + SE_DS_OBJECT + SE_DS_OBJECT_ALL + SE_PROVIDER_DEFINED_OBJECT + SE_WMIGUID_OBJECT + SE_REGISTRY_WOW64_32KEY ; + +TYPEDEF: TRUSTEE* PTRUSTEE + +C-STRUCT: TRUSTEE + { "PTRUSTEE" "pMultipleTrustee" } + { "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" } + { "TRUSTEE_FORM" "TrusteeForm" } + { "TRUSTEE_TYPE" "TrusteeType" } + { "LPTSTR" "ptstrName" } ; + +C-STRUCT: EXPLICIT_ACCESS + { "DWORD" "grfAccessPermissions" } + { "ACCESS_MODE" "grfAccessMode" } + { "DWORD" "grfInheritance" } + { "TRUSTEE" "Trustee" } ; + +C-STRUCT: SID_IDENTIFIER_AUTHORITY + { { "BYTE" 6 } "Value" } ; + +TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY + +CONSTANT: SECURITY_NULL_SID_AUTHORITY 0 +CONSTANT: SECURITY_WORLD_SID_AUTHORITY 1 +CONSTANT: SECURITY_LOCAL_SID_AUTHORITY 2 +CONSTANT: SECURITY_CREATOR_SID_AUTHORITY 3 +CONSTANT: SECURITY_NON_UNIQUE_AUTHORITY 4 +CONSTANT: SECURITY_NT_AUTHORITY 5 +CONSTANT: SECURITY_RESOURCE_MANAGER_AUTHORITY 6 + +CONSTANT: SECURITY_NULL_RID 0 +CONSTANT: SECURITY_WORLD_RID 0 +CONSTANT: SECURITY_LOCAL_RID 0 +CONSTANT: SECURITY_CREATOR_OWNER_RID 0 +CONSTANT: SECURITY_CREATOR_GROUP_RID 1 +CONSTANT: SECURITY_CREATOR_OWNER_SERVER_RID 2 +CONSTANT: SECURITY_CREATOR_GROUP_SERVER_RID 3 +CONSTANT: SECURITY_DIALUP_RID 1 +CONSTANT: SECURITY_NETWORK_RID 2 +CONSTANT: SECURITY_BATCH_RID 3 +CONSTANT: SECURITY_INTERACTIVE_RID 4 +CONSTANT: SECURITY_SERVICE_RID 6 +CONSTANT: SECURITY_ANONYMOUS_LOGON_RID 7 +CONSTANT: SECURITY_PROXY_RID 8 +CONSTANT: SECURITY_SERVER_LOGON_RID 9 +CONSTANT: SECURITY_PRINCIPAL_SELF_RID 10 +CONSTANT: SECURITY_AUTHENTICATED_USER_RID 11 +CONSTANT: SECURITY_LOGON_IDS_RID 5 +CONSTANT: SECURITY_LOGON_IDS_RID_COUNT 3 +CONSTANT: SECURITY_LOCAL_SYSTEM_RID 18 +CONSTANT: SECURITY_NT_NON_UNIQUE 21 +CONSTANT: SECURITY_BUILTIN_DOMAIN_RID 32 +CONSTANT: DOMAIN_USER_RID_ADMIN 500 +CONSTANT: DOMAIN_USER_RID_GUEST 501 +CONSTANT: DOMAIN_GROUP_RID_ADMINS 512 +CONSTANT: DOMAIN_GROUP_RID_USERS 513 +CONSTANT: DOMAIN_GROUP_RID_GUESTS 514 +CONSTANT: DOMAIN_ALIAS_RID_ADMINS 544 +CONSTANT: DOMAIN_ALIAS_RID_USERS 545 +CONSTANT: DOMAIN_ALIAS_RID_GUESTS 546 +CONSTANT: DOMAIN_ALIAS_RID_POWER_USERS 547 +CONSTANT: DOMAIN_ALIAS_RID_ACCOUNT_OPS 548 +CONSTANT: DOMAIN_ALIAS_RID_SYSTEM_OPS 549 +CONSTANT: DOMAIN_ALIAS_RID_PRINT_OPS 550 +CONSTANT: DOMAIN_ALIAS_RID_BACKUP_OPS 551 +CONSTANT: DOMAIN_ALIAS_RID_REPLICATOR 552 +CONSTANT: SE_GROUP_MANDATORY 1 +CONSTANT: SE_GROUP_ENABLED_BY_DEFAULT 2 +CONSTANT: SE_GROUP_ENABLED 4 +CONSTANT: SE_GROUP_OWNER 8 +CONSTANT: SE_GROUP_LOGON_ID -1073741824 + +! SID is a variable length structure +TYPEDEF: void* PSID + +TYPEDEF: EXPLICIT_ACCESS* PEXPLICIT_ACCESS + +TYPEDEF: DWORD SECURITY_INFORMATION +TYPEDEF: SECURITY_INFORMATION* PSECURITY_INFORMATION + +CONSTANT: OWNER_SECURITY_INFORMATION 1 +CONSTANT: GROUP_SECURITY_INFORMATION 2 +CONSTANT: DACL_SECURITY_INFORMATION 4 +CONSTANT: SACL_SECURITY_INFORMATION 8 + CONSTANT: DELETE HEX: 00010000 CONSTANT: READ_CONTROL HEX: 00020000 CONSTANT: WRITE_DAC HEX: 00040000 @@ -187,6 +350,34 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080 TOKEN_ADJUST_DEFAULT } flags ; foldable +CONSTANT: HKEY_CLASSES_ROOT 1 +CONSTANT: HKEY_CURRENT_CONFIG 2 +CONSTANT: HKEY_CURRENT_USER 3 +CONSTANT: HKEY_LOCAL_MACHINE 4 +CONSTANT: HKEY_USERS 5 + +CONSTANT: KEY_ALL_ACCESS HEX: 0001 +CONSTANT: KEY_CREATE_LINK HEX: 0002 +CONSTANT: KEY_CREATE_SUB_KEY HEX: 0004 +CONSTANT: KEY_ENUMERATE_SUB_KEYS HEX: 0008 +CONSTANT: KEY_EXECUTE HEX: 0010 +CONSTANT: KEY_NOTIFY HEX: 0020 +CONSTANT: KEY_QUERY_VALUE HEX: 0040 +CONSTANT: KEY_READ HEX: 0080 +CONSTANT: KEY_SET_VALUE HEX: 0100 +CONSTANT: KEY_WOW64_64KEY HEX: 0200 +CONSTANT: KEY_WOW64_32KEY HEX: 0400 +CONSTANT: KEY_WRITE HEX: 0800 + +CONSTANT: REG_BINARY 1 +CONSTANT: REG_DWORD 2 +CONSTANT: REG_EXPAND_SZ 3 +CONSTANT: REG_MULTI_SZ 4 +CONSTANT: REG_QWORD 5 +CONSTANT: REG_SZ 6 + +TYPEDEF: DWORD REGSAM + ! : I_ScGetCurrentGroupStateW ; ! : A_SHAFinal ; @@ -224,7 +415,19 @@ FUNCTION: BOOL AdjustTokenPrivileges ( HANDLE TokenHandle, PTOKEN_PRIVILEGES PreviousState, PDWORD ReturnLength ) ; -! : AllocateAndInitializeSid ; +FUNCTION: BOOL AllocateAndInitializeSid ( + PSID_IDENTIFIER_AUTHORITY pIdentifierAuthority, + BYTE nSubAuthorityCount, + DWORD dwSubAuthority0, + DWORD dwSubAuthority1, + DWORD dwSubAuthority2, + DWORD dwSubAuthority3, + DWORD dwSubAuthority4, + DWORD dwSubAuthority5, + DWORD dwSubAuthority6, + DWORD dwSubAuthority7, + PSID* pSid ) ; + ! : AllocateLocallyUniqueId ; ! : AreAllAccessesGranted ; ! : AreAnyAccessesGranted ; @@ -442,7 +645,8 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ; ! : GetExplicitEntriesFromAclA ; ! : GetExplicitEntriesFromAclW ; ! : GetFileSecurityA ; -! : GetFileSecurityW ; +FUNCTION: BOOL GetFileSecurityW ( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded ) ; +ALIAS: GetFileSecurity GetFileSecurityW ! : GetInformationCodeAuthzLevelW ; ! : GetInformationCodeAuthzPolicyW ; ! : GetInheritanceSourceA ; @@ -459,19 +663,20 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ; ! : GetMultipleTrusteeW ; ! : GetNamedSecurityInfoA ; ! : GetNamedSecurityInfoExA ; -! : GetNamedSecurityInfoExW ; -! : GetNamedSecurityInfoW ; +! FUNCTION: DWORD GetNamedSecurityInfoExW +FUNCTION: DWORD GetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID* ppsidOwner, PSID* ppsidGroup, PACL* ppDacl, PACL* ppSacl, PSECURITY_DESCRIPTOR* ppSecurityDescriptor ) ; +ALIAS: GetNamedSecurityInfo GetNamedSecurityInfoW ! : GetNumberOfEventLogRecords ; ! : GetOldestEventLogRecord ; ! : GetOverlappedAccessResults ; ! : GetPrivateObjectSecurity ; -! : GetSecurityDescriptorControl ; -! : GetSecurityDescriptorDacl ; -! : GetSecurityDescriptorGroup ; -! : GetSecurityDescriptorLength ; -! : GetSecurityDescriptorOwner ; -! : GetSecurityDescriptorRMControl ; -! : GetSecurityDescriptorSacl ; +FUNCTION: BOOL GetSecurityDescriptorControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSECURITY_DESCRIPTOR_CONTROL pControl, LPDWORD lpdwRevision ) ; +FUNCTION: BOOL GetSecurityDescriptorDacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbDaclPresent, PACL* pDacl, LPBOOL lpDaclDefaulted ) ; +FUNCTION: BOOL GetSecurityDescriptorGroup ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pGroup, LPBOOL lpGroupDefaulted ) ; +FUNCTION: BOOL GetSecurityDescriptorLength ( PSECURITY_DESCRIPTOR pSecurityDescriptor ) ; +FUNCTION: BOOL GetSecurityDescriptorOwner ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pOwner, LPBOOL lpOwnerDefaulted ) ; +FUNCTION: BOOL GetSecurityDescriptorRMControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PUCHAR RMControl ) ; +FUNCTION: BOOL GetSecurityDescriptorSacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbSaclPresent, PACL* pSacl, LPBOOL lpSaclDefaulted ) ; ! : GetSecurityInfo ; ! : GetSecurityInfoExA ; ! : GetSecurityInfoExW ; @@ -510,7 +715,7 @@ ALIAS: GetUserName GetUserNameW ! : ImpersonateNamedPipeClient ; ! : ImpersonateSelf ; FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ; -! : InitializeSecurityDescriptor ; +FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ; ! : InitializeSid ; ! : InitiateSystemShutdownA ; ! : InitiateSystemShutdownExA ; @@ -674,8 +879,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : RegConnectRegistryW ; ! : RegCreateKeyA ; ! : RegCreateKeyExA ; -! : RegCreateKeyExW ; -! : RegCreateKeyW ; +FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ; +! : RegCreateKeyW ! : RegDeleteKeyA ; ! : RegDeleteKeyW ; ! : RegDeleteValueA ; @@ -692,7 +897,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : RegLoadKeyA ; ! : RegLoadKeyW ; ! : RegNotifyChangeKeyValue ; -! : RegOpenCurrentUser ; +FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ; ! : RegOpenKeyA ; ! : RegOpenKeyExA ; ! : RegOpenKeyExW ; @@ -705,7 +910,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : RegQueryMultipleValuesW ; ! : RegQueryValueA ; ! : RegQueryValueExA ; -! : RegQueryValueExW ; +FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ; ! : RegQueryValueW ; ! : RegReplaceKeyA ; ! : RegReplaceKeyW ; @@ -756,7 +961,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : SetEntriesInAccessListA ; ! : SetEntriesInAccessListW ; ! : SetEntriesInAclA ; -! : SetEntriesInAclW ; +FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ; +ALIAS: SetEntriesInAcl SetEntriesInAclW ! : SetEntriesInAuditListA ; ! : SetEntriesInAuditListW ; ! : SetFileSecurityA ; @@ -767,7 +973,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL ! : SetNamedSecurityInfoA ; ! : SetNamedSecurityInfoExA ; ! : SetNamedSecurityInfoExW ; -! : SetNamedSecurityInfoW ; +FUNCTION: DWORD SetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID psidOwner, PSID psidGroup, PACL pDacl, PACL pSacl ) ; +ALIAS: SetNamedSecurityInfo SetNamedSecurityInfoW ! : SetPrivateObjectSecurity ; ! : SetPrivateObjectSecurityEx ; ! : SetSecurityDescriptorControl ; diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 794aa0e32e..9b7cd2e35e 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1501,7 +1501,6 @@ DESTRUCTOR: DeleteObject FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ; ALIAS: ExtTextOut ExtTextOutW ! FUNCTION: FillPath -FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ; ! FUNCTION: FillRgn ! FUNCTION: FixBrushOrgEx ! FUNCTION: FlattenPath diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 36acc5e346..4d3dd81a0e 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1477,7 +1477,7 @@ ALIAS: LoadLibraryEx LoadLibraryExW ! FUNCTION: LoadLibraryW ! FUNCTION: LoadModule ! FUNCTION: LoadResource -! FUNCTION: LocalAlloc +FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ; ! FUNCTION: LocalCompact ! FUNCTION: LocalFileTimeToFileTime ! FUNCTION: LocalFlags diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 9daac21697..f3bc1becb2 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -807,7 +807,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ; ! FUNCTION: EqualRect ! FUNCTION: ExcludeUpdateRgn ! FUNCTION: ExitWindowsEx -! FUNCTION: FillRect +FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ; FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ; FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ; ! FUNCTION: FindWindowExW From e59f69ba6fe1a585357a4e88d1efecd642395e17 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 17 Apr 2009 22:24:36 -0500 Subject: [PATCH 35/35] ignore .so and a.out --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 22dda8efb4..b52c593b49 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,5 @@ build-support/wordsize .#* *.swo checksums.txt +*.so +a.out