From 2793d9b1954299d03c09c6bc13cefc4534065ffa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 8 Jun 2008 16:47:20 -0500 Subject: [PATCH] Fix unit tests --- core/alien/compiler/compiler-tests.factor | 30 +++++++++++----------- core/effects/effects-tests.factor | 6 +++-- core/optimizer/optimizer-tests.factor | 18 ++++++------- extra/calendar/calendar.factor | 19 +++++++------- extra/documents/documents.factor | 5 ++-- extra/help/help.factor | 2 +- extra/locals/backend/backend-tests.factor | 21 +++++++-------- extra/present/present.factor | 2 ++ extra/tools/profiler/profiler-tests.factor | 4 +-- 9 files changed, 57 insertions(+), 50 deletions(-) diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor index 5d847e364f..eb7652aefd 100755 --- a/core/alien/compiler/compiler-tests.factor +++ b/core/alien/compiler/compiler-tests.factor @@ -77,7 +77,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with -: indirect-test-1 +: indirect-test-1 ( ptr -- result ) "int" { } "cdecl" alien-indirect ; { 1 1 } [ indirect-test-1 ] must-infer-as @@ -86,7 +86,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ -1 indirect-test-1 ] must-fail -: indirect-test-2 +: indirect-test-2 ( x y ptr -- result ) "int" { "int" "int" } "cdecl" alien-indirect gc ; { 3 1 } [ indirect-test-2 ] must-infer-as @@ -95,7 +95,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] unit-test -: indirect-test-3 +: indirect-test-3 ( a b c d ptr -- result ) "int" { "int" "int" "int" "int" } "stdcall" alien-indirect gc ; @@ -139,7 +139,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3, ! Make sure XT doesn't get clobbered in stack frame -: ffi_test_31 +: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y ) "void" f "ffi_test_31" { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } @@ -286,21 +286,21 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; ! Test callbacks -: callback-1 "void" { } "cdecl" [ ] alien-callback ; +: callback-1 ( -- callback ) "void" { } "cdecl" [ ] alien-callback ; [ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test [ t ] [ callback-1 alien? ] unit-test -: callback_test_1 "void" { } "cdecl" alien-indirect ; +: callback_test_1 ( ptr -- ) "void" { } "cdecl" alien-indirect ; [ ] [ callback-1 callback_test_1 ] unit-test -: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; +: callback-2 ( -- callback ) "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; [ ] [ callback-2 callback_test_1 ] unit-test -: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; +: callback-3 ( -- callback ) "void" { } "cdecl" [ 5 "x" set ] alien-callback ; [ t ] [ namestack* @@ -314,7 +314,7 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; ] with-scope ] unit-test -: callback-4 +: callback-4 ( -- callback ) "void" { } "cdecl" [ "Hello world" write ] alien-callback gc ; @@ -322,14 +322,14 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; [ callback-4 callback_test_1 ] with-string-writer ] unit-test -: callback-5 +: callback-5 ( -- callback ) "void" { } "cdecl" [ gc ] alien-callback ; [ "testing" ] [ "testing" callback-5 callback_test_1 ] unit-test -: callback-5a +: callback-5a ( -- callback ) "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; ! Hack; if we're on ARM, we probably don't have much RAM, so @@ -340,26 +340,26 @@ FUNCTION: ulonglong ffi_test_38 ( ulonglong x, ulonglong y ) ; ! ] unit-test ! ] unless -: callback-6 +: callback-6 ( -- callback ) "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; [ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test -: callback-7 +: callback-7 ( -- callback ) "void" { } "cdecl" [ 1000 sleep ] alien-callback ; [ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test [ f ] [ namespace global eq? ] unit-test -: callback-8 +: callback-8 ( -- callback ) "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; [ ] [ callback-8 callback_test_1 ] unit-test -: callback-9 +: callback-9 ( -- callback ) "int" { "int" "int" "int" } "cdecl" [ + + 1+ ] alien-callback ; diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 234f567f25..1c2b2f766d 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -1,9 +1,11 @@ IN: effects.tests -USING: effects tools.test ; +USING: effects tools.test prettyprint accessors sequences ; [ t ] [ 1 1 2 2 effect<= ] unit-test [ f ] [ 1 0 2 2 effect<= ] unit-test [ t ] [ 2 2 2 2 effect<= ] unit-test [ f ] [ 3 3 2 2 effect<= ] unit-test [ f ] [ 2 3 2 2 effect<= ] unit-test -[ t ] [ 2 3 f effect<= ] unit-test +[ 2 ] [ (( a b -- c )) in>> length ] unit-test +[ 1 ] [ (( a b -- c )) out>> length ] unit-test +[ "(( a b -- c ))" ] [ (( a b -- c )) unparse ] unit-test diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor index 6f4ae2c1d5..7032e58b3f 100755 --- a/core/optimizer/optimizer-tests.factor +++ b/core/optimizer/optimizer-tests.factor @@ -101,7 +101,7 @@ TUPLE: pred-test ; ! regression GENERIC: void-generic ( obj -- * ) -: breakage "hi" void-generic ; +: breakage ( -- * ) "hi" void-generic ; [ t ] [ \ breakage compiled? ] unit-test [ breakage ] must-fail @@ -116,12 +116,12 @@ GENERIC: void-generic ( obj -- * ) ! another regression : constant-branch-fold-0 "hey" ; foldable -: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline +: constant-branch-fold-1 ( -- ? ) constant-branch-fold-0 "hey" = ; inline [ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test ! another regression : foo f ; -: bar foo 4 4 = and ; +: bar ( -- ? ) foo 4 4 = and ; [ f ] [ bar ] unit-test ! ensure identities are working in some form @@ -131,7 +131,7 @@ GENERIC: void-generic ( obj -- * ) ] unit-test ! compiling with a non-literal class failed -: -regression ; +: -regression ( class -- tuple ) ; [ t ] [ \ -regression compiled? ] unit-test @@ -254,7 +254,7 @@ TUPLE: silly-tuple a b ; [ ] [ [ ] dataflow optimize drop ] unit-test ! Make sure we have sane heuristics -: should-inline? method flat-length 10 <= ; +: should-inline? ( generic class -- ? ) method flat-length 10 <= ; [ t ] [ \ fixnum \ shift should-inline? ] unit-test [ f ] [ \ array \ equal? should-inline? ] unit-test @@ -264,7 +264,7 @@ TUPLE: silly-tuple a b ; [ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test ! Regression -: lift-throw-tail-regression +: lift-throw-tail-regression ( obj -- obj str ) dup integer? [ "an integer" ] [ dup string? [ "a string" ] [ "error" throw @@ -294,7 +294,7 @@ TUPLE: silly-tuple a b ; GENERIC: generic-inline-test ( x -- y ) M: integer generic-inline-test ; -: generic-inline-test-1 +: generic-inline-test-1 ( -- x ) 1 generic-inline-test generic-inline-test @@ -319,7 +319,7 @@ M: integer generic-inline-test ; HINTS: recursive-inline-hang array ; -: recursive-inline-hang-1 +: recursive-inline-hang-1 ( -- a ) { } recursive-inline-hang ; [ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test @@ -350,7 +350,7 @@ USE: sequences.private [ 2 4 6.0 0 ] [ counter-example' ] unit-test -: member-test { + - * / /i } member? ; +: member-test ( obj -- ? ) { + - * / /i } member? ; \ member-test must-infer [ ] [ \ member-test word-dataflow optimize 2drop ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index f33e975c9a..e3cf849109 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -91,13 +91,13 @@ PRIVATE> [ hour>> ] [ minute>> ] [ second>> ] tri ; MEMO: instant ( -- dt ) 0 0 0 0 0 0 ; -: years ( n -- dt ) instant swap >>year ; -: months ( n -- dt ) instant swap >>month ; -: days ( n -- dt ) instant swap >>day ; +: years ( n -- dt ) instant clone swap >>year ; +: months ( n -- dt ) instant clone swap >>month ; +: days ( n -- dt ) instant clone swap >>day ; : weeks ( n -- dt ) 7 * days ; -: hours ( n -- dt ) instant swap >>hour ; -: minutes ( n -- dt ) instant swap >>minute ; -: seconds ( n -- dt ) instant swap >>second ; +: hours ( n -- dt ) instant clone swap >>hour ; +: minutes ( n -- dt ) instant clone swap >>minute ; +: seconds ( n -- dt ) instant clone swap >>second ; : milliseconds ( n -- dt ) 1000 / seconds ; GENERIC: leap-year? ( obj -- ? ) @@ -274,14 +274,15 @@ M: timestamp time- M: duration time- before time+ ; -MEMO: ( -- timestamp ) 0 0 0 0 0 0 instant ; +MEMO: ( -- timestamp ) +0 0 0 0 0 0 instant ; : valid-timestamp? ( timestamp -- ? ) clone instant >>gmt-offset dup time- time+ = ; -: unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 instant ; foldable +MEMO: unix-1970 ( -- timestamp ) + 1970 1 1 0 0 0 instant ; : millis>timestamp ( n -- timestamp ) >r unix-1970 r> milliseconds time+ ; diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index c13f08c293..9e4802c2ef 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io kernel math models namespaces sequences strings -splitting combinators unicode.categories math.order accessors ; +USING: accessors arrays io kernel math models namespaces +sequences strings splitting combinators unicode.categories +math.order ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; diff --git a/extra/help/help.factor b/extra/help/help.factor index e7ad29a741..d3c899ece7 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -50,7 +50,7 @@ M: word article-title word-name ] [ [ word-name ] - [ stack-effect [ effect>string " " prepend ] [ "" if ] if* ] bi + [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi append ] if ; diff --git a/extra/locals/backend/backend-tests.factor b/extra/locals/backend/backend-tests.factor index 41caa87fae..9352714509 100644 --- a/extra/locals/backend/backend-tests.factor +++ b/extra/locals/backend/backend-tests.factor @@ -5,34 +5,35 @@ USING: tools.test locals.backend kernel arrays ; [ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test -: get-local-test-1 3 >r 1 get-local r> drop ; +: get-local-test-1 ( -- x ) 3 >r 1 get-local r> drop ; -{ 0 1 } [ get-local-test-1 ] must-infer-as +\ get-local-test-1 must-infer [ 3 ] [ get-local-test-1 ] unit-test -: get-local-test-2 3 4 >r >r 2 get-local 2 drop-locals ; +: get-local-test-2 ( -- x ) 3 4 >r >r 2 get-local 2 drop-locals ; -{ 0 1 } [ get-local-test-2 ] must-infer-as +\ get-local-test-2 must-infer [ 4 ] [ get-local-test-2 ] unit-test -: get-local-test-3 3 4 >r >r 2 get-local r> r> 2array ; +: get-local-test-3 ( -- a b ) 3 4 >r >r 2 get-local r> r> 2array ; -{ 0 2 } [ get-local-test-3 ] must-infer-as +\ get-local-test-3 must-infer [ 4 { 3 4 } ] [ get-local-test-3 ] unit-test -: get-local-test-4 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ; +: get-local-test-4 ( -- a b ) + 3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ; -{ 0 2 } [ get-local-test-4 ] must-infer-as +\ get-local-test-4 must-infer [ 4 { 3 4 } ] [ get-local-test-4 ] unit-test [ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test -: load-locals-test-1 1 2 2 load-locals r> r> ; +: load-locals-test-1 ( -- a b ) 1 2 2 load-locals r> r> ; -{ 0 2 } [ load-locals-test-1 ] must-infer-as +\ load-locals-test-1 must-infer [ 1 2 ] [ load-locals-test-1 ] unit-test diff --git a/extra/present/present.factor b/extra/present/present.factor index 1fae84184a..3ccc1afe40 100644 --- a/extra/present/present.factor +++ b/extra/present/present.factor @@ -12,4 +12,6 @@ M: string present ; M: word present word-name ; +M: effect present effect>string ; + M: f present drop "" ; diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor index 450a024a1e..335733d109 100755 --- a/extra/tools/profiler/profiler-tests.factor +++ b/extra/tools/profiler/profiler-tests.factor @@ -20,9 +20,9 @@ alien tools.profiler.private sequences ; [ ] [ \ + usage-profile. ] unit-test -: callback-test "void" { } "cdecl" [ ] alien-callback ; +: callback-test ( -- callback ) "void" { } "cdecl" [ ] alien-callback ; -: indirect-test "void" { } "cdecl" alien-indirect ; +: indirect-test ( callback -- ) "void" { } "cdecl" alien-indirect ; : foobar ;