diff options
Diffstat (limited to 'tests')
199 files changed, 9193 insertions, 222 deletions
diff --git a/tests/000/binding.expected b/tests/000/binding.expected new file mode 100644 index 00000000..9e5303f0 --- /dev/null +++ b/tests/000/binding.expected @@ -0,0 +1,6 @@ +x="1" +y="2" +z[0]="1" +z[1]="2" +a="1" +b="0" diff --git a/tests/000/binding.txr b/tests/000/binding.txr new file mode 100644 index 00000000..95faa20d --- /dev/null +++ b/tests/000/binding.txr @@ -0,0 +1,5 @@ +@(bind x 1) +@(bind y 2) +@(rebind z (x y)) +@(bind (a b) (0 1)) +@(rebind (a b) (b a)) diff --git a/tests/000/nilvar.expected b/tests/000/nilvar.expected new file mode 100644 index 00000000..70985094 --- /dev/null +++ b/tests/000/nilvar.expected @@ -0,0 +1 @@ +a:c diff --git a/tests/000/nilvar.txr b/tests/000/nilvar.txr new file mode 100644 index 00000000..a6d1391c --- /dev/null +++ b/tests/000/nilvar.txr @@ -0,0 +1,3 @@ +@(next :string "a !b c") +@(coll)@(cases)@{nil /!\S+/}@(or)@{var /\S+/}@(end)@(end) +@(do (put-line (join-with ":" var))) diff --git a/tests/002/query-1.txr b/tests/002/query-1.txr index 0b4eced2..4bd6c97f 100644 --- a/tests/002/query-1.txr +++ b/tests/002/query-1.txr @@ -1,3 +1,5 @@ +@(do (unless (path-executable-to-me-p "/bin/sh") + (exit 13))) @(next `!ls @TESTDIR/proc | sort -n`) @(collect) @{process /[0-9]+/} diff --git a/tests/006/freeform-4.expected b/tests/006/freeform-4.expected new file mode 100644 index 00000000..62857f54 --- /dev/null +++ b/tests/006/freeform-4.expected @@ -0,0 +1,26 @@ +### +FF: +1 +2 + /FF + +X, Y : 1 2 + +### +FF: +3 +4 + /FF + +X, Y : 3 4 + +X[0]="1" +X[1]="3" +Y[0]="2" +Y[1]="4" +FF[0]="1\ +2\ +" +FF[1]="3\ +4\ +" diff --git a/tests/006/freeform-4.txr b/tests/006/freeform-4.txr new file mode 100644 index 00000000..328626eb --- /dev/null +++ b/tests/006/freeform-4.txr @@ -0,0 +1,20 @@ +@(next :list '("1" "2" "3" "4")) +@(collect) +@ (all) +@X +@Y +@ (and) +@ (freeform 2) +@FF +@ (end) +@(end) +@(output) +@ (repeat) +### +FF: +@FF /FF + +X, Y : @X @Y + +@ (end) +@(end) diff --git a/tests/006/freeform-5.expected b/tests/006/freeform-5.expected new file mode 100644 index 00000000..99433ca3 --- /dev/null +++ b/tests/006/freeform-5.expected @@ -0,0 +1,4 @@ +bar="BAR" +zzy="ZZY" +next="NEXT" +nextnext="NEXTNEXT" diff --git a/tests/006/freeform-5.txr b/tests/006/freeform-5.txr new file mode 100644 index 00000000..f1ec48c8 --- /dev/null +++ b/tests/006/freeform-5.txr @@ -0,0 +1,7 @@ +@(next :list (append (repeat (list (mkstring 99 #\A)) 100) + '("FOOBARXYZZY" "NEXT" "NEXTNEXT"))) +@(freeform) +@(skip)FOO@{bar}XY +@zzy +@next +@nextnext diff --git a/tests/007/except-3.expected b/tests/007/except-3.expected new file mode 100644 index 00000000..257cc564 --- /dev/null +++ b/tests/007/except-3.expected @@ -0,0 +1 @@ +foo diff --git a/tests/007/except-3.txr b/tests/007/except-3.txr new file mode 100644 index 00000000..f672c7d2 --- /dev/null +++ b/tests/007/except-3.txr @@ -0,0 +1,3 @@ +@(next (open-command "echo foo; kill -KILL $$") :nothrow) +@a +@(do (put-line a)) diff --git a/tests/007/except-4.expected b/tests/007/except-4.expected new file mode 100644 index 00000000..5716ca59 --- /dev/null +++ b/tests/007/except-4.expected @@ -0,0 +1 @@ +bar diff --git a/tests/007/except-4.txr b/tests/007/except-4.txr new file mode 100644 index 00000000..50c85539 --- /dev/null +++ b/tests/007/except-4.txr @@ -0,0 +1,8 @@ +@(include "../common") +@(try) +@(next (open-command "echo foo; kill -KILL $$")) +@a +@(catch) +@(bind a "bar") +@(end) +@(do (put-line a)) diff --git a/tests/008/call-2.txr b/tests/008/call-2.txr new file mode 100644 index 00000000..10257f62 --- /dev/null +++ b/tests/008/call-2.txr @@ -0,0 +1,6 @@ +@(define foo (var)) +@var +@(end) +@(next :list '("A" "B")) +@(call (quote foo) "A") +@(call (quote foo) "B") diff --git a/tests/008/call.expected b/tests/008/call.expected new file mode 100644 index 00000000..f644dfc5 --- /dev/null +++ b/tests/008/call.expected @@ -0,0 +1,2 @@ +correct +1 diff --git a/tests/008/call.txr b/tests/008/call.txr new file mode 100644 index 00000000..0cbb39f6 --- /dev/null +++ b/tests/008/call.txr @@ -0,0 +1,13 @@ +@(next :list '("1")) +@(define match1 (A)) +@ (all) +1 +@ (and) +@A +@ (end) +@(end) +@(call 'match1 A) +@(output) +correct +@A +@(end) diff --git a/tests/008/mdo.txr b/tests/008/mdo.txr new file mode 100644 index 00000000..dbc8b50c --- /dev/null +++ b/tests/008/mdo.txr @@ -0,0 +1,7 @@ +@(mdo (defvar a)) +@(mdo (push 1 a)) +@(define foo) +@ (mdo (push 2 a)) +@(end) +@(foo) +@(do (assert (equal a '(2 1)))) diff --git a/tests/008/no-stdin-hang.txr b/tests/008/no-stdin-hang.txr new file mode 100644 index 00000000..4b29f021 --- /dev/null +++ b/tests/008/no-stdin-hang.txr @@ -0,0 +1,5 @@ +@(define foo (var)) +@(next :list '("a")) +@var +@(end) +@(foo x) diff --git a/tests/008/repeat.expected b/tests/008/repeat.expected new file mode 100644 index 00000000..495d096a --- /dev/null +++ b/tests/008/repeat.expected @@ -0,0 +1,3 @@ +1 3 a +2 3 b +3 3 c diff --git a/tests/008/repeat.txr b/tests/008/repeat.txr new file mode 100644 index 00000000..dba54831 --- /dev/null +++ b/tests/008/repeat.txr @@ -0,0 +1,6 @@ +@(bind a ("a" "b" "c")) +@(output) +@(repeat :counter (i 1) :vars ((x (len a)))) +@i @x @a +@(end) +@(end) diff --git a/tests/009/json.expected b/tests/009/json.expected index 6330a595..e9d2e644 100644 --- a/tests/009/json.expected +++ b/tests/009/json.expected @@ -1,54 +1,54 @@ -AST: #H(() ("web-app" #H(() ("servlet" #(#H(() ("servlet-name" "cofaxCDS") ("servlet-class" "org.cofax.cds.CDSServlet") - ("init-param" #H(() ("dataStoreName" "cofax") ("cachePagesRefresh" 10.0) ("defaultListTemplate" "listTemplate.htm") - ("useJSP" :false) ("cachePagesDirtyRead" 10.0) ("useDataStore" :true) - ("cachePagesTrack" 200.0) ("dataStoreMaxConns" 100.0) ("cachePackageTagsStore" 200.0) - ("configGlossary:poweredBy" "Cofax") ("dataStoreInitConns" 10.0) - ("dataStorePassword" "dataStoreTestQuery") ("templateLoaderClass" "org.cofax.FilesTemplateLoader") - ("configGlossary:poweredByIcon" "/images/cofax.gif") ("dataStoreTestQuery" "SET NOCOUNT ON;select test='test';") - ("dataStoreConnUsageLimit" 100.0) ("dataStoreUrl" "jdbc:microsoft:sqlserver://LOCALHOST:1433;DatabaseName=goon") - ("redirectionClass" "org.cofax.SqlRedirection") ("dataStoreUser" "sa") - ("jspListTemplate" "listTemplate.jsp") ("configGlossary:adminEmail" "ksm@pobox.com") - ("cacheTemplatesTrack" 100.0) ("defaultFileTemplate" "articleTemplate.htm") - ("templateOverridePath" "") ("cachePagesStore" 100.0) ("templatePath" "templates") - ("configGlossary:installationAt" "Philadelphia, PA") ("dataStoreClass" "org.cofax.SqlDataStore") - ("cachePackageTagsTrack" 200.0) ("jspFileTemplate" "articleTemplate.jsp") - ("dataStoreLogFile" "/usr/local/tomcat/logs/datastore.log") ("cacheTemplatesRefresh" 15.0) - ("cacheTemplatesStore" 50.0) ("searchEngineRobotsDb" "WEB-INF/robots.db") - ("templateProcessorClass" "org.cofax.WysiwygTemplate") ("dataStoreDriver" "com.microsoft.jdbc.sqlserver.SQLServerDriver") - ("dataStoreLogLevel" "debug") ("cachePackageTagsRefresh" 60.0) - ("configGlossary:staticPath" "/content/static") ("maxUrlLength" 500.0) - ("searchEngineFileTemplate" "forSearchEngines.htm") ("searchEngineListTemplate" "forSearchEnginesList.htm")))) - #H(() ("servlet-name" "cofaxEmail") ("servlet-class" "org.cofax.cds.EmailServlet") - ("init-param" #H(() ("mailHost" "mail1") ("mailHostOverride" "mail2")))) - #H(() ("servlet-name" "cofaxAdmin") ("servlet-class" "org.cofax.cds.AdminServlet")) - #H(() ("servlet-name" "fileServlet") ("servlet-class" "org.cofax.cds.FileServlet")) - #H(() ("servlet-name" "cofaxTools") ("servlet-class" "org.cofax.cms.CofaxToolsServlet") - ("init-param" #H(() ("adminGroupID" 4.0) ("fileTransferFolder" "/usr/local/tomcat/webapps/content/fileTransferFolder") - ("lookInContext" 1.0) ("dataLogMaxSize" "") ("removePageCache" "/content/admin/remove?cache=pages&id=") - ("dataLogLocation" "/usr/local/tomcat/logs/dataLog.log") ("logMaxSize" "") - ("betaServer" :true) ("logLocation" "/usr/local/tomcat/logs/CofaxTools.log") - ("removeTemplateCache" "/content/admin/remove?cache=templates&id=") - ("templatePath" "toolstemplates/") ("dataLog" 1.0) ("log" 1.0)))))) - ("taglib" #H(() ("taglib-uri" "cofax.tld") ("taglib-location" "/WEB-INF/tlds/cofax.tld"))) - ("servlet-mapping" #H(() ("cofaxAdmin" "/admin/*") ("cofaxCDS" "/") ("fileServlet" "/static/*") - ("cofaxEmail" "/cofaxutil/aemail/*") ("cofaxTools" "/tools/*")))))) +AST: (("web-app" (("servlet" #((("servlet-name" "cofaxCDS") ("servlet-class" "org.cofax.cds.CDSServlet") + ("init-param" (("configGlossary:installationAt" "Philadelphia, PA") ("configGlossary:adminEmail" "ksm@pobox.com") + ("configGlossary:poweredBy" "Cofax") ("configGlossary:poweredByIcon" "/images/cofax.gif") + ("configGlossary:staticPath" "/content/static") ("templateProcessorClass" "org.cofax.WysiwygTemplate") + ("templateLoaderClass" "org.cofax.FilesTemplateLoader") ("templatePath" "templates") + ("templateOverridePath" "") ("defaultListTemplate" "listTemplate.htm") + ("defaultFileTemplate" "articleTemplate.htm") ("useJSP" :false) + ("jspListTemplate" "listTemplate.jsp") ("jspFileTemplate" "articleTemplate.jsp") + ("cachePackageTagsTrack" 200.0) ("cachePackageTagsStore" 200.0) + ("cachePackageTagsRefresh" 60.0) ("cacheTemplatesTrack" 100.0) + ("cacheTemplatesStore" 50.0) ("cacheTemplatesRefresh" 15.0) ("cachePagesTrack" 200.0) + ("cachePagesStore" 100.0) ("cachePagesRefresh" 10.0) ("cachePagesDirtyRead" 10.0) + ("searchEngineListTemplate" "forSearchEnginesList.htm") ("searchEngineFileTemplate" "forSearchEngines.htm") + ("searchEngineRobotsDb" "WEB-INF/robots.db") ("useDataStore" :true) + ("dataStoreClass" "org.cofax.SqlDataStore") ("redirectionClass" "org.cofax.SqlRedirection") + ("dataStoreName" "cofax") ("dataStoreDriver" "com.microsoft.jdbc.sqlserver.SQLServerDriver") + ("dataStoreUrl" "jdbc:microsoft:sqlserver://LOCALHOST:1433;DatabaseName=goon") + ("dataStoreUser" "sa") ("dataStorePassword" "dataStoreTestQuery") + ("dataStoreTestQuery" "SET NOCOUNT ON;select test='test';") ("dataStoreLogFile" "/usr/local/tomcat/logs/datastore.log") + ("dataStoreInitConns" 10.0) ("dataStoreMaxConns" 100.0) ("dataStoreConnUsageLimit" 100.0) + ("dataStoreLogLevel" "debug") ("maxUrlLength" 500.0)))) + (("servlet-name" "cofaxEmail") ("servlet-class" "org.cofax.cds.EmailServlet") + ("init-param" (("mailHost" "mail1") ("mailHostOverride" "mail2")))) + (("servlet-name" "cofaxAdmin") ("servlet-class" "org.cofax.cds.AdminServlet")) + (("servlet-name" "fileServlet") ("servlet-class" "org.cofax.cds.FileServlet")) + (("servlet-name" "cofaxTools") ("servlet-class" "org.cofax.cms.CofaxToolsServlet") + ("init-param" (("templatePath" "toolstemplates/") ("log" 1.0) ("logLocation" "/usr/local/tomcat/logs/CofaxTools.log") + ("logMaxSize" "") ("dataLog" 1.0) ("dataLogLocation" "/usr/local/tomcat/logs/dataLog.log") + ("dataLogMaxSize" "") ("removePageCache" "/content/admin/remove?cache=pages&id=") + ("removeTemplateCache" "/content/admin/remove?cache=templates&id=") + ("fileTransferFolder" "/usr/local/tomcat/webapps/content/fileTransferFolder") + ("lookInContext" 1.0) ("adminGroupID" 4.0) ("betaServer" :true)))))) + ("servlet-mapping" (("cofaxCDS" "/") ("cofaxEmail" "/cofaxutil/aemail/*") ("cofaxAdmin" "/admin/*") + ("fileServlet" "/static/*") ("cofaxTools" "/tools/*"))) + ("taglib" (("taglib-uri" "cofax.tld") ("taglib-location" "/WEB-INF/tlds/cofax.tld")))))) Unmatched junk: "" -AST: #("JSON Test Pattern pass1" #H(() ("object with 1 member" #("array with 1 element"))) - #H(()) #() -42.0 :true :false :null #H(() ("compact" #(1.0 2.0 3.0 4.0 5.0 6.0 7.0)) ("quotes" "" \" %22 0x22 034 "") - ("object" #H(())) ("0123456789" "digit") ("" 2.3456789012e76) - ("ALPHA" "ABCDEFGHIJKLMNOPQRSTUVWYZ") ("digit" "0123456789") - ("quote" "\"") (" s p a c e d " #(1.0 2.0 3.0 4.0 5.0 6.0 7.0)) - ("one" 1.0) ("alpha" "abcdefghijklmnopqrstuvwyz") ("E" 1.23456789e34) - ("comment" "// /* <!-- --") ("special" "`1~!@#$%^&*()_+-={':[,]}|;.</>?") - ("url" "http://www.JSON.org/") ("null" :null) ("hex" "ģ䕧覫췯ꯍ") - ("controls" "\b\f\n\r\t") ("address" "50 St. James Street") ("# -- --> */" " ") - ("\\/\\\\\"쫾몾ꮘﳞ볚\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?" "A key can be any string") - ("space" " ") ("e" 1.23456789e-13) ("real" -9876.54321) ("array" #()) - ("jsontext" "{\"object with 1 member\":[\"array with 1 element\"]}") - ("zero" 0.0) ("false" :false) ("slash" "/ & \\/") ("integer" 1234567890.0) - ("backslash" "\\\\") ("true" :true)) +AST: #("JSON Test Pattern pass1" (("object with 1 member" #("array with 1 element"))) + nil #() -42.0 :true :false :null (("integer" 1234567890.0) ("real" -9876.54321) ("e" 1.23456789e-13) + ("E" 1.23456789e34) ("" 2.3456789012e76) ("zero" 0.0) ("one" 1.0) + ("space" " ") ("quote" "\"") ("backslash" "\\\\") ("controls" "\b\f\n\r\t") + ("slash" "/ & \\/") ("alpha" "abcdefghijklmnopqrstuvwyz") ("ALPHA" "ABCDEFGHIJKLMNOPQRSTUVWYZ") + ("digit" "0123456789") ("0123456789" "digit") ("special" "`1~!@#$%^&*()_+-={':[,]}|;.</>?") + ("hex" "ģ䕧覫췯ꯍ") ("true" :true) ("false" :false) ("null" :null) + ("array" #()) ("object" nil) ("address" "50 St. James Street") + ("url" "http://www.JSON.org/") ("comment" "// /* <!-- --") ("# -- --> */" " ") + (" s p a c e d " #(1.0 2.0 3.0 4.0 5.0 6.0 7.0)) ("compact" #(1.0 2.0 3.0 4.0 5.0 6.0 7.0)) + ("jsontext" "{\"object with 1 member\":[\"array with 1 element\"]}") + ("quotes" "" \" %22 0x22 034 "") ("\\/\\\\\"쫾몾ꮘﳞ볚\b\f\n\r\t`1~!@#$%^&*()_+-=[]{}|;:',./<>?" + "A key can be any string")) 0.5 98.6 99.44 1066.0 10.0 1.0 0.1 1.0 2.0 2.0 "rosebud") Unmatched junk: "" diff --git a/tests/009/json.txr b/tests/009/json.txr index 5c2732e8..1c705de1 100644 --- a/tests/009/json.txr +++ b/tests/009/json.txr @@ -57,16 +57,15 @@ @(end) @; @; Recognize an object: a collection of string/value pairs, -@; turning them into an equal-based hash table +@; turning them into a list. @; @(define object (v))@\ @(local p e pair)@\ - @(ws){@(ws)@(coll :gap 0 :vars (pair))@\ + @(ws){@(ws)@(coll :gap 0 :vars (v))@\ @(string p):@(value e)@/,?/@\ - @(bind pair (p e))@\ + @(bind v (p e))@\ @(until)}@\ @(end)}@(ws)@\ - @(bind v @(progn ^#H((:equal-based) ,*pair)))@\ @(end) @; @; Recognize an array. diff --git a/tests/010/cons.tl b/tests/010/cons.tl new file mode 100644 index 00000000..de293652 --- /dev/null +++ b/tests/010/cons.tl @@ -0,0 +1,14 @@ +(load "../common") + +(let ((x (list* 1 2 3 4))) + (mtest + (set x (delcons x x)) (2 3 . 4) + (set x (delcons x x)) (3 . 4) + (set x (delcons x x)) 4 + (set x (delcons x x)) 4)) + +(let ((x (list* 1 2 3 4 5))) + (mtest + (delcons (cdr x) x) (1 3 4 . 5) + (delcons (cddr x) x) (1 3 . 5) + (delcons (cdr x) x) (1 . 5))) diff --git a/tests/010/eof-status.expected b/tests/010/eof-status.expected new file mode 100644 index 00000000..2b636133 --- /dev/null +++ b/tests/010/eof-status.expected @@ -0,0 +1,2 @@ +a="a" +status="5" diff --git a/tests/010/eof-status.txr b/tests/010/eof-status.txr new file mode 100644 index 00000000..0da9c633 --- /dev/null +++ b/tests/010/eof-status.txr @@ -0,0 +1,3 @@ +@(next (open-command "echo a; exit 5")) +@a +@(eof status) diff --git a/tests/010/hash.tl b/tests/010/hash.tl new file mode 100644 index 00000000..d6a8542b --- /dev/null +++ b/tests/010/hash.tl @@ -0,0 +1,94 @@ +(load "../common") + +(mtest + (uni #H(() ("a") ("b")) #H(() ("b") ("c"))) (("a") ("b") ("c")) + (diff #H(() ("a") ("b")) #H(() ("b") ("c"))) (("a")) + (isec #H(() ("a") ("b")) #H(() ("b") ("c"))) (("b"))) + +(mtest + [group-by identity '(1 1 2 2 3 3 3)] #H(() (1 (1 1)) (2 (2 2)) (3 (3 3 3))) + (group-by (op mod @1 3) (range 0 10)) #H(() (0 (0 3 6 9)) + (1 (1 4 7 10)) + (2 (2 5 8))) + [group-map (op mod @1 3) sum (range 0 10)] #H(() (0 18) (1 22) (2 15))) + +(mtest + [group-reduce (hash) identity (do inc @1) + "fourscoreandsevenyearsago" 0] #H(() (#\a 3) (#\c 1) (#\d 1) + (#\e 4) (#\f 1) (#\g 1) + (#\n 2) (#\o 3) (#\r 3) + (#\s 3) (#\u 1) (#\v 1) + (#\y 1)) + [group-reduce (hash) evenp + (range 1 10) 0] #H(() (t 30) (nil 25))) + +(mtest + (hash-props) #H(()) + (hash-props 1 2) #H(() (1 2)) + (hash-props 1 2 'a 'b) #H(() (1 2) (a b)) + (hash-props 1) :error + (hash-props 1 2 'a) :error) + +;; Test that growing a hash table works while iterators +;; are referencing it. +(let ((h (hash-list (range 0 199)))) + (let ((i (hash-begin h))) + (each ((x 200..1000)) + (set [h x] x)) + (each ((x 0..1000)) + (vtest [h x] x)))) + +;; Test that when an iterator is created which references +;; a table which is then resized, and from which all +;; entries are subsequently deleted, when the iterator +;; then marches, it will not see the deleted entries. +(let ((h (hash-list (range 0 199)))) + (let ((i (hash-begin h))) + (each ((x 200..1000)) + (set [h x] x)) + (each ((x 0..1000)) + (del [h x])) + (test (hash-next i) nil))) + +;; Test that when an iterator is created which references +;; a table which is then resized, and from which values +;; are never deleted, the iterator will visit all the +;; original items that existed when it was created. +(let ((h (hash-list (range 0 199)))) + (let ((i (hash-begin h))) + (each ((x 200..1000)) + (set [h x] x)) + (let ((items (build (whilet ((cell (hash-next i))) + (add (car cell)))))) + (test (diff 0..200 items) nil)))) + +(test [hash-map square '(1 2 3)] + #H(() (1 1) (2 4) (3 9))) + +(let ((h1 #H(() (a 1) (b 2) (c 3) (d 4))) + (h2 #H(() (b -2) (c -3) (d -4) (e -5)))) + (mtest + (hash-uni h1 h2) #H(() (a 1) (b 2) (c 3) (d 4) (e -5)) + [hash-uni h1 h2 +] #H(() (a 1) (b 0) (c 0) (d 0) (e -5)) + [hash-uni h1 h2 + -] #H(() (a -1) (b -4) (c -6) (d -8) (e -5)) + [hash-uni h1 h2 + : -] #H(() (a 1) (b 4) (c 6) (d 8) (e 5)) + [hash-uni h1 h2 + - -] #H(() (a -1) (b 0) (c 0) (d 0) (e 5))) + (mtest + [hash-join h1 h2 +] :error + [hash-join h1 h2 + 0] :error + [hash-join h1 h2 + : 0] :error + [hash-join h1 h2 + 0 0] #H(() (a 1) (b 0) (c 0) (d 0) (e -5))) + (mtest + (hash-diff h1 h2) #H(() (a 1)) + (hash-diff h2 h1) #H(() (e -5))) + (mtest + (hash-symdiff h1 h2) #H(() (a 1) (e -5)) + (hash-symdiff h2 h1) #H(() (a 1) (e -5))) + (mtest + (hash-isec h1 h2) #H(() (b 2) (c 3) (d 4)) + [hash-isec h1 h2 +] #H(() (b 0) (c 0) (d 0)))) + +(mtest + (eql (hash-equal "abc") (hash-equal "abc")) t + (eql (hash-equal (expt 2 128)) (hash-equal (expt 2 128))) t + (eql (hash-eql "abc") (hash-eql "abc")) nil + (eql (hash-eql (expt 2 128)) (hash-eql (expt 2 128))) t) diff --git a/tests/010/json.tl b/tests/010/json.tl new file mode 100644 index 00000000..d419295f --- /dev/null +++ b/tests/010/json.tl @@ -0,0 +1,194 @@ +(load "../common") + +(mtest + #J0 0.0 + #J"abc" "abc" + #Jtrue t + #Jfalse nil + #Jnull null) + +(mtest + #J1 1.0 + #J 1 1.0 + #J123 123.0 + #J0.123 0.123 + #J1.123 1.123 + #J1E3 1000.0 + #J1.1E3 1100.0 + #J1.1E+3 1100.0 + #J1.1E+03 1100.0 + #J1.1e3 1100.0 + #J1.1e+3 1100.0 + #J1.1e+03 1100.0) + +(mtest + #J"" "" + #J"\u0000" "\xdc00" + #J"\u0001" "\x1" + #J"a\u0000b" "a\xdc00;b" + #J"a\u0001b" "a\x1;b" + #J"\b\t\n\f\r" "\b\t\n\f\r" + #J"\/\\\"" "/\\\"") + +(when (> (sizeof wchar) 2) + (let ((chr (read "\"\\x10437\""))) + (vtest #J"\ud801\udc37" `@chr`) + (vtest #J"a\ud801\udc37b" `a@{chr}b`))) + +(mtest + #J[] #() + #J[ ] #() + #J[ ] #() + #J [ ] #() + #J[null] #(null) + #J[false] #(nil) + #J[true] #(t) + #J["abc"] #("abc") + #J[1,2,3] #(1.0 2.0 3.0) + #J[ 1 , 2 , 3 ] #(1.0 2.0 3.0) + #J[[]] #(#()) + #J[[],[]] #(#() #()) + #J[ [] , [] ] #(#() #()) + #J[[1],[2],3] #(#(1.0) #(2.0) 3.0)) + +(mtest + #J{} #H(()) + #J{ } #H(()) + #J{ } #H(()) + #J { } #H(()) + #J{true:true} #H(() (t t))) + #J{ true : true } #H(() (t t)) + #J{ {} : {} } #H(() (#H(()) #H(()))) + #J{ "a" : 1.0 } #H(() (a 1.0)) + #J{ "a" : 1.0, "b" : [null] } #H(() (a 1.0) (b #(null))) + +(mtest + #J[ + ] #() + #J[1, + 2, + 3] #(1.0 2.0 3.0) + #J{"foo": + "bar"} + #H(() ("foo" "bar"))) + +(let ((*print-circle* t)) + (mstest + #J[#1="abc", #1#] "#(#1=\"abc\" #1#)" + #2=#J[1, #2#] "#1=#(1.0 #J#1#)" + #J#3=[1, #3#] "#1=#(1.0 #1#)" + #4=#J{#4#:#4#} "#1=#H(() (#2=#J#1# #2#))" + #J#5={#5#:#5#} "#1=#H(() (#1# #1#))") + + (let ((chash #J{"foo":#6="bar", "xyzzy":#6#})) + (mtest + [chash "xyzzy"] "bar" + (eq [chash "foo"] [chash "xyzzy"]) t))) + +(mtest + ^#J~(+ 1.0 1) #J2 + ^#J[1, ~(+ 2.0 2)] #J[1, 4] + ^#J[1, ~(+ 2.0 2), 3] #J[1, 4, 3] + (eval ^^#J~#(1.0 ,*(list 2.0 3.0) 4.0)) #J[1, 2, 3, 4] + ^#J[1, ~*(list 2.0 3.0), 4] #J[1, 2, 3, 4] + #J^[1, ~(+ 2.0 2)] #(1.0 4.0) + #J^[1, ~(+ 2.0 2), 3] #(1.0 4.0 3.0) + ^#J{~(join "abc" "def") : "ghi"} #J{"abcdef":"ghi"} + #J^{~(join "abc" "def") : "ghi"} #H(() ("abcdef" "ghi"))) + +;; get-json +(mtest + (get-json "0") 0.0 + (get-json "\"abc\"") "abc" + (get-json "true") t + (get-json "false") nil + (get-json "null") null + (get-json "[1,2,3]") #(1.0 2.0 3.0) + (get-json "{\"a\":\"b\"}") #H(() ("a" "b"))) + +(mtest + (get-json "0 \n") 0.0 + (get-json "\"abc\" \n") "abc" + (get-json "true \n") t + (get-json "false \n") nil + (get-json "null \n") null + (get-json "[1,2,3] \n") #(1.0 2.0 3.0) + (get-json "{\"a\":\"b\"} \n") #H(() ("a" "b"))) + +(mtest + (get-json "0,") :error + (get-json "\"abc\",") :error + (get-json "true,") :error + (get-json "false,") :error + (get-json "null,") :error + (get-json "[1,2,3],") :error + (get-json "{\"a\":\"b\"},") :error) + +(mtest + (tojson #(1.0 "abc" t)) "[1,\"abc\",true]" + (tojson "<!--") "\"<\\u0021--\"" + (tojson "a<!--b") "\"a<\\u0021--b\"" + (tojson "<!-") "\"<!-\"" + (tojson "-->") "\"-\\u002D>\"" + (tojson "a-->b") "\"a-\\u002D>b\"" + (tojson "->") "\"->\"" + (tojson "</") "\"</\"" + (tojson "</scrip") "\"</scrip\"" + (tojson "</script") "\"<\\/script\"" + (tojson "a</scriptb") "\"a<\\/scriptb\"") + +(mtest + (get-jsons "") nil + (get-jsons "true") (t) + (get-jsons "1 1 [2] {3:4}") (1.0 1.0 #(2.0) #H(() (3.0 4.0)))) + +(mtest + (get-json "{ , }") :error + (get-json "{ 1:2, }") :error + (get-json "{ 1:2, 3:4, }") :error + (get-json "[ , ]") :error + (get-json "[ 1, ]") :error + (get-json "[ 1, 2, ]") :error) + +(let ((*read-bad-json* t)) + (mtest + (get-json "{ , }") :error + (get-json "{ 1:2, }") #H(() (1.0 2.0)) + (get-json "{ 1:2, 3:4, }") #H(() (1.0 2.0) (3.0 4.0)) + (get-json "[ , ]") :error + (get-json "[ 1, ]") #(1.0) + (get-json "[ 1, 2, ]") #(1.0 2.0))) + +(mtest + (with-out-string-stream (s) (put-json nil s)) "false" + (with-out-string-stream (s) (put-jsons nil s)) "" + (with-out-string-stream (s) (put-jsons '(1.0 t nil) s)) "1\ntrue\nfalse\n") + +(with-temp-file (name s "json") + (mtest + (file-put-json name #(1.0 2.0 3.0)) t + (file-get-string name) "[1,2,3]\n" + (file-get-json name) #(1.0 2.0 3.0) + (file-append-json name #H(() ("a" t))) t + (file-get-string name) "[1,2,3]\n{\"a\":true}\n" + (file-get-jsons name) (#(1.0 2.0 3.0) + #H(() ("a" t))) + (file-put-jsons name '(1.0 t null)) t + (file-get-jsons name) (1.0 t null) + (file-get-string name) "1\ntrue\nnull\n") + (if (path-executable-to-me-p "/bin/sh") + (mtest + (command-put-json `cat > @name` #(#() #())) t + (file-get-string name) "[[],[]]\n" + (command-get-json `cat @name`) #(#() #()) + (command-put-jsons `cat > @name` '(#() 1.0 nil)) t + (file-get-string name) "[]\n1\nfalse\n" + (command-get-jsons `cat @name`) (#() 1.0 nil)))) + +(mtest + (tojson 1) "1" + (tojson 123123123123123123123123123123) "123123123123123123123123123123" + (tojson '(1 2 3 4 5)) "[1,2,3,4,5]") + +(test + (get-json "[1, 2, ; foo\n 3]") #(1.0 2.0 3.0)) diff --git a/tests/010/qquote.tl b/tests/010/qquote.tl new file mode 100644 index 00000000..26d5417b --- /dev/null +++ b/tests/010/qquote.tl @@ -0,0 +1,42 @@ +(let ((nullsym nil) + (sym 's) + (atom "abc") + (cons '(x y z)) + (dwim '[])) + (tree-bind (x y (op arg)) ^(a b @,nullsym) + (assert (eq op 'sys:var)) + (assert (eq arg nullsym))) + (tree-bind (x y (op arg)) ^(a b @,sym) + (assert (eq op 'sys:var)) + (assert (eq arg sym))) + (tree-bind (x y . (op arg)) ^(a b . @,sym) + (assert (eq op 'sys:var)) + (assert (eq arg sym))) + (tree-bind (x y (op arg)) ^(a b @,atom) + (assert (eq op 'sys:var)) + (assert (eq arg atom))) + (tree-bind (x y . (op arg)) ^(a b . @,atom) + (assert (eq op 'sys:var)) + (assert (eq arg atom))) + (tree-bind (x y (op arg)) ^(a b @,cons) + (assert (eq op 'sys:expr)) + (assert (eq arg cons))) + (tree-bind (x y . (op arg)) ^(a b . @,cons) + (assert (eq op 'sys:expr)) + (assert (eq arg cons))) + (tree-bind (x y (op arg)) ^(a b @,dwim) + (assert (eq op 'sys:expr)) + (assert (eq arg dwim))) + (tree-bind (x y . (op arg)) ^(a b . @,dwim) + (assert (eq op 'sys:expr)) + (assert (eq arg dwim))) + (tree-bind (x y (op arg . tail)) ^(a b (sys:expr ,sym . foo)) + (assert (eq op 'sys:expr)) + (assert (eq arg sym)) + (assert (eq tail 'foo))) + (tree-bind (x y (op arg0 arg1)) ^(a b (sys:expr ,sym foo)) + (assert (eq op 'sys:expr)) + (assert (eq arg0 sym)) + (assert (eq arg1 'foo))) + (tree-bind (x y (op)) ^(a b (sys:expr)) + (assert (eq op 'sys:expr)))) diff --git a/tests/010/range.tl b/tests/010/range.tl new file mode 100644 index 00000000..4cc9ee95 --- /dev/null +++ b/tests/010/range.tl @@ -0,0 +1,103 @@ +(load "../common") + +(mtest + (range 1 1) (1) + (range 1.0 1.0) (1.0) + (range #\a #\a) (#\a) + (range #R(1 1) #R(1 1)) (#R(1 1))) + +(mtest + (range 0 4) (0 1 2 3 4) + (range 4 0) (4 3 2 1 0) + (range 0.0 4.0) (0.0 1.0 2.0 3.0 4.0) + (range 4.0 0.0) (4.0 3.0 2.0 1.0 0.0) + (range #\a #\c) (#\a #\b #\c) + (range #\c #\a) (#\c #\b #\a) + (range #R(0 0) #R(4 4)) (#R(0 0) #R(1 1) #R(2 2) #R(3 3) #R(4 4)) + (range #R(4 4) #R(0 0)) (#R(4 4) #R(3 3) #R(2 2) #R(1 1) #R(0 0))) + +(mtest + (len (range 1 1 "")) :error + (len (range 1 2 "")) :error) + +(mtest + (range 0 4 2) (0 2 4) + (range 4 0 -2) (4 2 0) + (range 0.0 4.0 2) (0.0 2.0 4.0) + (range 4.0 0.0 -2) (4.0 2.0 0.0) + (range #\a #\e 2) (#\a #\c #\e) + (range #\e #\a -2) (#\e #\c #\a) + (range #R(0 0) #R(4 4) 2) (#R(0 0) #R(2 2) #R(4 4)) + (range #R(4 4) #R(0 0) -2) (#R(4 4) #R(2 2) #R(0 0)) + (range 1 32 (op * 2)) (1 2 4 8 16 32)) + +(mtest + (range* 1 1) nil + (range* 1.0 1.0) nil + (range* #\a #\a) nil + (range* #R(1 1) #R(1 1)) nil) + +(mtest + (range* 0 4) (0 1 2 3) + (range* 4 0) (4 3 2 1) + (range* 0.0 4.0) (0.0 1.0 2.0 3.0) + (range* 4.0 0.0) (4.0 3.0 2.0 1.0) + (range* #\a #\c) (#\a #\b) + (range* #\c #\a) (#\c #\b) + (range* #R(0 0) #R(4 4)) (#R(0 0) #R(1 1) #R(2 2) #R(3 3)) + (range* #R(4 4) #R(0 0)) (#R(4 4) #R(3 3) #R(2 2) #R(1 1))) + +(mtest + (len (range* 1 1 "")) 0 + (len (range* 1 2 "")) :error) + +(mtest + (range* 0 4 2) (0 2) + (range* 4 0 -2) (4 2) + (range* 0.0 4.0 2) (0.0 2.0) + (range* 4.0 0.0 -2) (4.0 2.0) + (range* #\a #\e 2) (#\a #\c) + (range* #\e #\a -2) (#\e #\c) + (range* #R(0 0) #R(4 4) 2) (#R(0 0) #R(2 2)) + (range* #R(4 4) #R(0 0) -2) (#R(4 4) #R(2 2)) + (range* 1 32 (op * 2)) (1 2 4 8 16)) + +(mtest + (range 0 1.25 0.5) (0 0.5 1.0) + (range* 0 1.25 0.5) (0 0.5 1.0)) + +(mtest + (range "A" "A") nil + (range "A" "A" 0) :error + (range "A" "A" -2) :error) + +(mtest + (range "A" "C") ("A" "B" "C") + (range "A" "C" 2) ("A" "C") + (range "A" "D" 2) ("A" "C") + (range "A" "E" 2) ("A" "C" "E") + (range "A" "C" 3) ("A") + (range "A" "E" 3) ("A" "D")) + +(mtest + (range* "A" "C") ("A" "B") + (range* "A" "C" 2) ("A") + (range* "A" "D" 2) ("A" "C") + (range* "A" "E" 2) ("A" "C") + (range* "A" "C" 3) ("A") + (range* "A" "E" 3) ("A" "D")) + +(mtest + [range "ABCD" nil rest] ("ABCD" "BCD" "CD" "D" nil) + [range* "ABCD" nil rest] ("ABCD" "BCD" "CD" "D")) + +(defstruct udnum nil + v + (:method + (me arg) (new udnum v (+ me.v arg))) + (:method > (me arg) (> me.v arg)) + (:method < (me arg) (< me.v arg)) + (:method = (me arg) (= me.v arg))) + +(mtest + (range (new udnum v 0) (new udnum v 3)) (#S(udnum v 0) #S(udnum v 1) #S(udnum v 2) #S(udnum v 3)) + (range* (new udnum v 0) (new udnum v 3)) (#S(udnum v 0) #S(udnum v 1) #S(udnum v 2))) diff --git a/tests/010/seq.expected b/tests/010/seq.expected index 9c4d860d..691e6ac4 100644 --- a/tests/010/seq.expected +++ b/tests/010/seq.expected @@ -14,3 +14,39 @@ exception! 38 37 36 35 34 33 32 31 30 29 28 27 26 25 24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1) #((8 . #\g) (6 . #\f)) #((7 . #\h) (5 . #\e) (4 . #\d) (3 . #\c) (2 . #\b) (1 . #\a)) +"bdf" +"aceg" +"g" +"abcdef" +"abcdefg" +"" +"abcdefg" +"" +"aceg" +"bdf" +(1 3 5) +(0 2 4 6) +(0 1 2 3 4 5 6) +nil +(0 1 2 3 4 5 6) +nil +(0 2 4 6) +(1 3 5) +#(1 3 5) +#(0 2 4 6) +#(0 1 2 3 4 5 6) +#() +#(0 1 2 3 4 5 6) +#() +#(0 2 4 6) +#(1 3 5) +#b'bbddff' +#b'aaccee99' +#b'99' +#b'aabbccddeeff' +#b'aabbccddeeff99' +#b'' +#b'aabbccddeeff99' +#b'' +#b'aaccee99' +#b'bbddff' diff --git a/tests/010/seq.txr b/tests/010/seq.txr index 080b01ad..18f5c198 100644 --- a/tests/010/seq.txr +++ b/tests/010/seq.txr @@ -14,7 +14,62 @@ (format t "~s ~s\n" (del [*s* 1]) *s*) (format t "~s ~s\n" (del [*s* -1]) *s*) (catch (pr (del [*s* 3]) *s*) (t (x) (caught x))) - (pr [sort *v* >]) - (pr [sort *v2* > cdr]) - (pr [sort (range 1 100) >]) - (pr2 (del [*v2* 1..3]) *v2*)) + (pr [nsort *v* >]) + (pr [nsort *v2* > cdr]) + (pr [nsort (range 1 100) >]) + (pr2 (del [*v2* 1..3]) *v2*) + (let ((s (copy "abcdefg"))) + (pr (del [s '(1 3 5)])) + (pr s)) + (let ((s (copy "abcdefg"))) + (pr (del [s '(6)])) + (pr s)) + (let ((s (copy "abcdefg"))) + (pr (del [s '(0 1 2 3 4 5 6)])) + (pr s)) + (let ((s (copy "abcdefg"))) + (pr (del [s '(-7 -6 -5 -4 -3 -2 -1)])) + (pr s)) + (let ((s (copy "abcdefg"))) + (pr (del [s '(-7 -5 -3 -1)])) + (pr s)) + (let ((s (list 0 1 2 3 4 5 6))) + (pr (del [s '(1 3 5)])) + (pr s)) + (let ((s (list 0 1 2 3 4 5 6))) + (pr (del [s '(0 1 2 3 4 5 6)])) + (pr s)) + (let ((s (list 0 1 2 3 4 5 6))) + (pr (del [s '(-7 -6 -5 -4 -3 -2 -1)])) + (pr s)) + (let ((s (list 0 1 2 3 4 5 6))) + (pr (del [s '(-7 -5 -3 -1)])) + (pr s)) + (let ((s (vec 0 1 2 3 4 5 6))) + (pr (del [s '(1 3 5)])) + (pr s)) + (let ((s (vec 0 1 2 3 4 5 6))) + (pr (del [s '(0 1 2 3 4 5 6)])) + (pr s)) + (let ((s (vec 0 1 2 3 4 5 6))) + (pr (del [s '(-7 -6 -5 -4 -3 -2 -1)])) + (pr s)) + (let ((s (vec 0 1 2 3 4 5 6))) + (pr (del [s '(-7 -5 -3 -1)])) + (pr s)) + (let ((s (copy #b'aabbccddeeff99'))) + (pr (del [s '(1 3 5)])) + (pr s)) + (let ((s (copy #b'aabbccddeeff99'))) + (pr (del [s '(6)])) + (pr s)) + (let ((s (copy #b'aabbccddeeff99'))) + (pr (del [s '(0 1 2 3 4 5 6)])) + (pr s)) + (let ((s (copy #b'aabbccddeeff99'))) + (pr (del [s '(-7 -6 -5 -4 -3 -2 -1)])) + (pr s)) + (let ((s (copy #b'aabbccddeeff99'))) + (pr (del [s '(-7 -5 -3 -1)])) + (pr s)) + ) diff --git a/tests/010/span-var.txr b/tests/010/span-var.txr new file mode 100644 index 00000000..036acc6a --- /dev/null +++ b/tests/010/span-var.txr @@ -0,0 +1,39 @@ +@(define fun (x y)) +@(bind x "x") +@y +@y +@y +@(end) +@(next :list '("a" "a" "a" "b" "c")) +@{z (fun x "a")} +@(require (equal x "x")) +@(require (equal z '("a" "a" "a"))) +@(define fun2 (x y))@(bind x "x")@y@(end) +@(next :string "ab") +@{w (fun2 x "a")}@y +@(require (equal w "a")) +@(require (equal y "b")) +@(next :list '("a" "a" "a" "b" "c")) +@(bind d ("d")) +@(cases) +@ {d (fun "x" "a")} +@ {require (not "get here")} +@(or) +@ (require "get here") +@(end) +@(next :string "ab") +@(cases) +@ {d (fun2 "x" "a")} +@ {require (not "get here")} +@(or) +@ (require "get here") +@(end) +@(bind n "123") +@(next :string "123456") +@(cases) +@ {n /\d+/} +@ {require (not "get here")} +@(or) +@ {m /\d+/} +@ (require (equal m "123456")) +@(end) diff --git a/tests/010/tree.tl b/tests/010/tree.tl new file mode 100644 index 00000000..9d00fda6 --- /dev/null +++ b/tests/010/tree.tl @@ -0,0 +1,264 @@ +(load "../common") + +(defvarl tr (tree)) +(defvarl keys '(0 6 8 11 10 2 16 3 17 7 19 12 15 13 18 4 14 5 1 9)) + +(test tr #T(())) + +(mtest + (treep tr) t + (treep 42) nil) + +(mtest + (len #T()) 0 + (len #T(() 1)) 1 + (len #T(() 1 2)) 2 + (len #T(() 1 2 3)) 3 + (len #T(() 1 1 1)) 3) + +(each ((n keys)) + (tree-insert tr n)) + +(mtest + (tree-lookup tr 0) 0 + (tree-lookup tr 1) 1 + (tree-lookup tr 2) 2 + (tree-lookup tr 3) 3 + (tree-lookup tr 4) 4 + (tree-lookup tr 5) 5 + (tree-lookup tr 6) 6 + (tree-lookup tr 7) 7 + (tree-lookup tr 8) 8 + (tree-lookup tr 9) 9 + (tree-lookup tr 10) 10 + (tree-lookup tr 11) 11 + (tree-lookup tr 12) 12 + (tree-lookup tr 13) 13 + (tree-lookup tr 14) 14 + (tree-lookup tr 15) 15 + (tree-lookup tr 16) 16 + (tree-lookup tr 17) 17 + (tree-lookup tr 18) 18 + (tree-lookup tr 19) 19) + +(mtest + [tr 0] 0 + [tr 5] 5 + [tr 19] 19) + +(mtest + [tr 0..3] (0 1 2) + [tr 3..5] (3 4) + [tr -2..0] () + [tr -2..4] (0 1 2 3) + [tr :..4] (0 1 2 3) + [tr 18..100] (18 19) + [tr 18..:] (18 19) + [tr 100..200] ()) + +(vtest + [tr :..:] (range 0 19)) + +(vtest (build (for* ((i (tree-begin tr)) + (n (tree-next i))) + (n) + ((set n (tree-next i))) + (add (key n)))) + (range 0 19)) + +(vtest (build (for* ((j (tree-begin tr)) + (i (progn (tree-next j) (tree-next j) (tree-reset j tr))) + (n (tree-next i))) + (n) + ((set n (tree-next i))) + (add (key n)))) + (range 0 19)) + +(vtest (build (for* ((j (tree-begin tr)) + (i (progn (tree-next j) (tree-next j) (tree-reset j tr))) + (n (tree-peek i))) + ((and n (eq (tree-next i) n))) + ((set n (tree-peek i))) + (add (key n)))) + (range 0 19)) + +(defvarl trc (copy-search-tree tr)) + +(vtest trc tr) + +(tree-clear trc) + +(test trc #T(())) + +(test (tree-delete tr 6) 6) + +(vtest (build (for* ((i (tree-begin tr 6)) + (n (tree-next i))) + (n) + ((set n (tree-next i))) + (add (key n)))) + (range 7 19)) + +(vtest (build (for* ((i (tree-begin tr 0)) + (n (tree-next i))) + (n) + ((set n (tree-next i))) + (add (key n)))) + (rlist 0..5 7..19)) + +(vtest (build (for* ((i (tree-begin tr 8)) + (n (tree-next i))) + (n) + ((set n (tree-next i))) + (add (key n)))) + (range 8 19)) + +(vtest (build (for* ((i (tree-reset (tree-begin #T(())) tr 8)) + (n (tree-next i))) + (n) + ((set n (tree-next i))) + (add (key n)))) + (range 8 19)) + +(test (let* ((t0 (tree-begin tr)) + (t1 (progn (tree-next t0) (copy-tree-iter t0)))) + (tree-next t0) + (tree-next t0) + (list (key (tree-next t1)) + (key (tree-next t1)) + (key (tree-next t1)))) + (1 2 3)) + +(test (let* ((t0 (tree-begin tr)) + (t1 (progn (tree-next t0) (copy-tree-iter t0))) + (t2 (replace-tree-iter (tree-begin tr) t0))) + (tree-next t0) + (tree-next t0) + (list (key (tree-next t1)) + (key (tree-next t1)) + (key (tree-next t2)) + (key (tree-next t2)))) + (1 2 1 2)) + +(test (tree-next (tree-begin tr 20)) nil) + +(test (tree-next (tree-begin #T(()) 0)) nil) +(test (key (tree-next (tree-begin #T(() 1) 1))) 1) + +(mtest + (tree-delete tr 0) 0 + (tree-delete tr 1) 1 + (tree-delete tr 2) 2 + (tree-delete tr 3) 3 + (tree-delete tr 4) 4 + (tree-delete tr 5) 5 + (tree-delete tr 7) 7 + (tree-delete tr 8) 8 + (tree-delete tr 9) 9 + (tree-delete tr 10) 10 + (tree-delete tr 11) 11 + (tree-delete tr 12) 12 + (tree-delete tr 13) 13 + (tree-delete tr 14) 14 + (tree-delete tr 15) 15 + (tree-delete tr 16) 16 + (tree-delete tr 17) 17 + (tree-delete tr 18) 18 + (tree-delete tr 19) 19) + +(set *tree-fun-whitelist* [list* '= '< 'to *tree-fun-whitelist*]) + +(let ((tr [tree '(1 2 3) identity < =])) + (mtest + tr #T((identity < =) 1 2 3) + (copy-search-tree tr) #T((identity < =) 1 2 3) + (make-similar-tree tr) #T((identity < =)))) + +(test + (collect-each ((el (tree-begin #T(() 1 2 3 4 5) 2 5))) + (* 10 el)) + (20 30 40)) + +(mtest + (uni #T(() "a" "b") #T(() "b" "c")) ("a" "b" "c") + (diff #T(() "a" "b") #T(() "b" "c")) ("a") + (isec #T(() "a" "b") #T(() "b" "c")) ("b")) + +(defstruct (item label key) () + label + key + (:method equal (it) it.key)) + +(defun make-items () + (vec (new (item 'a 1)) + (new (item 'b 2)) + (new (item 'c 2)) + (new (item 'd 2)) + (new (item 'e 2)) + (new (item 'f 3)))) + +(let* ((items (make-items)) + (tr (tree items : : : t))) + (each ((it items)) + (vtest (tree-delete tr it) it)) + (test tr #T(()))) + +(let* ((items (make-items)) + (tr (tree items : : : t))) + (each ((it items)) + (let* ((tn (tree-lookup-node tr it.key)) + (iu (key tn))) + (vtest (tree-delete-specific-node tr tn) tn) + (each ((iv tr)) + (test (eq iv.label iu.label) nil)))) + (test tr #T(()))) + +(let* ((items (make-items)) + (tr (tree items : : : t))) + (vtest (vec-list [mapcar .label tr]) [mapcar .label items])) + +(let ((tr (tree))) + (mtest + (tree-insert tr 1) #N(1 nil nil) + (tree-insert tr 1) #N(1 nil nil) + (tree-insert tr 1) #N(1 nil nil)) + (tree-insert tr 2) + (test (tree-count tr) 2) + (tree-insert tr 1 t) + (test (tree-count tr) 3)) + +(mtest + (tree-min-node (tree)) nil + (tree-min-node (tree '(1))) #N(1 nil nil) + (tree-min-node (tree '(1 2 3))) #N(1 nil nil)) + +(mtest + (tree-min (tree)) nil + (tree-min (tree '(1))) 1 + (tree-min (tree '(1 2 3))) 1) + +(let ((tr (tree '(1 2 3 4 5 6 7 8 9 10)))) + (mtest + (tree-count tr) 10 + (tree-del-min tr) 1 + (tree-del-min tr) 2 + (tree-del-min tr) 3 + (tree-count tr) 7 + (tree-del-min tr) 4 + (tree-count tr) 6 + (tree-del-min tr) 5 + (tree-del-min tr) 6 + (tree-del-min tr) 7 + (tree-del-min tr) 8 + (tree-count tr) 2 + (tree-del-min tr) 9 + (tree-count tr) 1 + (tree-del-min tr) 10 + (tree-count tr) 0 + (tree-del-min tr) nil)) + +(let* ((tr [tree '(#R(1 10) #R(11 20) #R(21 30)) to]) + (node (tree-lookup-node tr 10))) + (test node #N(#R(1 10) nil nil)) + (tree-delete-specific-node tr node) + (test tr #T((to) #R(11 20) #R(21 30)))) diff --git a/tests/010/vec.tl b/tests/010/vec.tl new file mode 100644 index 00000000..f7b182c1 --- /dev/null +++ b/tests/010/vec.tl @@ -0,0 +1,53 @@ +(load "../common") + +(let ((v0 (vec)) + (v3 (vec 1 2 3))) + (mtest + v0 #() + v3 #(1 2 3) + (fill-vec v0 nil) #() + (fill-vec v0 nil -1 -1) :error + (fill-vec v0 nil 1 1) :error + (fill-vec v3 nil 0 0) #(1 2 3) + (fill-vec v3 nil 1 1) #(1 2 3) + (fill-vec v3 nil 2 2) #(1 2 3) + (fill-vec v3 nil 3 3) #(1 2 3) + (fill-vec v3 nil -3 -3) #(1 2 3) + (fill-vec v3 nil 4 0) :error + (fill-vec v3 nil 4 4) :error + (fill-vec v3 nil 0 4) :error + (fill-vec v3 nil -1 0) #(1 2 3) + (fill-vec v3 nil 1 0) #(1 2 3) + (fill-vec v3 nil 2 1) #(1 2 3) + (fill-vec v3 nil 3 2) #(1 2 3) + (fill-vec v3 nil -4 -3) :error + (fill-vec v3 nil -3 -4) :error + (fill-vec v3 nil) #(nil nil nil) + (fill-vec v3 1 0 1) #(1 nil nil) + (fill-vec v3 2 1 2) #(1 2 nil) + (fill-vec v3 3 2 3) #(1 2 3) + (fill-vec v3 0 1) #(1 0 0) + (fill-vec v3 2 -1) #(1 0 2) + (fill-vec v3 3 -3) #(3 3 3)) + (fill-vec v3 0 -2 -1) #(3 0 3)) + +(mtest + (nested-vec) nil + (nested-vec-of 0 4) #(0 0 0 0) + (nested-vec-of 0 4 3) #(#(0 0 0) + #(0 0 0) + #(0 0 0) + #(0 0 0)) + (nested-vec-of 'a 4 3 2) #(#(#(a a) #(a a) #(a a)) + #(#(a a) #(a a) #(a a)) + #(#(a a) #(a a) #(a a)) + #(#(a a) #(a a) #(a a))) + (nested-vec-of 'a 1 1 1) #(#(#(a))) + (nested-vec-of 'a 1 1 0) #(#(#())) + (nested-vec-of 'a 1 0 1) #(#()) + (nested-vec-of 'a 1 0) #(#()) + (nested-vec-of 'a 0 1) #() + (nested-vec-of 'a 0) #() + + (nested-vec-of 'a 4 0 1) #(#() #() #() #()) + (nested-vec-of 'a 4 0) #(#() #() #() #())) diff --git a/tests/011/keyparams.tl b/tests/011/keyparams.tl new file mode 100644 index 00000000..189081d3 --- /dev/null +++ b/tests/011/keyparams.tl @@ -0,0 +1,47 @@ +(load "../common") + +(defvarl v :v) +(defsymacro u (identity :u)) +(defvarl x :x) +(defvarl y :y) + +(mtest + [(lambda (:key))] nil + [(lambda (:key a))] :error + [(lambda (:key a) a) 1] 1) + +(mtest + [(lambda (:key -- (a v)) a)] :v + [(lambda (:key -- (a 'v)) a)] v + [(lambda (:key -- (a v a-p)) (list a a-p))] (:v nil) + [(lambda (:key -- (a 'v a-p)) (list a a-p))] (v nil)) + +(mtest + [(lambda (:key -- (a v)) a) :a 1] 1 + [(lambda (:key -- (a 'v)) a) :a 1] 1 + [(lambda (:key -- (a v a-p)) (list a a-p)) :a 1] (1 t) + [(lambda (:key -- (a 'v a-p)) (list a a-p)) :a 1] (1 t)) + +(mtest + [(lambda (:key -- (a v) (b u)) (list a b)) :a 1] (1 :u) + [(lambda (:key -- (a 'v) (b 'u)) (list a b)) :b 1] (v 1) + [(lambda (:key -- (a v a-p) (b u b-p)) (list a a-p b b-p)) :a 1] (1 t :u nil) + [(lambda (:key -- (a v a-p) (b u b-p)) (list a a-p b b-p)) :b 1] (:v nil 1 t)) + +(test + [(lambda (:key -- (a v) . r) (list a r)) :a 1] (1 (:a 1))) + +(defun key-place (:key -- x y (s nil s-p)) ^(,x ,y ,s ,s-p)) + +(defset key-place (:key -- x y) s + ^(key-place :x ,x :y ,y :s ,s)) + +(test + (set (key-place :x 3 :y 4) 42) (3 4 42 t)) + +(defmacro kp (r (:key -- (a v a-p) (b u b-p)) : ((:key -- (c x c-p) (d y d-p)))) + ^'(r ,a ,a-p ,b ,b-p ,c ,c-p ,d ,d-p)) + +(mtest + (kp :r ()) (r :v nil :u nil :x nil :y nil) + (kp 0 (:a 1 :b 2) (:d 3)) (r 1 t 2 t :x nil 3 t)) diff --git a/tests/011/macros-3.expected b/tests/011/macros-3.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/011/macros-3.expected +++ /dev/null diff --git a/tests/011/macros-3.tl b/tests/011/macros-3.tl index bf7cf9a6..fda312da 100644 --- a/tests/011/macros-3.tl +++ b/tests/011/macros-3.tl @@ -10,3 +10,16 @@ (macrolet ((m (:form f) f)) (m)))))) 42) + +(defvarl x 0) +(defmacro mac-time-counter () (inc x)) +(defsymacro s (mac-time-counter)) + +(mtest s 1 + s 2 + s 3) + +(test (symacrolet ((a 42)) + (labels () + a)) + 42) diff --git a/tests/011/macros-4.tl b/tests/011/macros-4.tl new file mode 100644 index 00000000..440dcd9e --- /dev/null +++ b/tests/011/macros-4.tl @@ -0,0 +1,11 @@ +(load "../common") + +(defmacro xsqrt (:match :form f) + (((* @exp @exp)) exp) + (@else f)) + +(defmacro xexpt (:match :form f) + ((@exp 2) ^(* ,exp ,exp)) + (@else f)) + +(test (expand '(xsqrt (xexpt x 2))) x) diff --git a/tests/011/mandel.txr b/tests/011/mandel.txr index 8a701526..cfa24857 100644 --- a/tests/011/mandel.txr +++ b/tests/011/mandel.txr @@ -1,16 +1,14 @@ @(do - (defvar x-centre -0.5) - (defvar y-centre 0.0) - (defvar width 4.0) - (defvar i-max 80) - (defvar j-max 60) - (defvar n 100) - (defvar r-max 2.0) - (defvar file "mandelbrot.pgm") - (defvar colour-max 255) - (defvar pixel-size (/ width i-max)) - (defvar x-offset (- x-centre (* 0.5 pixel-size (+ i-max 1)))) - (defvar y-offset (+ y-centre (* 0.5 pixel-size (+ j-max 1)))) + (defvarl x-centre -0.5) + (defvarl y-centre 0.0) + (defvarl width 4.0) + (defvarl i-max 80) + (defvarl j-max 60) + (defvarl n 100) + (defvarl r-max 2.0) + (defvarl pixel-size (/ width i-max)) + (defvarl x-offset (- x-centre (* 0.5 pixel-size (+ i-max 1)))) + (defvarl y-offset (+ y-centre (* 0.5 pixel-size (+ j-max 1)))) ;; complex number library (macro-time diff --git a/tests/011/patmatch.tl b/tests/011/patmatch.tl new file mode 100644 index 00000000..6d071f3d --- /dev/null +++ b/tests/011/patmatch.tl @@ -0,0 +1,619 @@ +(load "../common") + +(mtest + (if-match 1 1 'yes 'no) yes + (if-match 1 0 'yes 'no) no) + +(test (let ((sym 'a)) + (list (if-match a sym 'yes 'no) + (if-match b sym 'yes 'no))) + (yes no)) + +(mtest + (when-match @a 42 (list a)) (42) + (when-match (@nil) '(1) 'yes) yes + (when-match (@a @b @c) '(1 2 3) (list c b a)) (3 2 1) + (if-match (@a @b @c . @d) '(1 2 3 . 4) (list d c b a)) (4 3 2 1)) + +(test (if-match (@(oddp @a) @b @c . @d) '(2 x y z) + (list a b c d) + :no-match) + :no-match) + +(mtest + (if-match (1 2 . @a) '(1 2 3 4) a) (3 4) + (if-match ((1 2 @a) @b) '((1 2 3) 4) (list a b)) (3 4) + (if-match #() #() :yes :no) :yes + (if-match #() #(1) :yes :no) :no + (if-match #((1 @a) #(3 @b)) #((1 2) #(3 4)) (list a b)) (2 4)) + +(test (when-match @(struct time year 2021 month @m) #S(time year 2021 month 1) + m) + 1) + +(defstruct widget () + name + value) + +(defstruct grommet () + name + value) + +(vtest (append-each ((obj (list (new grommet name "foo" value :grom) + (new widget name "foo" value :widg)))) + (when-match @(struct @type name "foo" value @v) obj + (list (list type v)))) + ^((,(find-struct-type 'grommet) :grom) + (,(find-struct-type 'widget) :widg))) + +(mtest + (when-match @(as w (@a @b @c)) '(1 2 3) (list w a b c)) ((1 2 3) 1 2 3) + (when-match @(require (+ @a @b) (equal a b)) '(+ z z) (list a b)) (z z)) + +(test (if-match @(require (+ @a @b) (equal a b)) '(+ y z) + (list a b) + :no-match) + :no-match) + +(test (when-match @(all (x @a @b)) '((x 1 a) (x 2 b) (x 3 c)) + (list a b)) + ((1 2 3) (a b c))) + +(test (when-match (@x @(all @x)) '(1 (1 1 1 1)) x) 1) + +(test (when-match (@x @(all @x)) '(1 (1 1 1 2)) x) nil) + +(test (when-match @(some (x @a @b)) '((y 1 a) (x 2 b) (z 3 c)) + (list a b)) + (2 b)) + +(test (when-match @(coll (x @a @b)) '((y 1 a) (x 2 b) (z 3 c) (x 4 d)) + (list a b)) + ((2 4) (b d))) + +(test (if-match @(and (@x 2 3) (1 @y 3) (1 2 @z)) '(1 2 3) + (list x y z)) + (1 2 3)) + +(test (if-match @(and (@x 1) (1 @x)) '(1 1) x) 1) +(test (if-match @(and (@x 1) (1 @x)) '(1 2) x) nil) + +(test (when-match @(all @(or (@x @y) @z)) '((1 2) (3 4)) (list x y z)) + ((1 3) (2 4) (nil nil))) + +(test (let ((a 1) (b 2) (c 3)) + (if-match @(or @a @b @c) 2 + (list a b c))) + (1 2 3)) + +(test (when-match @(or @(all @x)) '(1 2 3) x) (1 2 3)) + +(test (when-match (foo @(all @x)) '(bar (1 2 . 3)) x) nil) + +(test (when-match (@(or foo) @(all @x)) '(bar (1 2 . 3)) x) nil) + +(test (when-match (@(oddp) @(all @x)) '(2 (1 2 . 3)) x) nil) + +(mtest + (if-match @(or (@x 3 3) (1 @x 3) (1 2 @x)) '(1 2 3) x) 2 + (if-match @(<= 10 @a 13) 11 :yes :no) :yes + (when-match @(as x @(<= 10 @a 13)) 11 x) 11 + (when-match (@(evenp) @(oddp @x)) '(2 3) x) 3 + (when-match @(<= 1 @x 10) 4 x) 4 + (when-match @(@d (chr-digit @c)) #\5 (list d c)) (5 #\5) + (when-match @(or @(require @a (oddp a)) @b @c) 2 (list a b c)) (nil 2 nil) + (when-match @(@x (< . @sym)) '(1 2 3) (list x sym)) (t (1 2 3)) + (when-match @(@x (< . @sym)) '(3 2 1) (list x sym)) nil + (let ((x t)) + (when-match @(@x (< . @sym)) '(1 2 3) (list x sym))) (t (1 2 3)) + (let ((x nil)) + (when-match @(@x (< . @sym)) '(1 2 3) (list x sym))) nil + (if-match (@(or @a) @a) '(1 2) a :no) :no + (if-match (@(and @a) @a) '(1 2) a :no) :no) + + +(test + (collect-each ((obj (list '(1 2 3) + '(4 5) + '(3 5) + #S(time year 2021 month 1 day 1) + #(vec tor)))) + (match-case obj + (@(struct time year @y) y) + (#(@x @y) (list x y)) + ((@nil @nil @x) x) + ((4 @x) x) + ((@x 5) x))) + (3 5 3 2021 (vec tor))) + +(test (when-match (@(and @a @b) (x . @c)) '(1 (x 2 3 4)) c) (2 3 4)) + +(test (when-match (@(some @a) . @b) '((1 2 3) 2) (list a b)) (1 (2))) + +(set *print-circle* t) + +(test (when-match @(as a @(some @a)) '#1=(1 2 #1# 3) :yes) :yes) + +(test (when-match (@a @(as a @(some @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes) + +(test (when-match (@a @(as a @(or x @a))) '(#1=(1 2 #1# 3) #1#) :yes) :yes) + +(test (when-match (@(with @a x 42) @b @c) '(1 2 3) (list a b c x)) + (1 2 3 42)) + +(test (let ((o 3)) + (when-match (@(evenp @x) @(with @z @(oddp @y) o)) '(4 6) + (list x y z))) + (4 3 6)) + +(test (let ((o 3)) + (when-match (@(evenp @x) @(with @(oddp @y) o)) '(4 6) + (list x y))) + (4 3)) + +(defstruct node () + left right) + +(mlet ((n (lnew node left (new node left n)))) + (test (when-match @(as x @(struct node + left @(struct node left @x))) + n :yes) + :yes)) + +(test + (collect-each ((obj (list '(1 2 3) + '(4 5) + '(3 5) + '(6 2 6) + #(11 12) + #S(time year 2021 month 1 day 2) + #S(time year 2020 month 1 day 1) + #(vec tor)))) + (match-case obj + (@(struct @s year 2021 day @d) (list d (struct-type-name s))) + (@(struct time year @y month @x day @x) (list y x)) + (#(@(integerp @x) @(require @y (succ x))) (list x y)) + (#(@x @y) (list x y)) + ((@x @nil @x) x) + ((@nil @nil @x) x) + ((4 @x) x) + ((@x 5) x))) + (3 5 3 6 (11 12) (2 time) (2020 1) (vec tor))) + +(test (when-match @(hash (x @y) (@y @datum)) #H(() (x k) (k 42)) datum) + 42) + +(test (when-match @(hash (x @y) (@(symbolp @y) @datum)) #H(() (x k) (k 42)) datum) + (42)) + +(mtest + (when-match @(hash (a)) #H(() (a b)) t) t + (when-match @(hash (c)) #H(() (a b)) t) nil + (let ((x 'a)) (when-match @(hash (@x)) #H(() (a b)) t)) t + (let ((x 'd)) (when-match @(hash (@x)) #H(() (a b)) t)) nil + (when-match @(hash (@x)) #H(() (a b)) x) (a)) + +(mtest + (if-match #R(10 20) 10..20 :yes :no) :yes + (if-match #R(10 20) #R(10 20) :yes :no) :yes + (if-match #R(10 20) #R(1 2) :yes :no) :no + (when-match #R(@a @b) 1..2 (list a b)) (1 2) + (when-match #R(@a 2) 1..2 a) 1 + (when-match #R(1 @a) 1..2 a) 2 + (when-match #R(2 @a) 1..2 a) nil + (when-match #R(@a 1) 1..2 a) nil) + +(mtest + (when-match @a..@b '1..2 (list a b)) (1 2) + (when-match (rcons @a @b) '(rcons 1 2) (list a b)) (1 2)) + +(test (let ((h #H(() (a 1) (b 2)))) + (when-match @[h @x] 'a x)) + a) + +(test (let ((h #H(() (a 1) (b 2)))) + (when-match @(@y [h @x]) 'a (list x y))) + (a 1)) + +(test + (let ((f (lambda-match + (() (list 0 :args)) + ((@a) (list 1 :arg a)) + ((@a @b) (list 2 :args a b)) + ((@a @b . @c) (list* '> 2 :args a b c))))) + (list [f] [f 1] [f 1 2] [f 1 2 3])) + ((0 :args) (1 :arg 1) (2 :args 1 2) (> 2 :args 1 2 3))) + +(test + [(lambda-match + ((0 1) :zero-one) + ((1 0) :one-zero) + ((@x @y) :no-match)) 1 0] + :one-zero) + +(test + [(lambda-match + ((0 1) :zero-one) + ((1 0) :one-zero) + ((@x @y) :no-match)) 1 1] + :no-match) + +(compile-only + (eval-only + (test + [(lambda-match + ((0 1) :zero-one) + ((1 0) :one-zero) + ((@x @y) :no-match)) 1 2 3] + :error))) + +(test + [(lambda-match + ((@a @b) (list a b)) + ((@x . @y) (list x y))) + 1 2 3] + (1 (2 3))) + +(test + [(lambda-match + ((@a @b) (list a b)) + (@x x)) + 1 2 3] + (1 2 3)) + +(defun-match fib + ((0) 1) + ((1) 1) + ((@x) (+ (fib (pred x)) (fib (ppred x))))) + +(mtest + (fib 0) 1 + (fib 1) 1 + (fib 2) 2 + (fib 3) 3 + (fib 4) 5 + (fib 5) 8) + +(defun-match ack + ((0 @n) (+ n 1)) + ((@m 0) (ack (- m 1) 1)) + ((@m @n) (ack (- m 1) (ack m (- n 1))))) + +(mtest + (ack 1 1) 3 + (ack 2 2) 7) + +(defun x-x-y (list x) + (when-match (@x @x @y) list y)) + +(mtest + (x-x-y '(1 1 2) 1) 2 + (x-x-y '(1 2 3) 1) nil + (x-x-y '(1 1 2 r2) 1) nil) + +(test (let ((a 3) (x 0)) + (match-case '(3 2 1) + ((@x 2 @b) ^(1 ,b)) + ((@a 2 @b) ^(2 ,a)))) + (2 3)) + +(test + (let ((a 3) (x 0)) + (labels ((local (:match) + ((@x 2 @b) ^(1 ,b)) + ((@a 2 @b) ^(2 ,a)))) + (local 3 2 1))) + (2 3)) + +(test + (when-match @(sme (1 2) (3 4) (5 . 6) m e) + '(1 2 3 4 5 . 6) + (list m e)) + ((3 4 5 . 6) (5 . 6))) + +(test + (when-match @(sme (1 2) (3 4) (5 . 6) m d) + '(1 2 abc 3 4 def 5 . 6) + (list m d)) + ((3 4 def 5 . 6) (5 . 6))) + +(test + (when-match @(sme (1 2 @x . @y) (4 @z) 6) + '(1 2 abc 3 4 def 5 . 6) + (list x y z)) + (abc (3 4 def 5 . 6) def)) + +(mtest + (when-match @(sme (1 2) (2 3) (4)) '(1 2 3 4) t) nil + (when-match @(sme (1 2) (3 4) (4)) '(1 2 3 4) t) nil + (when-match @(sme (1 2) (2 3) (3 4)) '(1 2 3 4) t) nil + (when-match @(sme (1 2 . @x) (3 . @y) (4)) '(1 2 3 4) t) t + (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4) t) t + (when-match @(sme (1 2 . @x) (3 . @y) ()) '(1 2 3 4 . 5) t) nil) + +(test (when-match @(sme (1 @y) (@z @x @y @z) (@x @y)) '(1 2 3 1 2 3 1 2) + (list x y z)) + (1 2 3)) + +(test (when-match @(and @(sme (1 @x) (3) (7) m n) + @(with @(coll @(oddp @y)) (ldiff m n))) + '(1 2 3 4 5 6 7) + (list x y)) + (2 (3 5))) + +(test (when-match @(sme () () 5) 5 t) t) + +(mtest + (when-match @(end 3 x) 3 x) 3 + (when-match @(end (2 @x) y) '(1 2 3) (list x y)) (3 (2 3)) + (when-match @(end (2 . @x) y) '(1 2 . 3) (list x y)) (3 (2 . 3))) + +(test (when-match @(as z @(end (2 @x) y)) '(1 2 3) (list x y z)) + (3 (2 3) (1 2 3))) + +(defmatch env (var :env e) + ^@(with ,var ',e)) + +(test (when-match @(and @a @(env e) @b) 42 + (list a (env-vbindings e) (lexical-var-p e 'a) (lexical-var-p e 'b) b)) + (42 ((a . sys:special)) t nil 42)) + +(defmatch var= (sym :env e) + (if (lexical-var-p e sym) + (with-gensyms (obj) + ^@(require (sys:var ,obj) (= ,sym ,obj))) + ^(sys:var ,sym))) + +(test (when-match (@(var= a) @(var= a)) '(1 1.0) a) 1) + +(mtest + (when-match `` "" t) t + (when-match `abc` "abc" t) t + (when-match `abc` "abcdef" t) nil + (when-match `@a` "abc" a) "abc" + (let ((x "foo")) (when-match `@x` "foobar" t)) nil + (let ((x "foo")) (when-match `@x` "foo" x)) "foo") + +(mtest + (when-match `@a@b` "abc" a) :error + (when-match `@nil@b` "abc" a) :error + (when-match `@nil@nil` "abc" a) :error + (when-match `@a@nil` "abc" a) :error) + +(mtest + (when-match `@a-$` "a-$" a) "a" + (when-match `#@a-$` "#a-$" a) "a" + (when-match `#@a-$` "#a-$$" a) nil + (when-match `#@a-$` "#a-" a) nil + (when-match `#@a-@b` "#a-$" (list a b)) ("a" "$") + (when-match `#@{a #/ab*c/}` "#abbbc" a) "abbbc" + (when-match `#@{a #/ab*c/}d` "#abbbcd" a) "abbbc" + (when-match `#@{nil #/ab*c/}` "#abbbc" t) t + (when-match `#@{nil #/ab*c/}d` "#abbbcd" t) t + (when-match `#@{a 3}@b` "#abb" a) "abb" + (when-match `#@{a 3}@b` "#abbbc" (list a b)) ("abb" "bc") + (when-match `#@{a 4}@b` "#abb" a) nil + (when-match `#@{a 3}` "#abb" a) "abb" + (when-match `#@{a 2}` "#abb" a) nil + (when-match `#@{a 4}` "#abb" a) nil) + +(let ((z 0)) + (mtest + (when-match `@z#@a-$` "0#a-$" a) "a" + (when-match `@z#@a-$` "0#a-$$" a) nil + (when-match `@z#@a-$` "0#a-" a) nil + (when-match `@z#@a-@b` "0#a-$" (list a b)) ("a" "$") + (when-match `@z#@{a #/ab*c/}` "0#abbbc" a) "abbbc" + (when-match `@z#@{a #/ab*c/}d` "0#abbbcd" a) "abbbc" + (when-match `@z#@{a 3}@b` "0#abb" a) "abb" + (when-match `@z#@{a 3}@b` "0#abbbc" (list a b)) ("abb" "bc") + (when-match `@z#@{a 4}@b` "0#abb" a) nil + (when-match `@z#@{a 3}` "0#abb" a) "abb" + (when-match `@z#@{a 2}` "0#abb" a) nil + (when-match `@z#@{a 4}` "0#abb" a) nil)) + +(test (when-match `#@{a 4 5}` "#abb" a) :error) + +(let ((b "bcd")) + (mtest + (when-match `@a@b` "abcd" a) "a" + (when-match `@a@{b [1..:]}` "acd" a) "a" + (when-match `@a@{b [1..:]}` "abcd" a) "ab" + (when-match `@a@{b [0..1]}` "abcd" a) nil + (when-match `@a@{b [0..2]}d` "abcd" a) "a")) + +(let ((x 123) (z 0)) + (mtest + (when-match `^@{x 5}$` "^123 $" t) t + (when-match `^@{x -5}$` "^ 123$" t) t + (when-match `@x@x` "123123" t) t + (when-match `@x@{x [1..:]}` "12323" t) t + (when-match `@z^@{x 5}$` "0^123 $" t) t + (when-match `@z^@{x -5}$` "0^ 123$" t) t + (when-match `@z@x@x` "0123123" t) t + (when-match `@z@x@{x [1..:]}` "012323" t) t)) + +(let ((a "$")) + (test (when-match `@a-@b` "$-@" b) "@")) + +(mtest + (when-match `@{a #/\d+/}-@{a #/\d+/}` "123-123" a) "123" + (when-match `@{a #/\d+/}-@{a #/\d+/}-` "123-123-" a) "123" + (when-match `@{a #/\d+/}-@{a #/\d+/}` "123-1234" a) nil + (when-match `@{a #/\d+/}-@{a #/\d+/}-` "123-1234-" a) nil) + +(test + (build + (each-match (`(@a) @b-@c` '("x" + "" + "(311) 555-5353" + "(604) 923-2323" + "133" + "4-5-6-7") + @x 1) + (add (list x a b c)))) + ((3 "311" "555" "5353") (4 "604" "923" "2323"))) + +(test + (append-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d)) + (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo))) + (list x y)) + (1 a 3 c)) + +(test + (append-matches (@x '((1) (2) (3) 4)) x) + (1 2 3 . 4)) + +(test + (keep-matches ((:foo @y) '((:foo a) (:bar b) (:foo c) (:foo d)) + (@x :bar) '((1 :bar) (2 :bar) (3 :bar) (4 :foo))) + (list x y)) + ((1 a) (3 c))) + +(test + (build + (each-match-product (`(@a) @b-@c` '("x" + "" + "(311) 555-5353" + "(604) 923-2323" + "133" + "4-5-6-7") + @(oddp @x) '(1 2 3)) + (add (list x a b c)))) + ((1 "311" "555" "5353") (3 "311" "555" "5353") + (1 "604" "923" "2323") (3 "604" "923" "2323"))) + +(test + (append-match-products (@(oddp @x) (range 1 5) + @(evenp @y) (range 1 5)) + (list x y)) + (1 2 1 4 3 2 3 4 5 2 5 4)) + +(test + (keep-match-products (@(oddp @x) (range 1 5) + @(evenp @y) (range 1 5)) + (list x y)) + ((1 2) (1 4) (3 2) (3 4) (5 2) (5 4))) + +(test + (each-match (@a '(1 2 3)) (return 42)) 42) + +(mtest + (when-match ^(,a ,b) '(1 2) (list a b)) (1 2) + (when-match ^(,(oddp @a) ,(evenp @b)) '(1 2) (list a b)) (1 2) + (when-match ^#(,a ,b) #(1 2) (list a b)) (1 2) + (when-match ^#S(,type year ,y) #S(time year 2021) + (list (struct-type-name type) y)) (time 2021) + (when-match ^#H(() (x ,y) (,(symbolp @y) ,datum)) + #H(() (x k) (k 42)) + datum) (42)) + +(mtest + (when-match ^#J~a 42.0 a) 42.0 + (when-match ^#J[~a, ~b] #J[true, false] (list a b)) (t nil) + (when-match ^#J{"x" : ~y, ~(symbolp @y) : ~datum} + #J{"x" : true, true : 42} + datum) (42.0) + (when-match ^#J{"foo" : {"x" : ~val}} #J{"foo" : {"x" : "y"}} val) "y") + +(test + (let ((a '(1 2 3 4))) + (build + (while-match @(true @x) (pop a) + (add (* 10 x))))) + (10 20 30 40)) + +(test + (let ((a '(1 (2 3) 4 (5 6)))) + (build + (while-match-case (pop a) + ((@x @y) (add :pair x y)) + (@(numberp @x) (add :num x))))) + (:num 1 :pair 2 3 :num 4 :pair 5 6)) + +(test + (let ((a '(1 (2 3) 4 (5 6)))) + (build + (while-true-match-case (pop a) + ((@x @y) (add :pair x y)) + (@(evenp @x) (add :even x)) + (@(oddp @x) (add :odd x)) + (@else (error "unhandled case"))))) + (:odd 1 :pair 2 3 :even 4 :pair 5 6)) + +(mtest + (match (@a @b) '(1 2) (list a b)) (1 2) + (match (@a @b) '(1 2 3) (list a b)) :error) + +(mtest + (match-ecase 42) :error + (match-ecase 42 (@a a)) 42 + (match-ecase '(1 2) ((@a) a)) :error) + +(mtest + (match @`foo-@a` "foo-abc" a) "abc" + (match ^(,`foo-@a`) '("foo-abc") a) "abc" + (match ^#J[~`foo-@a`] #("foo-abc") a) "abc") + +(mtest + (match @(< @nil 0) -1 42) 42 + (match @(> 0 @nil) -1 42) 42 + (if-match @(< @nil 0) 1 :y :n) :n + (if-match @(< @nil 2) 1 :y :n) :y + (match @(@nil (< @x 0)) -1 x) -1 + (match @(@nil (< @nil 0)) -1 t) t) + +(mtest + (match ^(foo) '(foo) t) t + (match ^#H() #H(() (a b)) t) t + (match ^#H(()) #H(() (a b)) t) t + (match ^#S(time) #S(time year 2023) t) t) + +(mtest + (match-cond (t)) :error + (match-cond (t t)) t + (match-cond (t t nil)) nil + (match-cond (t t t)) t + (let ((x 42)) + (match-cond + (`@x-73` "73-73" :a) + (`@x-@y` "42-24" y))) "24" + (let ((x 42) + (y 24)) + (match-cond + (`@x-24` `42-@y`))) "42-24") + +(mtest + (symacrolet ((x 3)) + (match @x 4 x)) :error + (symacrolet ((x 3)) + (match @x 3 x)) 3 + (let ((x 3)) + (match @x 4 x)) :error + (let ((x 3)) + (match @x 3 x)) 3) + +(defvar dv :dv) +(defsymacro gs :gs) + +(mtest + (match @dv 0 dv) :error + (match @dv :dv dv) :dv + (match @gs 0 gs) :error + (match @gs :gs gs) :gs) + +(mtest + (match @(end @x) '(1 . 2) x) 2 + (match @(end @(evenp @x)) '(1 . 2) x) 2 + (match @(end (@z . @x)) '(1 . 2) (list z x)) (1 2) + (match @(end (@z . @(evenp @x))) '(1 . 2) (list z x)) (1 2)) + +(mtest + (match @(sme (@a) (@b) @x) '(0 1 . 2) (list a b x)) (0 1 2) + (match @(sme (@a) (@b) @(evenp @x)) '(0 1 . 2) (list a b x)) (0 1 2)) + +(compile-only + (eval-only + (with-compile-opts (nil unused) + (compile-file (base-name *load-path*) "temp.tlo")) + (remove-path "temp.tlo"))) diff --git a/tests/011/place.tl b/tests/011/place.tl new file mode 100644 index 00000000..eb0dcb46 --- /dev/null +++ b/tests/011/place.tl @@ -0,0 +1,9 @@ +(load "../common") + +(defvar h (hash)) + +(mtest + (let ((x 0)) (ensure (gethash h (pinc x)) "a") x) 1 + [h 0] "a" + (let ((x 0)) (ensure (gethash h 0) (pinc x)) x) 0 + [h 0] "a") diff --git a/tests/011/tree-bind.tl b/tests/011/tree-bind.tl new file mode 100644 index 00000000..ac55cc07 --- /dev/null +++ b/tests/011/tree-bind.tl @@ -0,0 +1,20 @@ +(load "../common") + +(mtest + (tree-bind b '(1 2) b) (1 2) + (tree-bind (t b) '(1 2) b) 2 + (tree-bind (t . b) '(1 2) b) (2) + (tree-bind (b t) '(1 2) b) 1 + (tree-bind (b . t) '(1 2) b) 1 + (tree-bind t '(1 2) 3) 3 + (tree-bind (t : b) '(1 2) b) 2 + (tree-bind (b : t) '(1) b) 1 + (tree-bind (b : (t 2)) '(1) b) 1 + (tree-bind (#:b : (a 2 t)) '(1) a) 2 + (let ((i 0)) (tree-bind (b : (t (inc i) t)) '(1) (cons i b))) (1 . 1) + (let ((i 0)) (tree-bind (b : (t (inc i) t)) '(1 2) (cons i b))) (0 . 1)) + +(compile-only + (eval-only + (compile-file (base-name *load-path*) "temp.tlo") + (remove-path "temp.tlo"))) diff --git a/tests/011/txr-case.expected b/tests/011/txr-case.expected index 4af473e5..e7582780 100644 --- a/tests/011/txr-case.expected +++ b/tests/011/txr-case.expected @@ -2,3 +2,4 @@ no match for 09-10-20 match: year 2009, month 10, day 20 no match for July-15-2014 no match for foo +match: year 2021, month 06, day 16, foo:bar diff --git a/tests/011/txr-case.txr b/tests/011/txr-case.txr index 1aa80478..d6d8d788 100644 --- a/tests/011/txr-case.txr +++ b/tests/011/txr-case.txr @@ -1,4 +1,5 @@ @(load `@{stdlib}txr-case`) +@(include "../common") @(define date (year month day)) @{year /\d\d\d\d/}-@{month /\d\d/}-@{day /\d\d/} @(end) @@ -7,3 +8,19 @@ (txr-if date (y m d) date (put-line `match: year @y, month @m, day @d`) (put-line `no match for @date`)))) +@(define notmatch ()) +blah +@(end) +@(define stuff (year month day a b)) +@(date year month day) +@a @b +@(end) +@(do (txr-case (make-strlist-input-stream '("2021-06-16" + "foo bar")) + + (notmatch () (put-line "notexpected")) + (stuff (y m d a b) (put-line `match: year @y, month @m, day @d, @a:@b`))) + (mtest + (match-fboundp 'notmatch) t + (match-fboundp 'stuff) t + (match-fboundp 'xyzzy) nil)) diff --git a/tests/012/aseq.expected b/tests/012/aseq.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/aseq.expected +++ /dev/null diff --git a/tests/012/aseq.tl b/tests/012/aseq.tl index dfb20118..e1a55fb8 100644 --- a/tests/012/aseq.tl +++ b/tests/012/aseq.tl @@ -8,7 +8,11 @@ (:method lambda (me i) (if (rangep i) (mapcar (op + me.n) [me.list i]) - (+ me.n (ref me.list i))))) + (+ me.n (ref me.list i)))) + (:method lambda-set (me i nv) + (if (rangep i) + (set [me.list i] (mapcar (lop - me.n) nv)) + (set [me.list i] (- nv me.n))))) (defvarl o (new (add 3 (range 10 100 10)))) @@ -16,3 +20,8 @@ (test (cadr o) 23) (test [o 4] 53) (test (cadr (last o)) nil) + +(test (set [o 0..3] '(1003 1103 1203)) (1003 1103 1203)) +(test o.list (1000 1100 1200 40 50 60 70 80 90 100)) +(test (del [o 1..4]) (1103 1203 43)) +(test o.list (1000 50 60 70 80 90 100)) diff --git a/tests/012/ashwin.expected b/tests/012/ashwin.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/ashwin.expected +++ /dev/null diff --git a/tests/012/binding.tl b/tests/012/binding.tl new file mode 100644 index 00000000..59c1ff04 --- /dev/null +++ b/tests/012/binding.tl @@ -0,0 +1,5 @@ +(load "../common") + +(test + (mac-env-param-bind '(foo) 42 (:env e :form f x y) '(1 2) (list x y e f)) + (1 2 42 (foo))) diff --git a/tests/012/buf.tl b/tests/012/buf.tl new file mode 100644 index 00000000..01a510ab --- /dev/null +++ b/tests/012/buf.tl @@ -0,0 +1,28 @@ +(load "../common") + +(vtest (uint-buf (make-buf 8 255 16)) (pred (expt 2 64))) +(test (int-buf (make-buf 8 255 16)) -1) + +(mtest + (str-buf #b'E6BC') "\xDCE6\xDCBC" + (buf-str "\xDCE6\xDCBC") #b'E6BC' + (str-buf #b'E6') "\xDCE6" + (buf-str "\xDCE6") #b'E6') + +(when (fboundp 'usr:buf-compress) + (mtest + (< (len (buf-compress (make-buf 1024))) 100) t + (buf-compress (make-buf 1024) -2) :error + (buf-compress (make-buf 1024) 10) :error) + + (each ((i 0..65535)) + (let* ((buf (ffi-put i (ffi uint16))) + (zbuf (buf-compress buf))) + (vtest (buf-decompress zbuf) buf))) + + (let ((buf (random-buf 65536))) + (vtest (buf-decompress (buf-compress buf)) buf)) + + (mtest + (buf-decompress (make-buf 1024)) :error + (buf-decompress (make-buf 1024 255)) :error)) diff --git a/tests/012/cadr.tl b/tests/012/cadr.tl new file mode 100644 index 00000000..509590f7 --- /dev/null +++ b/tests/012/cadr.tl @@ -0,0 +1,14 @@ +(load "../common") + +(mtest + (cxr 1 42) 42 + (cxr #b11 '(a . b)) a + (cxr #b10 '(a . b)) b + (cxr #b11000 '(1 2 3 4 5)) 4 + (cyr #b100001 '(1 2 3 4 5)) 5 + (cyr #b1111 '(((a)))) a + (cyr #b111 '(a)) :error) + +(let ((r (range* 0 100))) + (vtest (mapcar (op cyr (succ (expt 2 (succ @1))) r) 0..100) r) + (vtest (mapcar (op cxr (* 3 (expt 2 @1)) r) 0..100) r)) diff --git a/tests/012/callable.tl b/tests/012/callable.tl new file mode 100644 index 00000000..9e88b955 --- /dev/null +++ b/tests/012/callable.tl @@ -0,0 +1,31 @@ +(load "../common") + +(mtest + [0 '(1 2 3)] 1 + [1 '(1 2 3)] 2 + [2 '(1 2 3)] 3) + +(mtest + [0 "abc"] #\a + [1 "abc"] #\b + [2 "abc"] #\c) + +(mtest + [0..1 '(1 2 3)] (1) + [1..3 '(1 2 3)] (2 3)) + +(mtest + [0..0 "abc"] "" + [0..2 "abc"] "ab" + [-1..: "abc"] "c") + +(test (mapcar [callf list* 2 0 1 3..:] '((A B C X) (D E F Y) (G H I Z))) + ((C A B X) (F D E Y) (I G H Z))) + +(mtest + (set [1 1] 2) :error + (set [1 1..2] 2) :error + (set [1..2 1] 2) :error + (set [1..2 1..2] 2) :error + (let ((abc "abc")) (set [1..2 abc] "42") abc) "a42c" + (let ((abc "abc")) (set [1 abc] #\d) abc) "adc") diff --git a/tests/012/case.tl b/tests/012/case.tl new file mode 100644 index 00000000..856ac56c --- /dev/null +++ b/tests/012/case.tl @@ -0,0 +1,32 @@ +(load "../common") + +(mtest + (caseq 0 (1 :match)) nil + (caseq 0 ((1) :match)) nil + (caseq 1 (1 :match)) :match + (caseq 1 ((1) :match)) :match + (caseq 1 ((0 1) :match)) :match + (caseq 1 ((0 2) :match)) nil + (caseq 1 (t :match)) :match + (caseq 1 ((t) :match)) nil + (caseq t ((t) :match)) :match) + +(defvar o 1) +(defvar y t) + +(mtest + (caseq* 0 (o :match)) nil + (caseq* 0 ((o) :match)) nil + (caseq* 1 (o :match)) :match + (caseq* 1 ((o) :match)) :match + (caseq* 1 ((0 o) :match)) :match + (caseq* 1 ((0 2) :match)) nil + (caseq* 1 (t :match)) :match + (caseq* 1 (y :match)) nil + (caseq* 1 ((t) :match)) nil + (caseq* t ((t) :match)) :match + (caseq* t ((y) :match)) :match) + +(test (casequal '(a b c d) + (((a b c d)) :match)) + :match) diff --git a/tests/012/circ.tl b/tests/012/circ.tl index 4b6e9990..82abe745 100644 --- a/tests/012/circ.tl +++ b/tests/012/circ.tl @@ -5,9 +5,9 @@ (print me.a stream pretty-p) (put-string "]]" stream))) -(defvar x (let* ((l (list "a")) - (c (new circ-print a l))) - (list l c))) +(defvarl x (let* ((l (list "a")) + (c (new circ-print a l))) + (list l c))) (let ((*print-circle* t)) (prinl (new circ-print a "a")) diff --git a/tests/012/compile.tl b/tests/012/compile.tl new file mode 100644 index 00000000..b79d92f4 --- /dev/null +++ b/tests/012/compile.tl @@ -0,0 +1,15 @@ +(defparml %this-dir% (dir-name *load-path*)) +(defparml %expected-file% `@(m^ #/.*[.]/ *load-path*)expected`) + +(file-put-string %expected-file% "") + +(each ((f '#"aseq ashwin circ cont defset except \ + fini ifa man-or-boy oop-mi oop-seq oop \ + parse syms quasi quine seq stslot const type")) + (let ((exf `@{%this-dir%}/@f.expected`)) + (when (path-exists-p exf) + (file-append-string %expected-file% + (file-get-string exf)))) + (with-compile-opts (nil unused) + (compile-file `@f.tl` "temp.tlo")) + (remove-path "temp.tlo")) diff --git a/tests/012/cons.tl b/tests/012/cons.tl new file mode 100644 index 00000000..98267290 --- /dev/null +++ b/tests/012/cons.tl @@ -0,0 +1,35 @@ +(load "../common") + +(mtest + (tree-find "abc" "abc") t + (tree-find "abc" "abc" (fun eq)) nil + (tree-find "b" '("a" "b" "c")) t + (tree-find "b" '("a" "b" "c") (fun eq)) nil + (tree-find "b" '(("b") "a" "c")) t + (tree-find "b" '("a" ("b") "c")) t + (tree-find "b" '("a" (("b")) "c")) t + (tree-find "d" '("a" (("b")) "c")) nil + (tree-find nil '("a" (("b")) "c")) nil) + +(mtest + (cons-find "abc" "abc") t + (cons-find "abc" "ABC" (fun eq)) nil + (cons-find "b" '("a" "b" "c")) t + (cons-find "b" '("a" "b" "c") (fun eq)) nil + (cons-find "b" '(("b") "a" "c")) t + (cons-find "b" '("a" ("b") "c")) t + (cons-find "b" '("a" (("b")) "c")) t + (cons-find "d" '("a" (("b")) "c")) nil + (cons-find "d" '("a" (("b")) "c" . "d")) t + (cons-find "d" '("a" (("b") . "d") "c")) t + (cons-find "d" '("a" . "d")) t + (cons-find nil '("a" (("b")) "c")) t) + +(mtest + (cons-count "abc" "abc") 1 + (cons-count "abc" "abc" (fun eq)) 0 + (cons-count "b" '("b" . "b")) 2 + (cons-count "b" '(3 . "b")) 1 + (cons-count "b" '("b" . 3)) 1 + (cons-count "b" '(("b" . "b") ("b" . "b"))) 4 + (cons-count nil '(1 (2 3 (4)))) 3) diff --git a/tests/012/const.tl b/tests/012/const.tl new file mode 100644 index 00000000..e0235e30 --- /dev/null +++ b/tests/012/const.tl @@ -0,0 +1,23 @@ +(load "../common") + +(mtest + (constantp nil) t + (constantp t) t + (constantp :key) t + (constantp 'a) nil) + +(mtest + (constantp ''a) t + (constantp '(+)) t + (constantp '(+ 2)) t + (constantp '(+ 2 2)) t) + +(mtest + (constantp '(+ a)) nil + (constantp '(+ (* 2 2) (* 3 3))) t + (constantp '(+ (* 2 2) (* 3 a))) nil) + +(mtest + (constantp '(list 1 2 3)) nil + (constantp '(symacrolet ((a 1)) (+ a))) t + (constantp '(let ((a 1)) (+ a))) nil) diff --git a/tests/012/cont.expected b/tests/012/cont.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/cont.expected +++ /dev/null diff --git a/tests/012/cont.tl b/tests/012/cont.tl index 0a728ff9..f6724439 100644 --- a/tests/012/cont.tl +++ b/tests/012/cont.tl @@ -24,8 +24,8 @@ (defun amb (. args) (suspend amb-scope cont (each ((a args)) - (when (and a (call cont a)) - (return-from amb a))))) + (whenlet ((res (and a (call cont a)))) + (return-from amb-scope res))))) (test (amb-scope (let ((w1 (amb "the" "that" "a")) @@ -37,3 +37,16 @@ (eql [w3 -1] [w4 0]))) (list w1 w2 w3 w4))) ("that" "thing" "grows" "slowly")) + +(unless (>= (sizeof wchar) 4) + (exit 0)) + +(test (amb-scope + (let ((🍌 [apply amb (range 95795 95805)]) + (🍏 [apply amb (range 217510 217520)]) + (🍉 [apply amb (range 414555 414570)]) + (🍒 [apply amb (range 422470 422485)])) + (amb (= (+ (expt 🍌 4) (expt 🍏 4) (expt 🍉 4)) + (expt 🍒 4))) + (list 🍌 🍏 🍉 🍒))) + (95800 217519 414560 422481)) diff --git a/tests/012/defset.expected b/tests/012/defset.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/defset.expected +++ /dev/null diff --git a/tests/012/defset.tl b/tests/012/defset.tl index 110f3c64..917c0a9c 100644 --- a/tests/012/defset.tl +++ b/tests/012/defset.tl @@ -19,3 +19,15 @@ (expand '(inc (foo 1 2 :a 3 :b 4) 5)) ^(let ((,%new-val-sym% (+ (foo 1 2 :a 3 :b 4) 5))) (bar 1 2 3 4 () 4 ,%new-val-sym%))) + +(defvarl %data% (vec 0 0 0 0 0 0 0 0 0 1)) +(defun getd (a b c) [%data% (+ a b c)]) +(defun setd (a b c v) (set [%data% (+ a b c)] v)) +(define-accessor getd setd) + +(mtest + (getd 2 3 4) 1 + (set (getd 2 3 4) 2) 2 + [%data% 9] 2 + (inc (getd 2 3 4) 3) 5 + [%data% 9] 5) diff --git a/tests/012/fini.expected b/tests/012/fini.expected index 5e967eb2..72fdc948 100644 --- a/tests/012/fini.expected +++ b/tests/012/fini.expected @@ -2,44 +2,64 @@ inside with-objects base:21 finalized derived:1 derived fini derived:1 finalized +derived:1 derived postfini derived:2 derived fini derived:2 finalized +derived:2 derived postfini derived:3 derived fini derived:3 finalized +derived:3 derived postfini derived:4 derived fini derived:4 finalized +derived:4 derived postfini derived:5 derived fini derived:5 finalized +derived:5 derived postfini derived:6 derived fini derived:6 finalized +derived:6 derived postfini derived:7 derived fini derived:7 finalized +derived:7 derived postfini derived:8 derived fini derived:8 finalized +derived:8 derived postfini derived:9 derived fini derived:9 finalized +derived:9 derived postfini derived:10 derived fini derived:10 finalized +derived:10 derived postfini derived:11 derived fini derived:11 finalized +derived:11 derived postfini derived:12 derived fini derived:12 finalized +derived:12 derived postfini derived:13 derived fini derived:13 finalized +derived:13 derived postfini derived:14 derived fini derived:14 finalized +derived:14 derived postfini derived:15 derived fini derived:15 finalized +derived:15 derived postfini derived:16 derived fini derived:16 finalized +derived:16 derived postfini derived:17 derived fini derived:17 finalized +derived:17 derived postfini derived:18 derived fini derived:18 finalized +derived:18 derived postfini derived:19 derived fini derived:19 finalized +derived:19 derived postfini derived:20 derived fini derived:20 finalized +derived:20 derived postfini after with-objects derived:41 derived fini derived:41 finalized @@ -81,3 +101,31 @@ derived:23 derived fini derived:23 finalized derived:22 derived fini derived:22 finalized +derived:22 derived postfini +derived:23 derived postfini +derived:24 derived postfini +derived:25 derived postfini +derived:26 derived postfini +derived:27 derived postfini +derived:28 derived postfini +derived:29 derived postfini +derived:30 derived postfini +derived:31 derived postfini +derived:32 derived postfini +derived:33 derived postfini +derived:34 derived postfini +derived:35 derived postfini +derived:36 derived postfini +derived:37 derived postfini +derived:38 derived postfini +derived:39 derived postfini +derived:40 derived postfini +derived:41 derived postfini +multi :init: 1 +multi :init: 2 +multi :postinit: 1 +multi :postinit: 2 +multi :fini: 2 +multi :fini: 1 +multi :postfini: 1 +multi :postfini: 2 diff --git a/tests/012/fini.tl b/tests/012/fini.tl index 3aa581f9..506b4c9e 100644 --- a/tests/012/fini.tl +++ b/tests/012/fini.tl @@ -11,7 +11,9 @@ (defstruct derived base (:fini (me) - (put-line `@(typeof me):@{me.id} derived fini`))) + (put-line `@(typeof me):@{me.id} derived fini`)) + (:postfini (me) + (put-line `@(typeof me):@{me.id} derived postfini`))) (unwind-protect (with-objects ((b (new base others (mapcar (ret (new derived)) (range 1 20))))) @@ -19,4 +21,24 @@ (put-line "after with-objects")) (mapcar (ret (new derived)) (range 1 20)) -(sys:gc) +(sys:gc t) + +(defstruct multi () + (:init (me) + (put-line `@{%fun%}: 1`)) + (:init (me) + (put-line `@{%fun%}: 2`)) + (:postinit (me) + (put-line `@{%fun%}: 1`)) + (:postinit (me) + (put-line `@{%fun%}: 2`)) + (:fini (me) + (put-line `@{%fun%}: 1`)) + (:fini (me) + (put-line `@{%fun%}: 2`)) + (:postfini (me) + (put-line `@{%fun%}: 1`)) + (:postfini (me) + (put-line `@{%fun%}: 2`))) + +(with-objects ((m (new multi)))) diff --git a/tests/012/ifa.expected b/tests/012/ifa.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/ifa.expected +++ /dev/null diff --git a/tests/012/ifa.tl b/tests/012/ifa.tl index d669244d..45a2939b 100644 --- a/tests/012/ifa.tl +++ b/tests/012/ifa.tl @@ -10,8 +10,11 @@ (isqrt it))) 7) -;; ambiguous: is "it" x or is "it" y? -(test (let (x y) (ifa (> x y) (print it))) :error) +;; no it-candidates: "it" is leftmost arg x. +(test (let ((x 1) (y 0)) (ifa (> x y) it)) 1) + +;; multiple it-candidates: error +(test (let (x y) (ifa (> (* x x) (* y y)) it)) :error) ;; "it" is (+ 3 (* 2 x)) (test (let ((x 5)) diff --git a/tests/012/iter.tl b/tests/012/iter.tl new file mode 100644 index 00000000..1b1bfd1e --- /dev/null +++ b/tests/012/iter.tl @@ -0,0 +1,92 @@ +(load "../common") + +(mtest + [mapcar identity "A".."D"] ("A" "B" "C" "D") + [mapcar identity "A1".."C2"] ("A1" "A2" "B1" "B2" "C1" "C2") + [mapcar identity "D".."A"] ("D" "C" "B" "A") + [mapcar identity "C2".."A1"] ("C2" "C1" "B2" "B1" "A2" "A1")) + +(test + [maprod append "AA".."DD" "01".."19"] + ("AA01" "AA02" "AA03" "AA04" "AA05" "AA06" "AA07" "AA08" "AA09" + "AA11" "AA12" "AA13" "AA14" "AA15" "AA16" "AA17" "AA18" "AA19" + "AB01" "AB02" "AB03" "AB04" "AB05" "AB06" "AB07" "AB08" "AB09" + "AB11" "AB12" "AB13" "AB14" "AB15" "AB16" "AB17" "AB18" "AB19" + "AC01" "AC02" "AC03" "AC04" "AC05" "AC06" "AC07" "AC08" "AC09" + "AC11" "AC12" "AC13" "AC14" "AC15" "AC16" "AC17" "AC18" "AC19" + "AD01" "AD02" "AD03" "AD04" "AD05" "AD06" "AD07" "AD08" "AD09" + "AD11" "AD12" "AD13" "AD14" "AD15" "AD16" "AD17" "AD18" "AD19" + "BA01" "BA02" "BA03" "BA04" "BA05" "BA06" "BA07" "BA08" "BA09" + "BA11" "BA12" "BA13" "BA14" "BA15" "BA16" "BA17" "BA18" "BA19" + "BB01" "BB02" "BB03" "BB04" "BB05" "BB06" "BB07" "BB08" "BB09" + "BB11" "BB12" "BB13" "BB14" "BB15" "BB16" "BB17" "BB18" "BB19" + "BC01" "BC02" "BC03" "BC04" "BC05" "BC06" "BC07" "BC08" "BC09" + "BC11" "BC12" "BC13" "BC14" "BC15" "BC16" "BC17" "BC18" "BC19" + "BD01" "BD02" "BD03" "BD04" "BD05" "BD06" "BD07" "BD08" "BD09" + "BD11" "BD12" "BD13" "BD14" "BD15" "BD16" "BD17" "BD18" "BD19" + "CA01" "CA02" "CA03" "CA04" "CA05" "CA06" "CA07" "CA08" "CA09" + "CA11" "CA12" "CA13" "CA14" "CA15" "CA16" "CA17" "CA18" "CA19" + "CB01" "CB02" "CB03" "CB04" "CB05" "CB06" "CB07" "CB08" "CB09" + "CB11" "CB12" "CB13" "CB14" "CB15" "CB16" "CB17" "CB18" "CB19" + "CC01" "CC02" "CC03" "CC04" "CC05" "CC06" "CC07" "CC08" "CC09" + "CC11" "CC12" "CC13" "CC14" "CC15" "CC16" "CC17" "CC18" "CC19" + "CD01" "CD02" "CD03" "CD04" "CD05" "CD06" "CD07" "CD08" "CD09" + "CD11" "CD12" "CD13" "CD14" "CD15" "CD16" "CD17" "CD18" "CD19" + "DA01" "DA02" "DA03" "DA04" "DA05" "DA06" "DA07" "DA08" "DA09" + "DA11" "DA12" "DA13" "DA14" "DA15" "DA16" "DA17" "DA18" "DA19" + "DB01" "DB02" "DB03" "DB04" "DB05" "DB06" "DB07" "DB08" "DB09" + "DB11" "DB12" "DB13" "DB14" "DB15" "DB16" "DB17" "DB18" "DB19" + "DC01" "DC02" "DC03" "DC04" "DC05" "DC06" "DC07" "DC08" "DC09" + "DC11" "DC12" "DC13" "DC14" "DC15" "DC16" "DC17" "DC18" "DC19" + "DD01" "DD02" "DD03" "DD04" "DD05" "DD06" "DD07" "DD08" "DD09" + "DD11" "DD12" "DD13" "DD14" "DD15" "DD16" "DD17" "DD18" "DD19")) + +(mtest + [maprod append "A".."F" (drop 1 "00".."15")] + ("A01" "A02" "A03" "A04" "A05" "A10" "A11" "A12" "A13" "A14" "A15" + "B01" "B02" "B03" "B04" "B05" "B10" "B11" "B12" "B13" "B14" "B15" + "C01" "C02" "C03" "C04" "C05" "C10" "C11" "C12" "C13" "C14" "C15" + "D01" "D02" "D03" "D04" "D05" "D10" "D11" "D12" "D13" "D14" "D15" + "E01" "E02" "E03" "E04" "E05" "E10" "E11" "E12" "E13" "E14" "E15" + "F01" "F02" "F03" "F04" "F05" "F10" "F11" "F12" "F13" "F14" "F15") + [maprod append "A".."F" [1..11 "00".."99"]] + ("A01" "A02" "A03" "A04" "A05" "A06" "A07" "A08" "A09" "A10" "B01" + "B02" "B03" "B04" "B05" "B06" "B07" "B08" "B09" "B10" "C01" "C02" + "C03" "C04" "C05" "C06" "C07" "C08" "C09" "C10" "D01" "D02" "D03" + "D04" "D05" "D06" "D07" "D08" "D09" "D10" "E01" "E02" "E03" "E04" + "E05" "E06" "E07" "E08" "E09" "E10" "F01" "F02" "F03" "F04" "F05" + "F06" "F07" "F08" "F09" "F10")) + +(test + [mapcar identity [3..6 0..10]] (3 4 5)) + +;; iterating from fixnum to bignum was rejected in up to txr-269. +(test (each ((x fixnum-max..(* 5 fixnum-max))) (return 42)) 42) + +(test (progn (each ((x "A".."Z")) (sys:gc)) 42) 42) + +(let ((big (* fixnum-max 8))) + (test (progn (each ((x big..(+ 10 big))) (sys:gc)) 42) 42)) + +(mtest + (list-seq 0..5) (0 1 2 3 4) + (list-seq 5..0) (4 3 2 1 0) + (list-seq 0..5.0) (0 1 2 3 4) + (list-seq 5..0.0) (4 3 2 1 0) + (list-seq 0.0..5.0) (0.0 1.0 2.0 3.0 4.0) + (list-seq 5.0..0.0) (4.0 3.0 2.0 1.0 0.0) + (list-seq 0.0..5) (0.0 1.0 2.0 3.0 4.0) + (list-seq 5.0..0) (4.0 3.0 2.0 1.0 0.0) + (list-seq 0.0..5.1) (0.0 1.0 2.0 3.0 4.0 5.0) + (list-seq 0.5..5) (0.5 1.5 2.5 3.5 4.5) + (list-seq (expt 2 256)..(ssucc (expt 2 256))) + (115792089237316195423570985008687907853269984665640564039457584007913129639936 + 115792089237316195423570985008687907853269984665640564039457584007913129639937) + (list-seq (expt 2 256)..(ppred (expt 2 256))) + (115792089237316195423570985008687907853269984665640564039457584007913129639935 + 115792089237316195423570985008687907853269984665640564039457584007913129639934) + (take 3 (list-seq (expt 2 256)..0)) + (115792089237316195423570985008687907853269984665640564039457584007913129639935 + 115792089237316195423570985008687907853269984665640564039457584007913129639934 + 115792089237316195423570985008687907853269984665640564039457584007913129639933)) + diff --git a/tests/012/lambda.tl b/tests/012/lambda.tl new file mode 100644 index 00000000..811dbcfc --- /dev/null +++ b/tests/012/lambda.tl @@ -0,0 +1,162 @@ +(load "../common") + +(defun call-lambda (fn . args) + [fn . args]) + +(defun call-lambda-fixed (fn . args) + (tree-case args + (() [fn]) + ((a1) [fn a1]) + ((a1 a2) [fn a1 a2]) + ((a1 a2 a3) [fn a1 a2 a3]) + ((a1 a2 a3 a4) [fn a1 a2 a3 a4]) + ((a1 a2 a3 a4 a5) [fn a1 a2 a3 a4 a5]) + ((a1 . r) [fn a1 . r]) + ((a1 a2 . r) [fn a1 a2 . r]) + ((a1 a2 a3 . r) [fn a1 a2 a3 . r]) + ((a1 a2 a3 a4 . r) [fn a1 a2 a3 a4 . r]) + ((a1 a2 a3 a4 a5 . r) [fn a1 a2 a3 a4 a5 . r]) + (r [fn . r]))) + +(defmacro ltest (:match :form f) + (([(lambda . @rest) . @args] @expected) + (if *compile-test* + ^(progn + (test [(lambda ,*rest) ,*args] ,expected) + (test (call-lambda (lambda ,*rest) ,*args) ,expected) + (test (call-lambda-fixed (lambda ,*rest) ,*args) ,expected)) + ^(test [(lambda ,*rest) ,*args] ,expected))) + ((@else . rest) (compile-error f "bad syntax"))) + +(defmacro mltest (. pairs) + ^(progn ,*(mapcar (op cons 'ltest) (tuples 2 pairs)))) + +(mltest + [(lambda ())] nil + [(lambda ()) 1] :error + [(lambda (a) a)] :error + [(lambda (a) a) 1] 1 + [(lambda (a) a) 1 2] :error + [(lambda (a b) (list a b)) 1] :error + [(lambda (a b) (list a b)) 1 2] (1 2) + [(lambda (a b) (list a b)) 1 2 3] :error + [(lambda (a b c) (list a b c)) 1 2] :error + [(lambda (a b c) (list a b c)) 1 2 3] (1 2 3) + [(lambda (a b c) (list a b c)) 1 2 3 4] :error) + +(mltest + [(lambda (: a) a)] nil + [(lambda (: (a 1)) a)] 1 + [(lambda (: (a 1)) a) 2] 2 + [(lambda (: (a 1)) a) 2 3] :error + [(lambda (: (a 1 a-p)) (list a a-p))] (1 nil) + [(lambda (: (a 1 a-p)) (list a a-p)) 2] (2 t)) + +(mltest + [(lambda (x : a) (list x a))] :error + [(lambda (x : (a 1)) (list x a))] :error + [(lambda (x : (a 1)) (list x a)) 2] (2 1) + [(lambda (x : (a 1)) (list x a)) 2 3] (2 3) + [(lambda (x : (a 1)) (list x a)) 2 3 4] :error + [(lambda (x : (a 1 a-p)) (list x a a-p))] :error + [(lambda (x : (a 1 a-p)) (list x a a-p)) 2] (2 1 nil)) + +(mltest + [(lambda (x : a) (list x a)) 0] (0 nil) + [(lambda (x : (a 1)) (list x a)) 0] (0 1) + [(lambda (x : (a 1)) (list x a)) 0 2] (0 2) + [(lambda (x : (a 1 a-p)) (list x a a-p)) 0] (0 1 nil) + [(lambda (x : (a 1 a-p)) (list x a a-p)) 0 2] (0 2 t)) + +(mltest + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r))] :error + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1] :error + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2] (1 2 3 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 8] (1 2 8 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 8 9] (1 2 8 9 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 8 9 0] (1 2 8 9 (0))) + +(defvarl vs '(a)) + +(mltest + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) . vs] :error + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 . vs] (1 a 3 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 . vs] (1 2 a 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 . vs] (1 2 3 a nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 4 . vs] (1 2 3 4 (a))) + +(mltest + [(lambda (x y : (a 3) (b 4)) (list x y a b)) . vs] :error + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 . vs] (1 a 3 4) + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 2 . vs] (1 2 a 4) + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 2 3 . vs] (1 2 3 a) + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 2 3 4 . vs] :error) + +(test + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) . vs] :error) + +(mltest + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 . vs] + (1 a 3 nil 4 nil nil) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 . vs] + (1 2 a t 4 nil nil) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 . vs] + (1 2 3 t a t nil) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 4 . vs] + (1 2 3 t 4 t (a)) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 4 5 . vs] + (1 2 3 t 4 t (5 a)) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 : 4 . vs] + (1 2 3 nil 4 t (a)) + [(lambda (x y : (a 3 u) (b 4 v) . r) (list x y a u b v r)) 1 2 3 : . vs] + (1 2 3 t 4 nil (a))) + +(defvarl vl '(a b c d)) + +(mltest + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) . vl] (a b c d nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 . vl] (1 a b c (d)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 . vl] (1 2 a b (c d)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 . vl] (1 2 3 a (b c d)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 4 . vl] (1 2 3 4 (a b c d)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 3 4 5 . vl] (1 2 3 4 (5 a b c d))) + +(mltest + [(lambda (x y : (a 3) (b 4)) (list x y a b)) . vl] (a b c d) + [(lambda (x y : (a 3) (b 4)) (list x y a b)) 1 . vl] :error) + +(mltest + [(lambda (x : y) (list x y)) 1 :] (1 nil) + [(lambda (x : y z) (list x y z)) 1 :] (1 nil nil) + [(lambda (x : y z) (list x y z)) 1 2 :] (1 2 nil) + [(lambda (x : y z) (list x y z)) 1 nil :] (1 nil nil) + [(lambda (x : y z) (list x y z)) 1 nil nil] (1 nil nil)) + +(mltest + [(lambda (x : (y nil)) (list x y)) 1 :] (1 nil) + [(lambda (x : (y nil) (z)) (list x y z)) 1 :] (1 nil nil) + [(lambda (x : (y nil) (z)) (list x y z)) 1 2 :] (1 2 nil) + [(lambda (x : (y nil) (z)) (list x y z)) 1 nil :] (1 nil nil) + [(lambda (x : (y nil) (z)) (list x y z)) 1 nil nil] (1 nil nil)) + +(defvarl vc '(: : : :)) + +(mltest + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) . vc] (: : 3 4 nil) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 . vc] (1 : 3 4 (:)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 . vc] (1 2 3 4 (: :)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 0 . vc] (1 2 0 4 (: : :)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 0 0 . vc] (1 2 0 0 (: : : :)) + [(lambda (x y : (a 3) (b 4) . r) (list x y a b r)) 1 2 0 0 5 . vc] (1 2 0 0 (5 : : : :))) + +(test (functionp (lambda (: (n n)) n)) t) + +(defvarl n) + +(ltest + [(lambda (: (n n)) n)] nil) + +(cond + (*compile-test* (exit t)) + (t (set *compile-test* t) + (load (base-name *load-path*)))) diff --git a/tests/012/lazy.tl b/tests/012/lazy.tl new file mode 100644 index 00000000..be04412a --- /dev/null +++ b/tests/012/lazy.tl @@ -0,0 +1,6 @@ +(load "../common") + +(test [mapcar* list nil] nil) +(test [mapcar* list '(1)] ((1))) +(test [mapcar* list '(1 2 3)] ((1) (2) (3))) +(test [mapcar* list '(1 2 3) '(a b c)] ((1 a) (2 b) (3 c))) diff --git a/tests/012/less.tl b/tests/012/less.tl new file mode 100644 index 00000000..11748c7f --- /dev/null +++ b/tests/012/less.tl @@ -0,0 +1,21 @@ +(load "../common") + +(mtest + (less #() #(a)) t + (greater #() #(a)) nil + (less #(0) #(1)) t + (greater #(0) #(1)) nil + (less #(1) #(0)) nil + (greater #(1) #(0)) t + (less #(0) #(0 0)) t + (less #(1) #(0 0)) nil + (less #(0 0) #(0 1)) t + (less #(0 0) #(0 0)) nil + (less #(0 0) #(0 0 0)) t) + +(mtest + (less '() #()) t + (less '(0) #(0)) t + (less "a" #(#\a)) t + (less #() #b'') t + (less #(0) #b'00') t) diff --git a/tests/012/oop-dsc.tl b/tests/012/oop-dsc.tl new file mode 100644 index 00000000..7885f386 --- /dev/null +++ b/tests/012/oop-dsc.tl @@ -0,0 +1,80 @@ +(load "../common") + +(define-struct-clause :nothing (. ignored-args)) + +(defstruct s0 () + (:nothing 1 "foo" :junk) + x) + +(test (new s0) #S(s0 x nil)) + +(define-struct-clause :multi (init-val . names) + (mapcar (lop list init-val) names)) + +(defstruct s1 () + (:multi 0 a b c)) + +(test (new s1) #S(s1 a 0 b 0 c 0)) + +(define-struct-clause :getset (slot getter setter : init-val) + ^((,slot ,init-val) + (:method ,getter (obj) obj.,slot) + (:method ,setter (obj new) (set obj.,slot new)))) + +(defstruct s2 () + (:getset a get-a set-a 0) + (:getset b get-b set-b 0)) + +(let ((s2 (new s2))) + (mtest + s2.a 0 + s2.b 0 + s2.(get-a) 0 + s2.(get-b) 0 + s2.(set-a 42) 42 + s2.(set-b 73) 73 + s2.a 42 + s2.b 73 + s2.(get-a) 42 + s2.(get-b) 73)) + +(define-struct-clause :hash (hash-name by-slot) + ^((:static ,hash-name (hash)) + (:postinit (me) + (set [me.,hash-name me.,by-slot] me)) + (:postfini (me) + (del [me.,hash-name me.,by-slot])))) + +(defstruct s3 () + a b + (:hash a-hash a) + (:hash b-hash b)) + +(let* ((s3-list (list (new s3 a "one" b 1) + (new s3 a "two" b 2) + (new s3 a "three" b 3))) + (s3 (first s3-list))) + (mtest + [s3.a-hash "one"].a "one" + [s3.a-hash "two"].b 2 + [s3.a-hash "three"].b 3 + [s3.b-hash 1].a "one" + [s3.b-hash 2].b 2 + [s3.b-hash 3].a "three") + (call-finalizers s3) + (test [s3.a-hash "one"] nil)) + +(define-struct-clause :s3 () + '((:inherit s3) + (:inherit passwd group))) + +(defstruct s4 (time) + (:s3)) + +(let ((s4 (new s4 a "x" b 999))) + (mtest + [s4.a-hash "two"].a "two" + [s4.a-hash "x"].a "x" + [s4.b-hash 999].a "x" + s4.uid nil + s4.gid nil)) diff --git a/tests/012/oop-mac.tl b/tests/012/oop-mac.tl new file mode 100644 index 00000000..d3c3e480 --- /dev/null +++ b/tests/012/oop-mac.tl @@ -0,0 +1,18 @@ +(load "../common") + +(test (with-resources ((a nil (list a)) + (b nil) + (c nil (list c))) + (list a b c)) + (nil nil nil)) + +(test (build + (catch + (with-resources ((a 1 (add a)) + (x nil) + (b 2 (add b)) + (y (throw 'out)) + (z nil t) + (c 3 (add c)))) + (out () (add 4)))) + (2 1 4)) diff --git a/tests/012/oop-mi.expected b/tests/012/oop-mi.expected index 6d112c2e..ebc807f3 100644 --- a/tests/012/oop-mi.expected +++ b/tests/012/oop-mi.expected @@ -1,7 +1,7 @@ -#S(der0 gx gx gy dgy x dx y dy z dz) +#S(der0 li (b1 b2 g) gx gx gy dgy x dx y dy z dz) dgs0 gs1-b1 -#S(der1 x b3x gx b3gx gy gy y b2y) +#S(der1 x b3x gx b3gx li (b1 b2 g) gy gy y b2y) gs0 gs1-b1 (meth base3 b3m0) @@ -15,3 +15,11 @@ gm base1 base2 grand +(b1 b2 g) +(gf b2f b1f b1 b2 g) +(b1 b2 g) +(gf b2f b1f b1 b2 g) +(b1 b2 g) +(gf b2f b1f b1 b2 g) +(b2 b1 g) +(gf b1f b2f b2 b1 g) diff --git a/tests/012/oop-mi.tl b/tests/012/oop-mi.tl index 4431f23d..0e54086a 100644 --- a/tests/012/oop-mi.tl +++ b/tests/012/oop-mi.tl @@ -1,8 +1,11 @@ (load "../common") (defstruct grand nil + (li 'nil) (gx 'gx) (gy 'gy) + (:init (me) (push 'g me.li)) + (:fini (me) (push 'gf me.li)) (:static gs0 'gs0) (:static gs1 'gs1) (:method gm (me) 'gm)) @@ -12,11 +15,15 @@ (defstruct base1 grand (x 'b1x) + (:init (me) (push 'b1 me.li)) + (:fini (me) (push 'b1f me.li)) (:static gs1 'gs1-b1) (:method m (me) 'm1)) (defstruct base2 grand (y 'b2y) + (:init (me) (push 'b2 me.li)) + (:fini (me) (push 'b2f me.li)) (:static gs1 'gs1-b2) (:method m (me) 'm2)) @@ -63,3 +70,9 @@ (prinl (static-slot-home 'der2 'm)) (prinl (static-slot-home 'der3 'm)) (prinl (static-slot-home 'der3 'gm)) + +(each ((ty '(der0 der1 der2 der3))) + (let ((ob (new* ty))) + (prinl ob.li) + (call-finalizers ob) + (prinl ob.li))) diff --git a/tests/012/oop-prelude.expected b/tests/012/oop-prelude.expected new file mode 100644 index 00000000..daf379e0 --- /dev/null +++ b/tests/012/oop-prelude.expected @@ -0,0 +1,5 @@ +#S(fox) created +#S(bear) created +inside with-object +#S(bear) finalized +#S(fox) finalized diff --git a/tests/012/oop-prelude.tl b/tests/012/oop-prelude.tl new file mode 100644 index 00000000..bb0b3d44 --- /dev/null +++ b/tests/012/oop-prelude.tl @@ -0,0 +1,13 @@ +(load "../common") + +(define-struct-prelude init-fini-log (fox bear) + (:init (me) (put-line `@me created`)) + (:fini (me) (put-line `@me finalized`))) + +(defstruct fox ()) + +(defstruct bear ()) + +(with-objects ((f (new fox)) + (b (new bear))) + (put-line "inside with-object")) diff --git a/tests/012/oop-seq.tl b/tests/012/oop-seq.tl new file mode 100644 index 00000000..17463e96 --- /dev/null +++ b/tests/012/oop-seq.tl @@ -0,0 +1,87 @@ +(load "../common") + +(defstruct counter-iter-fast () + cur-val + step + limit + (:method iter-item (me) + me.cur-val) + (:method iter-step (me) + (inc me.cur-val me.step) + (if (< me.cur-val me.limit) me))) + +(defstruct counter-fast () + init + step + limit + (:method iter-begin (me) + (if (< me.init me.limit) + (new counter-iter-fast + cur-val me.init + step me.step + limit me.limit)))) + +(defstruct counter-iter-canon () + cur-val + step + limit + (:method iter-item (me) + me.cur-val) + (:method iter-more (me) + (< me.cur-val me.limit)) + (:method iter-step (me) + (inc me.cur-val me.step) + me)) + +(defstruct counter-canon () + init + step + limit + (:method iter-begin (me) + (new counter-iter-canon + cur-val me.init + step me.step + limit me.limit))) + +(test (list-seq (new counter-canon init 0 step 2 limit 10)) + (0 2 4 6 8)) + +(test (list-seq (new counter-fast init 0 step 2 limit 10)) + (0 2 4 6 8)) + +(test (list-seq (new counter-canon init 0 step 1 limit 0)) + nil) + +(test (list-seq (new counter-fast init 0 step 1 limit 0)) + nil) + +(defstruct integers () + item to next + (:method length-< (me len) + (cond + ((<= len 1) nil) + (me.next me.next.(length-< (pred len))) + (t))) + (:postinit (me) + (if (< me.item me.to) + (set me.next (lnew integers to me.to item (succ me.item)))))) + +(let ((ints (new integers item 1 to 10))) + (mtest + (length-< ints 11) t) + (length-< ints 10) nil + (length-< ints 9) nil) + +;; The following reproduced a segfault when the change was made to allow del to +;; work with structs that have lambda and lambda-set. + +(defstruct blah () + (:method lambda-set (me . args))) + +(defparm o (new blah)) + +(set [o 1..20] 42) + +(defmeth blah lambda (me . args)) + +(set [o 1..20] 42) diff --git a/tests/012/oop.tl b/tests/012/oop.tl index 51dadbf3..5cdd3ec3 100644 --- a/tests/012/oop.tl +++ b/tests/012/oop.tl @@ -2,7 +2,7 @@ (defstruct animal nil (:function whoami () "n/a") - (:method print (self stream : pretty-p) (put-string self.[whoami] stream))) + (:method print (self stream : pretty-p) (put-string [self.whoami] stream))) (defstruct dog animal (:function whoami () "dog")) @@ -77,3 +77,75 @@ (prinl d) (prinl (list b.sa b.sb b.sc b.x b.y)) (prinl (list d.sa d.sb d.sc d.x d.y))) + +(defstruct (ab a : b) () a b) + +(defvar foo) + +(mtest + (new* (foo 'ab) a 1) :error + (new* ((find-struct-type 'ab)) a 1) #S(ab a 1 b nil) + (new* [find-struct-type 'ab] a 1) #S(ab a 1 b nil) + (new* ([find-struct-type 'ab] 1 2)) #S(ab a 1 b 2) + (new* ((find-struct-type 'ab) 1 2)) #S(ab a 1 b 2) + (new* ([find-struct-type 'ab] 1) b 2) #S(ab a 1 b 2) + (let ((type (find-struct-type 'ab))) + (new* type a 3 b 4)) #S(ab a 3 b 4) + (let ((type (find-struct-type 'ab))) + (new* (type 3 4))) #S(ab a 3 b 4)) + +(defstruct worker () + name + (:method work (me) `worker @{me.name} works`) + (:method relax (me : (min 15)) `worker @{me.name} relaxes for @min min`)) + +(defstruct contractor () + sub + (:delegate work (me) me.sub.sub) + (:delegate break (me : min) me.sub.sub relax) + (:delegate break20 (me : (min 20)) me.sub.sub relax)) + +(let ((co (new contractor sub (new contractor sub (new worker name "foo"))))) + (mtest co.(work) "worker foo works" + co.(break) "worker foo relaxes for 15 min" + co.(break 5) "worker foo relaxes for 5 min" + co.(break20 5) "worker foo relaxes for 5 min" + co.(break20) "worker foo relaxes for 20 min")) + +(test + (defstruct bad-delegate () + (:delegate del (x : (y z w)))) + :error) + +(defstruct api-x () + (:method get (x a b : c . d) ^(api-x get ,x ,a ,b ,c ,d)) + (:method put (x s) ^(api-x put ,x ,s))) + +(defstruct api-y () + (:method frob (y r : s) ^(api-y frob ,y ,r ,s)) + (:method tweak (y) ^(api-y tweak ,y))) + +(defstruct api-z () + (:method decrement (z n) ^(api-z decrement ,z ,n)) + (:method increment (z n) ^(api-z increment ,z ,n))) + +(defstruct component () + (ax (new api-x)) + (ay (new api-y)) + (az (new api-z)) + (:mass-delegate o o.ax api-x *) + (:mass-delegate o o.ay api-y frob) + (:mass-delegate o o.az api-z * decrement)) + +(let ((c (new component))) + (mtest + c.(get 1 2 3 . 4) (api-x get #S(api-x) 1 2 3 4) + c.(put 5) (api-x put #S(api-x) 5) + c.(get) :error + c.(put 5 6) :error + c.(frob 7 8) (api-y frob #S(api-y) 7 8) + c.(frob 9) (api-y frob #S(api-y) 9 nil) + c.(frob 7 8 9) :error + c.(tweak) :error + c.(increment 1) (api-z increment #S(api-z) 1) + c.(decrement) :error)) diff --git a/tests/012/op.tl b/tests/012/op.tl new file mode 100644 index 00000000..47f1f80d --- /dev/null +++ b/tests/012/op.tl @@ -0,0 +1,127 @@ +(load "../common") + +(defun fi (fun) + (assert (zerop (fun-optparam-count fun))) + (list (fun-fixparam-count fun) + (fun-variadic fun))) + +(mtest + (fi (op)) :error + (fi (op list)) (0 t) + (fi (op list @1)) (1 t) + (fi (op list @2)) (2 t) + (fi (op list @42)) (42 t) + (fi (op list @rest)) (0 t) + (fi (op list @1 @rest)) (1 t) + (fi (op list @2 @rest)) (2 t) + (fi (op list @42 @rest)) (42 t) + (fi (op list @1 @3 @rest @2)) (3 t)) + +(mtest + (fi (do)) :error + (fi (do progn)) (1 t) + (fi (do progn @1)) (1 t) + (fi (do progn @2)) (2 t) + (fi (do progn @42)) (42 t) + (fi (do progn @rest)) (0 t) + (fi (do progn @1 @rest)) (1 t) + (fi (do progn @2 @rest)) (2 t) + (fi (do progn @42 @rest)) (42 t) + (fi (do progn @1 @3 @rest @2)) (3 t)) + +(mtest + (fi (do if)) (1 t) + (fi (do if @1)) (1 t) + (fi (do if @2)) (2 t) + (fi (do if @42)) (42 t) + (fi (do if @rest)) (0 t) + (fi (do if @1 @rest)) (1 t) + (fi (do if @2 @rest)) (2 t) + (fi (do if @42 @rest)) (42 t) + (fi (do if @1 @3 @rest @2)) (3 t)) + +(mtest + [(do quote x) 3] :error + [(do quote @1) 3] :error + (do pop a) :error) + +(defun y (f) + [(op @1 @1) + (op f (op [@@1 @@1]))]) + +(defun fac (f) + (do if (zerop @1) + 1 + (* @1 [f (- @1 1)]))) + +(defun fac-y (n) + [(y (do do if (zerop @1) + 1 + (* @1 [@@1 (- @1 1)]))) n]) + +(defun fac-r (n) + [(do if (zerop @1) 1 (* @1 [@rec (pred @1)])) n]) + +(defun fac-r2 (n) + [(do if (zerop @1) 1 (* @1 @(rec (pred @1)))) n]) + +(mtest + [[y fac] 4] 24 + (fac-y 4) 24 + (fac-r 4) 24 + (fac-r2 4) 24) + +(mtest + (flow 1 (+ 2) [dup *] (let ((x @1)) x)) 9 + (flow #S(time year 2021) .year succ) 2022) + +(mtest + [[(do op list)] 2] :error + [[(do op list) 2]] (2) + [[(do op list @@1) 1] 2] (1 2) + [[(do op list @1)] 2] :error + [[(do op list @1) 1] 2] (2 1) + [[(do op list @@1 @1) 1] 2] (1 2)) + +(mtest + [[[[(do do do op list @1) 1] 2] 3] 4] (4 1 2 3) + [[[[(do do do op list @@1) 1] 2] 3] 4] (3 1 2 4) + [[[[(do do do op list @@@1) 1] 2] 3] 4] (2 1 3 4) + [[[[(do do do op list @@@@1) 1] 2] 3] 4] (1 2 3 4)) + +(mtest + [[[[(do do do op list) 1] 2] 3] 4] (1 2 3 4) + [[[[(do do do op list @1 @@1 @@@1 @@@@1) 1] 2] 3] 4] (4 3 2 1) + [[[[(do do do op list @@@@1 @@@1 @@1 @1) 1] 2] 3] 4] (1 2 3 4)) + +(test (flow (range 1000 9999) + (keep-if (opip digits (ap > (+ @2 @3) (+ @1 @4)))) + (partition-if (op neq 1 (- @2 @1))) + (find-max-key @1 : len)) + 80) + +(mtest + (flow 1 (+ 1) (let x) (+ 2) (let y) (+ 3) (list x y @1)) (2 4 7) + (flow 10 (+ 1) (let (x @1) (y (* x 2))) (+ x y)) 44 + (flow 10 (+ 1) (let ((x @1) (y (* @1 2))) (+ x y))) 33 + (flow 10 (+ 1) (let ((x @1) (y (* @1 2))))) nil) + +(mtest + (lflow 10 (- 1) (- 1)) 8 + (lflow 10 (op - 100) (+ 1)) 91) + +(mtest + (remove-if (opf orf (< 10) (> 5)) (range 0 20)) (5 6 7 8 9 10) + (remove-if (lopf orf (> 10) (< 5)) (range 0 20)) (5 6 7 8 9 10)) + +(test + (let ((x 0) (y 0)) + (list (flow x + (+ 2) + (tap inc y @1) + (* 4) + (tap inc y @1) + (+ 5) + (tap inc y @1)) + y)) + (13 23)) diff --git a/tests/012/parse.tl b/tests/012/parse.tl new file mode 100644 index 00000000..6d091b00 --- /dev/null +++ b/tests/012/parse.tl @@ -0,0 +1,66 @@ +(load "../common") + +(unless (< (sizeof wchar) 4) + (test (read `"@(str-buf #b'EDB081')"`) + "\xDCED\xDCB0\xDC81") + + (test (read `"@(str-buf #b'F3FF')"`) + "\xDCF3\xDCFF") + + (test (regex-parse (str-buf #b'EDB081')) + (compound "\xDCED\xDCB0\xDC81")) + + (test (regex-parse (str-buf #b'F3FF')) + (compound #\xDCF3 #\xDCFF))) + +(mtest + (read "0") 0 + (read "0x") 0x + (read "a") a + (read "abc") abc + (read "abc.def") abc.def + (read "(1 2 3)") (1 2 3) + (read "#;(1 2 3) 4") 4 + (read "#;(1 2 3) #; a.b 4") 4 + (read "0 ") 0 + (read "0x ") 0x + (read "a ") a + (read "abc ") abc + (read "abc.def ") abc.def + (read "(1 2 3) ") (1 2 3) + (read "#;(1 2 3) 4 ") 4 + (read "#;(1 2 3) #; a.b 4 ") 4 + (read "0,") :error + (read "0x,") :error + (read "a,") :error + (read "abc,") :error + (read "abc.def,") :error + (read "(1 2 3),") :error + (read "#;(1 2 3) 4,") :error + (read "#;(1 2 3) #; a.b 4,") :error) + +(mtest + (iread "0") 0 + (iread "0x") 0x + (iread "a") a + (iread "abc") abc + (iread "abc.def") abc + (iread "(1 2 3)") (1 2 3) + (iread "#;(1 2 3) 4") 4 + (iread "#;(1 2 3) #; a.b 4") .b + (iread "0 ") 0 + (iread "0x ") 0x + (iread "a ") a + (iread "abc ") abc + (iread "abc.def ") abc + (iread "(1 2 3) ") (1 2 3) + (iread "#;(1 2 3) 4 ") 4 + (iread "#;(1 2 3) #; a.b 4 ") .b + (iread "0,") 0 + (iread "0x,") 0x + (iread "a,") a + (iread "abc,") abc + (iread "abc.def,") abc + (iread "(1 2 3),") (1 2 3) + (iread "#;(1 2 3) 4,") 4 + (iread "#;(1 2 3) #; a.b 4,") .b) diff --git a/tests/012/quasi.expected b/tests/012/quasi.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/quasi.expected +++ /dev/null diff --git a/tests/012/quasi.tl b/tests/012/quasi.tl index 276d5395..1cb24578 100644 --- a/tests/012/quasi.tl +++ b/tests/012/quasi.tl @@ -36,3 +36,18 @@ (let ((s)) (mapcar (ret `<@{(push (inc @1) s) d}>`) (range 0 2)))) ("<1>" "<2-1>" "<3-2-1>")) + +(test + (symacrolet ((two 2)) + `@{two}abc`) + "2abc") + +(test + (macrolet ((two () 2)) + `@(two)abc`) + "2abc") + +(compile-only + (eval-only + (compile-file (base-name *load-path*) "temp.tlo") + (remove-path "temp.tlo"))) diff --git a/tests/012/quine.expected b/tests/012/quine.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/quine.expected +++ /dev/null diff --git a/tests/012/readprint.tl b/tests/012/readprint.tl new file mode 100644 index 00000000..4298a85b --- /dev/null +++ b/tests/012/readprint.tl @@ -0,0 +1,13 @@ +(load "../common") + +(mstest + '[ . a] "[. a]" + '[. a] "[. a]" + '[ . @a] "[. @a]" + '[. @a] "[. @a]" + '[] "[]" + '[. 3] "[. 3]" + '[3 . 4] "[3 . 4]" + '(dwim) "[]" + '(dwim . 3) "[. 3]" + '(dwim 3 . 4) "[3 . 4]") diff --git a/tests/012/seq.expected b/tests/012/seq.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/seq.expected +++ /dev/null diff --git a/tests/012/seq.tl b/tests/012/seq.tl index 9c3821d1..262c7739 100644 --- a/tests/012/seq.tl +++ b/tests/012/seq.tl @@ -13,7 +13,873 @@ (test (build (add 1) (add 2) (pend (get) (get))) (1 2 1 2 1 2)) (test (build (add 1) (add 2) (pend* (get) (get))) (1 2 1 2 1 2)) +(mtest + (build (add 1 2) (oust)) nil + (build (add 1 2) (oust '(3 4)) (add 5)) (3 4 5) + (build (add 1 2) (oust '(3 4) '(5)) (add 6)) (3 4 5 6)) + (set *print-circle* t) (stest (build (add 1) (add 2) (ncon (get))) "#1=(1 2 . #1#)") (stest (build (add 1) (add 2) (ncon* (get))) "#1=(1 2 . #1#)") + +(test (mapcar (lambda (. args) (list . args)) '#(1 2 3) '#(4 5 6)) + #((1 4) (2 5) (3 6))) + +(test [window-map 2 '(x x) list '(a b c d e f g)] + ((x x a b c) (x a b c d) (a b c d e) + (b c d e f) (c d e f g) (d e f g nil) + (e f g nil nil))) + +(test [window-map 2 '(x x y y) list '(a b c d e f g)] + ((x x a b c) (x a b c d) (a b c d e) + (b c d e f) (c d e f g) (d e f g y) + (e f g y y))) + +(test [window-map 2 nil list '(a b c d e f g)] + ((nil nil a b c) (nil a b c d) (a b c d e) + (b c d e f) (c d e f g) + (d e f g nil) (e f g nil nil))) + +(test [window-map 2 :wrap list '(a b c d e f g)] + ((f g a b c) (g a b c d) (a b c d e) (b c d e f) + (c d e f g) (d e f g a) (e f g a b))) + +(test [window-map 2 :reflect list '(a b c d e f g)] + ((b a a b c) (a a b c d) (a b c d e) (b c d e f) + (c d e f g) (d e f g g) (e f g g f))) + +(test [window-map 7 :wrap list '(a b c)] + ((c a b c a b c a b c a b c a b) + (a b c a b c a b c a b c a b c) + (b c a b c a b c a b c a b c a))) + +(test [window-map 7 :reflect list '(a b c)] + ((a c b a c b a a b c c b a c b) + (c b a c b a a b c c b a c b a) + (b a c b a a b c c b a c b a c))) + +(test [window-map 1 nil (lambda (x y z) + (if (and (eq x #\<) + (eq z #\>)) + (chr-toupper y) + y)) + "ab<c>de<f>g"] + "ab<C>de<F>g") + +(test [window-mappend 1 :reflect (lambda (x y z) + (if (< x y z) + (list y))) + '(1 2 1 3 4 2 1 9 7 5 7 8 5)] + (3 7)) + +(test [window-map 2 #(0 0 0 0) + (lambda (. args) (/ (sum args) 5)) + #(4 7 9 13 5 1 6 11 10 3 8)] + #(4.0 6.6 7.6 7.0 6.8 7.2 6.6 6.2 7.6 6.4 4.2)) + +(mtest + [reduce-left + () 0] 0 + [reduce-left + ()] 0 + [reduce-left cons ()] :error + [reduce-left cons '(1)] 1 + [reduce-left cons #(1)] 1 + [reduce-left cons #(1) : (op * 10)] 10 + [reduce-left cons #(1) 2 (op * 10)] (2 . 10) + [reduce-left cons #(2 3) 10 (op * 10)] ((10 . 20) . 30)) + +(mtest + (starts-with "" "") t + (starts-with "" "a") t + (starts-with "a" "") nil + (starts-with "a" "a") t + (starts-with "" "abc") t + (starts-with "abc" "") nil + (starts-with "abc" "abc") t + (starts-with "ab" "abc") t + (starts-with "bc" "abc") nil + ) + +(mtest + (ends-with "" "") t + (ends-with "" "a") t + (ends-with "a" "") nil + (ends-with "a" "a") t + (ends-with "" "abc") t + (ends-with "abc" "") nil + (ends-with "abc" "abc") t + (ends-with "ab" "abc") nil + (ends-with "bc" "abc") t) + +(mtest + (rmismatch #() #()) nil + (rmismatch #(1) #()) -1 + (rmismatch #() #(1)) -1 + (rmismatch #(1) #(1)) nil + (rmismatch #(1 2) #(1 2)) nil + (rmismatch #(2 2) #(1 2)) -2 + (rmismatch #(1 2) #(2 2)) -2 + (rmismatch #(3 2 1) #(1 1)) -2 + (rmismatch #(1 1) #(3 2 1)) -2 + (rmismatch #(3 2 1) #(2 1)) -3 + (rmismatch #(2 1) #(3 2 1)) -3) + +(mtest + (rmismatch '() '()) nil + (rmismatch '(1) '()) -1 + (rmismatch '() '(1)) -1 + (rmismatch '(1) '(1)) nil + (rmismatch '(1 2) '(1 2)) nil + (rmismatch '(2 2) '(1 2)) -2 + (rmismatch '(1 2) '(2 2)) -2 + (rmismatch '(3 2 1) '(1 1)) -2 + (rmismatch '(1 1) '(3 2 1)) -2 + (rmismatch '(3 2 1) '(2 1)) -3 + (rmismatch '(2 1) '(3 2 1)) -3) + +(mtest + (rmismatch '() #()) nil + (rmismatch '(1) #()) -1 + (rmismatch '() #(1)) -1 + (rmismatch '(1) #(1)) nil + (rmismatch '(1 2) #(1 2)) nil + (rmismatch '(2 2) #(1 2)) -2 + (rmismatch '(1 2) #(2 2)) -2 + (rmismatch '(3 2 1) #(1 1)) -2 + (rmismatch '(1 1) #(3 2 1)) -2 + (rmismatch '(3 2 1) #(2 1)) -3 + (rmismatch '(2 1) #(3 2 1)) -3) + +(mtest + (rmismatch #() '()) nil + (rmismatch #(1) '()) -1 + (rmismatch #() '(1)) -1 + (rmismatch #(1) '(1)) nil + (rmismatch #(1 2) '(1 2)) nil + (rmismatch #(2 2) '(1 2)) -2 + (rmismatch #(1 2) '(2 2)) -2 + (rmismatch #(3 2 1) '(1 1)) -2 + (rmismatch #(1 1) '(3 2 1)) -2 + (rmismatch #(3 2 1) '(2 1)) -3 + (rmismatch #(2 1) '(3 2 1)) -3) + +(mtest + (rmismatch "" "") nil + (rmismatch "1" "") -1 + (rmismatch "" "1") -1 + (rmismatch "1" "1") nil + (rmismatch "12" "12") nil + (rmismatch "22" "12") -2 + (rmismatch "12" "22") -2 + (rmismatch "321" "11") -2 + (rmismatch "11" "321") -2 + (rmismatch "321" "21") -3 + (rmismatch "21" "321") -3) + +(mtest + [keep-if oddp (range 1 10)] (1 3 5 7 9) + [keep-if oddp nil] nil + [keep-if oddp #()] #() + [keep-if oddp #(1)] #(1) + [keep-if oddp #(2)] #() + [keep-if chr-isalpha "a1b2c3d"] "abcd" + [keep-if chr-isalpha ""] "" + [keep-if chr-isalpha "abc"] "abc" + [keep-if chr-isalpha "1234"] "") + +(mtest + [remove-if oddp (range 1 10)] (2 4 6 8 10) + [remove-if oddp nil] nil + [remove-if oddp #()] #() + [remove-if oddp #(1)] #() + [remove-if oddp #(2)] #(2) + [remove-if chr-isalpha "a1b2c3d"] "123" + [remove-if chr-isalpha ""] "" + [remove-if chr-isalpha "1234"] "1234" + [remove-if chr-isalpha "abcd"] "") + +(mtest + [keep-if* chr-isalpha ""] nil + [keep-if* chr-isalpha "abcd"] (#\a #\b #\c #\d) + (take 3 [keep-if* oddp (range 1)]) (1 3 5)) + +(mtest + [remove-if* chr-isalpha ""] nil + [remove-if* chr-isalpha "abcd"] nil + [remove-if* chr-isdigit "a1b2c3d4"] (#\a #\b #\c #\d) + (take 3 [remove-if* oddp (range 1)]) (2 4 6)) + +(mtest + [separate oddp (range 1 10)] ((1 3 5 7 9) (2 4 6 8 10)) + [separate integerp (range 1 10)] ((1 2 3 4 5 6 7 8 9 10) ()) + [separate chrp (range 1 10)] (() (1 2 3 4 5 6 7 8 9 10)) + [separate oddp (vec-list (range 1 10))] (#(1 3 5 7 9) #(2 4 6 8 10)) + [separate chr-isalpha "a1b2c3d4"] ("abcd" "1234") + [separate chrp "a1b2c3d4"] ("a1b2c3d4" "") + [separate integerp "a1b2c3d4"] ("" "a1b2c3d4")) + +(mtest + (tuples 0 nil) :error + (tuples 3.5 '(1 2 3)) :error + (tuples -1 "abc") :error) + +(mtest + (tuples 1 nil) nil + (tuples 1 "") nil + (tuples 1 #()) nil) + +(mtest + (tuples 1 '(a)) ((a)) + (tuples 1 "a") ("a") + (tuples 1 #(1)) (#(1))) + +(mtest + (tuples 1 '(a b c)) ((a) (b) (c)) + (tuples 1 "abc") ("a" "b" "c") + (tuples 1 #(1 2 3)) (#(1) #(2) #(3))) + +(mtest + (tuples 1 '(a b c) 'd) ((a) (b) (c)) + (tuples 1 "abc" #\d) ("a" "b" "c") + (tuples 1 #(1 2 3) 4) (#(1) #(2) #(3))) + +(mtest + (tuples 2 '(a b c)) ((a b) (c)) + (tuples 2 "abc") ("ab" "c") + (tuples 2 #(1 2 3)) (#(1 2) #(3))) + +(mtest + (tuples 3 '(a b c)) ((a b c)) + (tuples 3 "abc") ("abc") + (tuples 3 #(1 2 3)) (#(1 2 3))) + +(mtest + (tuples 2 '(a b c) 'd) ((a b) (c d)) + (tuples 2 "abc" #\d) ("ab" "cd") + (tuples 2 #(1 2 3) 4) (#(1 2) #(3 4))) + +(defun lforce (list) + [mapdo identity list] + list) + +(test + (lforce (tuples 2 "abc" 3)) ("ab" (#\c 3))) + +(test + (take 3 (tuples 3 (range 0))) ((0 1 2) (3 4 5) (6 7 8))) + +(mtest + (tuples* 0 nil) :error + (tuples* 3.5 '(1 2 3)) :error + (tuples* -1 "abc") :error) + +(mtest + (tuples* 1 nil) nil + (tuples* 1 "") nil + (tuples* 1 #()) nil) + +(mtest + (tuples* 1 '(a)) ((a)) + (tuples* 1 "a") ("a") + (tuples* 1 #(1)) (#(1))) + +(mtest + (tuples* 1 '(a b c)) ((a) (b) (c)) + (tuples* 1 "abc") ("a" "b" "c") + (tuples* 1 #(1 2 3)) (#(1) #(2) #(3))) + +(mtest + (tuples* 1 '(a b c) 'd) ((a) (b) (c)) + (tuples* 1 "abc" #\d) ("a" "b" "c") + (tuples* 1 #(1 2 3) 4) (#(1) #(2) #(3))) + +(mtest + (tuples* 2 '(a b c)) ((a b) (b c)) + (tuples* 2 "abc") ("ab" "bc") + (tuples* 2 #(1 2 3)) (#(1 2) #(2 3))) + +(mtest + (tuples* 3 '(a b c)) ((a b c)) + (tuples* 3 "abc") ("abc") + (tuples* 3 #(1 2 3)) (#(1 2 3))) + +(mtest + (tuples* 3 '(a b) 'c) ((a b c)) + (tuples* 3 "a" #\c) ("acc") + (tuples* 3 #() 1) (#(1 1 1))) + +(test + (lforce (tuples* 3 "a" 1)) :error) + +(mtest + (take 3 (tuples* 3 (range 0))) ((0 1 2) (1 2 3) (2 3 4)) + (take 3 (tuples* 3 0)) ((0 1 2) (1 2 3) (2 3 4))) + +(mtest + (nrot nil) nil + (nrot (vec)) #() + (nrot "") "" + (nrot nil 2) nil + (nrot (vec) 2) #() + (nrot "" 2) "" + (nrot nil -1) nil + (nrot (vec) -1) #() + (nrot "" -1) "") + +(mtest + (let ((s '(a))) (nrot s)) (a) + (let ((s (vec 1))) (nrot s) s) #(1) + (let ((s "x")) (nrot s) s) "x" + (let ((s '(a))) (nrot s -1)) (a) + (let ((s (vec 1))) (nrot s -1) s) #(1) + (let ((s "x")) (nrot s -1) s) "x") + +(mtest + (let ((s '(a b))) (nrot s)) (b a) + (let ((s (vec 1 2))) (nrot s) s) #(2 1) + (let ((s (copy "xy"))) (nrot s) s) "yx" + (let ((s '(a b))) (nrot s -1)) (b a) + (let ((s (vec 1 2))) (nrot s -1) s) #(2 1) + (let ((s (copy "xy"))) (nrot s -1) s) "yx") + +(mtest + (let ((s '(a b c))) (nrot s)) (b c a) + (let ((s (vec 1 2 3))) (nrot s) s) #(2 3 1) + (let ((s (copy "xyz"))) (nrot s) s) "yzx" + (let ((s '(a b c))) (nrot s -1)) (c a b) + (let ((s (vec 1 2 3))) (nrot s -1) s) #(3 1 2) + (let ((s (copy "xyz"))) (nrot s -1) s) "zxy") + +(mtest + (let ((s (list 'a 'b 'c))) (nrot s 33)) (a b c) + (let ((s (list 'a 'b 'c))) (nrot s 34)) (b c a)) + +(mtest + (rot nil) nil + (rot #()) #() + (rot "") "" + (rot nil 2) nil + (rot #() 2) #() + (rot "" 2) "" + (rot nil -1) nil + (rot #() -1) #() + (rot "" -1) "") + +(mtest + (let ((s '(a))) (list (rot s) s)) ((a) (a)) + (let ((s #(1))) (list (rot s) s)) (#(1) #(1)) + (let ((s "x")) (list (rot s) s)) ("x" "x") + (let ((s '(a))) (list (rot s -1) s)) ((a) (a)) + (let ((s #(1))) (list (rot s -1) s)) (#(1) #(1)) + (let ((s "x")) (list (rot s -1) s)) ("x" "x")) + +(mtest + (let ((s '(a b))) (list (rot s) s)) ((b a) (a b)) + (let ((s #(1 2))) (list (rot s) s)) (#(2 1) #(1 2)) + (let ((s "xy")) (list (rot s) s)) ("yx" "xy") + (let ((s '(a b))) (list (rot s -1) s)) ((b a) (a b)) + (let ((s #(1 2))) (list (rot s -1) s)) (#(2 1) #(1 2)) + (let ((s "xy")) (list (rot s -1) s)) ("yx" "xy")) + +(mtest + (let ((s '(a b c))) (list (rot s) s)) ((b c a) (a b c)) + (let ((s #(1 2 3))) (list (rot s) s)) (#(2 3 1) #(1 2 3)) + (let ((s "xyz")) (list (rot s) s)) ("yzx" "xyz") + (let ((s '(a b c))) (list (rot s -1) s)) ((c a b) (a b c)) + (let ((s #(1 2 3))) (list (rot s -1) s)) (#(3 1 2) #(1 2 3)) + (let ((s "xyz")) (list (rot s -1) s)) ("zxy" "xyz")) + +(mtest + (let ((s '(a b c))) (list (rot s 33) s)) ((a b c) (a b c)) + (let ((s '(a b c))) (list (rot s 34) s)) ((b c a) (a b c))) + +(mtest + (subq #\a #\b "") "" + (subq #\a #\b "a") "b" + (subq #\a #\b "aaa") "bbb" + (subq #\a #\b "abc") "bbc") + +(mtest + (subql #\a #\b "") "" + (subql #\a #\b "a") "b" + (subql #\a #\b "aaa") "bbb" + (subql #\a #\b "abc") "bbc") + +(mtest + (subqual #\a #\b "") "" + (subqual #\a #\b "a") "b" + (subqual #\a #\b "aaa") "bbb" + (subqual #\a #\b "abc") "bbc") + +(mtest + (subq 0 1 nil) nil + (subq 0 1 '(0)) (1) + (subq 0 1 '(0 0 0)) (1 1 1) + (subq 0 1 '(0 1 2)) (1 1 2)) + +(mtest + (subql 0 1 nil) nil + (subql 0 1 '(0)) (1) + (subql 0 1 '(0 0 0)) (1 1 1) + (subql 0 1 '(0 1 2)) (1 1 2)) + +(mtest + (subqual 0 1 nil) nil + (subqual 0 1 '(0)) (1) + (subqual 0 1 '(0 0 0)) (1 1 1) + (subqual 0 1 '(0 1 2)) (1 1 2)) + +(mtest + (subqual "foo" "bar" nil) nil + (subqual "foo" "bar" '#"foo") #"bar" + (subqual "foo" "bar" '#"foo foo foo") #"bar bar bar" + (subqual "foo" "bar" '#"xyzzy foo quuz") #"xyzzy bar quuz") + +(mtest + (subqual "brown" "black" #("how" "now" "brown" "cow")) #("how" "now" "black" "cow") + (subst "brown" "black" #("how" "now" "brown" "cow")) #("how" "now" "black" "cow")) + +(mtest + [subst "brown" "black" #("how" "now" "BROWN" "cow") : downcase-str] #("how" "now" "black" "cow") + [subst 5 0 '(1 2 3 4 5 6 7 8 9 10) <] (1 2 3 4 5 0 0 0 0 0)) + +(mtest + (pairlis nil nil) nil + (pairlis "abc" #(1 2 3 4)) ((#\a . 1) (#\b . 2) (#\c . 3)) + (pairlis "abcd" #(1 2 3)) ((#\a . 1) (#\b . 2) (#\c . 3)) + (pairlis "" #(1 2 3)) nil + (pairlis "abcd" #()) nil + (pairlis '(1 2 3) '(a b c) '(4 5 6)) ((1 . a) (2 . b) (3 . c) 4 5 6)) + +(mtest + (find-max nil) nil + [find-max '("alpha" "charlie" "aardvark" "bravo") less] "aardvark" + [find-max '("alpha" "charlie" "aardvark" "bravo") less reverse] "alpha" + [find-max '("alpha" "charlie" "aardvark" "bravo") : reverse] "bravo" + (find-max 1..10) 9 + [find-max #H(() (a 1) (b 2) (c 3)) : cdr] (c . 3)) + +(mtest + (find-max-key nil) nil + [find-max-key '("alpha" "charlie" "aardvark" "bravo") less upcase-str] "AARDVARK" + [find-max-key #H(() (a 1) (b 2) (c 3)) : cdr] 3) + +(defvarl fn (do and + (chr-isdigit @1) + (not (chr-isdigit @2)))) + +(mtest + [partition-if tf nil] nil + [partition-if tf "abc"] ("a" "b" "c") + [partition-if nilf "abc"] ("abc") + [partition-if neql "aaaabbcdee"] ("aaaa" "bb" "c" "d" "ee") + (partition-if fn "a13cd9foo42z") ("a13" "cd9" "foo42" "z")) + +(mtest + (partition-if (op /= (- @2 @1) 1) + '(1 3 4 5 7 8 9 10 9 8 6 5 3 2)) + ((1) (3 4 5) (7 8 9 10) (9) (8) (6) (5) (3) (2)) + (partition-if (op > (abs (- @2 @1)) 1) + '(1 3 4 5 7 8 9 10 9 8 6 5 3 2)) + ((1) (3 4 5) (7 8 9 10 9 8) (6 5) (3 2))) + +(mtest + [partition-if neql "aaaabbcdee" 2] ("aaaa" "bb" "cdee") + [partition-if neql "aaaabbcdee" 1] ("aaaa" "bbcdee") + [partition-if fn "a13cd9foo42z" 2] ("a13" "cd9" "foo42z") + [partition-if fn "a13cd9foo42z" 1] ("a13" "cd9foo42z") + [partition-if fn "a13cd9foo42z" 0] ("a13cd9foo42z")) + +(mtest + [count 1 nil] 0 + [count 1 '(1 2 3 4 1 5)] 2 + [count "abc" '("foo" "bar" "ABC" "abc" "def" "abc")] 2 + [count "ABC" '("foo" "bar" "ABC" "abc" "def" "abc") : upcase-str] 3) + +(compile-only + (test + [count #1="abc" '("abc" "abc" "abc" #1# "abc" #1#" abc") eq] 2)) + +(mtest + (search "" "") 0 + (search "abcde" "ab") 0 + (search "abcde" "bc") 1 + (search "abcde" "cd") 2 + (search "abcde" "de") 3 + (search "abcde" "e") 4 + (search "abcde" "") 0 + (search "abcde" "x") nil) + +(mtest + (search nil nil) 0 + (search '#"a b c d e" '#"a b") 0 + (search '#"a b c d e" '#"b c") 1 + (search '#"a b c d e" '#"c d") 2 + (search '#"a b c d e" '#"d e") 3 + (search '#"a b c d e" '#"e") 4 + (search '#"a b c d e" nil) 0 + (search '#"a b c d e" '#"x") nil) + +(mtest + (rsearch nil nil) 0 + (rsearch "abcde" "ab") 0 + (rsearch "abcde" "bc") 1 + (rsearch "abcde" "cd") 2 + (rsearch "abcde" "de") 3 + (rsearch "abcde" "e") 4 + (rsearch "abcde" "") 5 + (rsearch "abcde" "x") nil) + +(mtest + (rsearch '#"a b c d e" '#"a b") 0 + (rsearch '#"a b c d e" '#"b c") 1 + (rsearch '#"a b c d e" '#"c d") 2 + (rsearch '#"a b c d e" '#"d e") 3 + (rsearch '#"a b c d e" '#"e") 4 + (rsearch '#"a b c d e" nil) 5 + (rsearch '#"a b c d e" '#"x") nil) + +(mtest + (search-all "" "") (0) + (search-all "xxxxx" "y") nil + (search-all "xxxxx" "x") (0 1 2 3 4) + (search-all "xxx" "") (0 1 2 3)) + +(mtest + (search-all nil nil) (0) + (search-all '#"x x x x x" '#"y") nil + (search-all '#"x x x x x" '#"x") (0 1 2 3 4) + (search-all '#"x x x" "") (0 1 2 3)) + +(mtest + [keep-keys-if evenp (range 1 20) square] (4 16 36 64 100 144 196 256 324 400) + [keep-keys-if chr-isupper "foo bar" chr-toupper] "FOOBAR" + [keep-keys-if evenp (vec-list (range 1 20)) square] #(4 16 36 64 100 144 196 256 324 400)) + + +(mtest + [separate-keys evenp (range 1 20) square] ((4 16 36 64 100 144 196 256 324 400) + (1 9 25 49 81 121 169 225 289 361)) + [separate-keys chr-isupper "foo bar" chr-toupper] ("FOOBAR" " ") + [separate-keys evenp (vec-list (range 1 20)) square] (#(4 16 36 64 100 144 196 256 324 400) + #(1 9 25 49 81 121 169 225 289 361))) + +(mtest + (flatten '()) () + (flatten '(nil)) () + (flatten '(a)) (a) + (flatten '(a b)) (a b) + (flatten '(nil b)) (b) + (flatten '(a nil)) (a) + + (flatten '((nil))) () + (flatten '((a))) (a) + (flatten '((a) (b))) (a b) + (flatten '((nil) (b))) (b) + (flatten '((a) (nil))) (a) + + (flatten '((a b))) (a b) + (flatten '((nil b))) (b) + (flatten '((a nil))) (a) + + (flatten '(((())))) nil + (flatten '(((())) a)) (a) + (flatten '(((()) a))) (a) + (flatten '(((() a)))) (a) + (flatten '((((a))))) (a) + + (flatten 3) (3) + (flatten '(1 . 2)) :error + (flatten '(1 2 . 3)) :error + (flatten '(1 (2 . 3))) :error) + +(mtest + (flatten* '()) () + (flatten* '(nil)) () + (flatten* '(a)) (a) + (flatten* '(a b)) (a b) + (flatten* '(nil b)) (b) + (flatten* '(a nil)) (a) + + (flatten* '((nil))) () + (flatten* '((a))) (a) + (flatten* '((a) (b))) (a b) + (flatten* '((nil) (b))) (b) + (flatten* '((a) (nil))) (a) + + (flatten* '((a b))) (a b) + (flatten* '((nil b))) (b) + (flatten* '((a nil))) (a) + + (flatten* '(((())))) nil + (flatten* '(((())) a)) (a) + (flatten* '(((()) a))) (a) + (flatten* '(((() a)))) (a) + (flatten* '((((a))))) (a) + + (flatten* 3) (3) + (lforce (flatten* '(1 . 2))) :error + (lforce (flatten* '(1 2 . 3))) :error + (lforce (flatten* '(1 (2 . 3)))) :error) + +(mtest + (flatcar ()) (nil) + (flatcar 'a) (a) + (flatcar '(a . b)) (a b) + (flatcar '(nil . nil)) (nil) + (flatcar '(nil . b)) (nil b) + (flatcar '(b . nil)) (b) + (flatcar '(a b . c)) (a b c) + (flatcar '(() b . c)) (nil b c) + (flatcar '((()) b . c)) (nil b c) + (flatcar '(((a)) b . c)) (a b c)) + +(mtest + (flatcar* ()) (nil) + (flatcar* 'a) (a) + (flatcar* '(a . b)) (a b) + (flatcar* '(nil . nil)) (nil) + (flatcar* '(nil . b)) (nil b) + (flatcar* '(b . nil)) (b) + (flatcar* '(a b . c)) (a b c) + (flatcar* '(() b . c)) (nil b c) + (flatcar* '((()) b . c)) (nil b c) + (flatcar* '(((a)) b . c)) (a b c)) + +(mtest + (length-< nil 0) nil + (length-< nil 1) t + (length-< '(a) 1) nil + (length-< '(a) 2) t + (length-< '(a . b) 1) nil + (length-< '(a . b) 2) t) + +(mtest + (length-< "" 0) nil + (length-< "" 1) t + (length-< "a" 1) nil + (length-< "a" 2) t) + +(mtest + (length-< #() 0) nil + (length-< #() 1) t + (length-< #(a) 1) nil + (length-< #(a) 2) t) + +(let ((l (list 1 2 3 4))) + (del (ref l 1)) + (test l (1 3 4)) + (del (second l)) + (test l (1 4))) + +(let ((nl (list (list (list 1 2) + (list 3 4) + (list 5 6)) + (list (list 7 8) + (list 9 10) + (list 11 12))))) + (mtest + (mref nl 0 0 0) 1 + (mref nl 0 0 1) 2 + (mref nl 0 1 0) 3 + (mref nl 0 1 1) 4 + (mref nl 0 2 0) 5 + (mref nl 0 2 1) 6 + (mref nl 1 0 0) 7 + (mref nl 1 0 1) 8 + (mref nl 1 1 0) 9 + (mref nl 1 1 1) 10 + (mref nl 1 2 0) 11 + (mref nl 0 2 1) 6) + + (mtest + (set (mref nl 0 0 0) 101) 101 + (mref nl 0 0 0) 101 + + (del (mref nl 0 0 0..:)) (101 2) + nl ((nil (3 4) (5 6)) ((7 8) (9 10) (11 12))) + + (set (mref nl 1 0..2) '(4)) (4) + nl ((nil (3 4) (5 6)) (4 (11 12))) + + (del (mref nl 1)) (4 (11 12)) + nl ((nil (3 4) (5 6))) + + (set (mref nl 1..:) '(a b c)) (a b c) + nl ((nil (3 4) (5 6)) a b c) + + (set (mref nl 1..3) '(e f)) (e f) + nl ((nil (3 4) (5 6)) e f c))) + +(flet ((get-vec () (vec 1 2 3)) + (get-list () (list 1 2 3))) + (mtest + (inc (mref (get-vec) 0)) 2 + (set (mref (get-vec) 0) 10) 10 + (inc (mref (get-list) 0)) 2 + (set (mref (get-list) 0) 10) 10 + (push 3 (mref (get-vec) 1..2)) (3 . #(2)) + (set (mref (get-vec) 1..2) '(30)) (30) + (push 3 (mref (get-list) 1..2)) :error + (set (mref (get-list) 1..2) '(30)) :error)) + + +(let ((nv (nested-vec 4 4 4))) + (let ((x 0)) + (each-prod ((i 0..4) + (j 0..4) + (k 0..4)) + (vtest (set (mref nv i j k) (inc x)) (succ x)))) + (mtest + nv #(#(#( 1 2 3 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16)) + #(#(17 18 19 20) #(21 22 23 24) #(25 26 27 28) #(29 30 31 32)) + #(#(33 34 35 36) #(37 38 39 40) #(41 42 43 44) #(45 46 47 48)) + #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64))) + (set (mref nv 0 0 1..3) #(20 30)) #(20 30) + nv #(#(#( 1 20 30 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16)) + #(#(17 18 19 20) #(21 22 23 24) #(25 26 27 28) #(29 30 31 32)) + #(#(33 34 35 36) #(37 38 39 40) #(41 42 43 44) #(45 46 47 48)) + #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64))) + (set (mref nv 1 1..3) "AB") "AB" + nv #(#(#( 1 20 30 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16)) + #(#(17 18 19 20) #\A #\B #(29 30 31 32)) + #(#(33 34 35 36) #(37 38 39 40) #(41 42 43 44) #(45 46 47 48)) + #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64))) + (set (mref nv 1..3) '(B C)) (B C) + nv #(#(#( 1 20 30 4) #( 5 6 7 8) #( 9 10 11 12) #(13 14 15 16)) + B + C + #(#(49 50 51 52) #(53 54 55 56) #(57 58 59 60) #(61 62 63 64))))) + +(let ((cf (lambda (x) + (lambda (y) + (lambda (z) + (+ x y z)))))) + (test [mref cf 1 2 3] 6)) + +(test + (zip) nil) + +(mtest + (zip '()) nil + (zip #()) #() + (zip "") "" + (zip #b'') #b'') + +(mtest + (zip '(a)) ((a)) + (zip '(a b)) ((a) (b)) + (zip '(a b c)) ((a) (b) (c))) + +(mtest + (zip #(a)) #(#(a)) + (zip #(a b)) #(#(a) #(b)) + (zip #(a b c)) #(#(a) #(b) #(c))) + +(mtest + (zip "a") ("a") + (zip "ab") ("a" "b") + (zip "abc") ("a" "b" "c")) + +(mtest + (zip #b'aa') (#b'aa') + (zip #b'aabb') (#b'aa' #b'bb') + (zip #b'aabbcc') (#b'aa' #b'bb' #b'cc')) + +(mtest + (zip '(a) '(b)) ((a b)) + (zip '(a c) '(b d)) ((a b) (c d)) + (zip '(a c e) '(b d f)) ((a b) (c d) (e f)) + (zip '(a d) '(b e) '(c f)) ((a b c) (d e f))) + +(mtest + (zip #(a) #(b)) #(#(a b)) + (zip #(a c) #(b d)) #(#(a b) #(c d)) + (zip #(a c e) #(b d f)) #(#(a b) #(c d) #(e f)) + (zip #(a d) #(b e) #(c f)) #(#(a b c) #(d e f))) + +(mtest + (zip #(a) #(b)) #(#(a b)) + (zip #(a c) #(b d)) #(#(a b) #(c d)) + (zip #(a c e) #(b d f)) #(#(a b) #(c d) #(e f)) + (zip #(a d) #(b e) #(c f)) #(#(a b c) #(d e f))) + +(mtest + (zip "a" "b") ("ab") + (zip "ac" "bd") ("ab" "cd") + (zip "ace" "bdf") ("ab" "cd" "ef") + (zip "ad" "bef" "cf") ("abc" "def")) + +(mtest + (zip #b'aa' #b'bb') (#b'aabb') + (zip #b'aacc' #b'bbdd') (#b'aabb' #b'ccdd') + (zip #b'aaccee' #b'bbddff') (#b'aabb' #b'ccdd' #b'eeff') + (zip #b'aaddee' #b'bbeeff' #b'ccff') (#b'aabbcc' #b'ddeeff')) + +(test + (zip "ab" "ijklm" "xy") ("aix" "bjy")) + +(test + (zip "ab" '(#\i #\j) #("x" "y")) ("aix" "bjy")) + +(vtest + [apply mapcar join (list-seq "aaa".."zzz")] + (transpose (list-seq "aaa".."zzz"))) + +(eval-only (set *compile-opts*.constant-throws nil)) + +(mtest + (ref "a".."z" 0) :error + (ref (rcons 'foo 'bar) 0) :error) + +(mtest + (ref 1..6 0) 1 + (ref 1..6 1) 2 + (ref 1..6 4) 5 + (ref 1..6 5) :error + (ref 1..6 -1) 5 + (ref 1..6 -2) 4 + (ref 1..6 -5) 1 + (ref 1..6 -6) :error) + +(mtest + (ref 1..: 0) 1 + (ref 1..: 1) 2 + (ref 1..: 4) 5 + (ref 1..: -1) :error + (ref 1..: -2) :error) + +(mtest + (ref 1..t 0) 1 + (ref 1..t 1) 2 + (ref 1..t 4) 5 + (ref 1..t -1) :error + (ref 1..: -2) :error) + +(mtest + (ref #\a..#\f 0) #\a + (ref #\a..#\f 1) #\b + (ref #\a..#\f 4) #\e + (ref #\a..#\f 5) :error + (ref #\a..#\f -1) #\e + (ref #\a..#\f -2) #\d + (ref #\a..#\f -5) #\a + (ref #\a..#\f -6) :error) + +(mtest + (ref #\a..: 0) #\a + (ref #\a..: 1) #\b + (ref #\a..: 4) #\e + (ref #\a..: -1) :error + (ref #\a..: -2) :error) + +(mtest + (ref #\a..t 0) #\a + (ref #\a..t 1) #\b + (ref #\a..t 4) #\e + (ref #\a..t -1) :error + (ref #\a..: -2) :error) + + +(mtest + (ref 1..6 0.0) (1.0 2.0 3.0 4.0 5.0)) diff --git a/tests/012/sort.tl b/tests/012/sort.tl new file mode 100644 index 00000000..bca4a3d8 --- /dev/null +++ b/tests/012/sort.tl @@ -0,0 +1,98 @@ +(load "../common") + +(test (sort ()) nil) + +(let* ((list (conses '(1 2 3 4 5 6 7 8))) + (sp (uniq [mapcar sort (perm list (len list))]))) + (mvtest (len sp) 1 + (car sp) list)) + +(test (sort #()) #()) + +(let* ((vec (conses #(1 2 3 4 5 6 7 8))) + (sp (uniq [mapcar sort (perm vec (len vec))]))) + (mvtest (len sp) 1 + (car sp) vec)) + +(let* ((list (range* 0 1000)) + (slist (shuffle list)) + (vec (vec-list list)) + (svec (vec-list slist))) + (mvtest + (sort list) list + (sort slist) list + (sort list (fun greater)) (reverse list) + (sort slist (fun greater)) (reverse list)) + (mvtest + (sort vec) vec + (sort svec) vec + (sort vec (fun greater)) (reverse vec) + (sort svec (fun greater)) (reverse vec)) + (mvtest + (csort list) list + (csort slist) list + (csort list (fun greater)) (reverse list) + (csort slist (fun greater)) (reverse list)) + (mvtest + (csort vec) vec + (csort svec) vec + (csort vec (fun greater)) (reverse vec) + (csort svec (fun greater)) (reverse vec))) + + +(test (ssort ()) nil) + +(let* ((list (conses '(1 2 3 4 5 6 7 8))) + (sp (uniq [mapcar ssort (perm list (len list))]))) + (mvtest (len sp) 1 + (car sp) list)) + +(test (ssort #()) #()) + +(let* ((vec (conses #(1 2 3 4 5 6 7 8))) + (sp (uniq [mapcar ssort (perm vec (len vec))]))) + (mvtest (len sp) 1 + (car sp) vec)) + +(let* ((list (range* 0 1000)) + (slist (shuffle list)) + (vec (vec-list list)) + (svec (vec-list slist))) + (mvtest + (ssort list) list + (ssort slist) list + (ssort list (fun greater)) (reverse list) + (ssort slist (fun greater)) (reverse list)) + (mvtest + (ssort vec) vec + (ssort svec) vec + (ssort vec (fun greater)) (reverse vec) + (ssort svec (fun greater)) (reverse vec)) + (mvtest + (cssort list) list + (cssort slist) list + (cssort list (fun greater)) (reverse list) + (cssort slist (fun greater)) (reverse list)) + (mvtest + (cssort vec) vec + (cssort svec) vec + (cssort vec (fun greater)) (reverse vec) + (cssort svec (fun greater)) (reverse vec))) + +(mtest + [sort-group '((a 1) (b 1) (a 2) (b 2) (a 3) (c 2) (c 1) (a 4)) car] + (((a 1) (a 2) (a 3) (a 4)) + ((b 1) (b 2)) + ((c 2) (c 1))) + [csort-group '((a 1) (b 1) (a 2) (b 2) (a 3) (c 2) (c 1) (a 4)) car] + (((a 1) (a 2) (a 3) (a 4)) + ((b 1) (b 2)) + ((c 2) (c 1)))) + +(mtest + (hist-sort nil) nil + (hist-sort '(3 4 5)) ((3 . 1) (4 . 1) (5 . 1)) + (hist-sort '("a" "b" "c" "a" "b" "a" "b" "a")) (("a" . 4) ("b" . 3) ("c" . 1))) + +(test + [hist-sort-by upcase-str '("a" "b" "c" "a" "b" "a" "b" "a")] (("A" . 4) ("B" . 3) ("C" . 1))) diff --git a/tests/012/stack.tl b/tests/012/stack.tl new file mode 100644 index 00000000..b3cea078 --- /dev/null +++ b/tests/012/stack.tl @@ -0,0 +1,50 @@ +(load "../common") + +(defvarl stack-limited (set-stack-limit 32768)) + +(defun recur () (recur)) + +(defmacro so (expr) + ^(catch ,expr + (stack-overflow (exc) :so))) + +(test (so (recur)) :so) + +(if (fboundp 'setrlimit) + (test (let ((pid (fork))) + (cond + ((zerop pid) + (set-stack-limit 0) + (let ((rlim (getrlimit rlimit-stack))) + (set rlim.cur 32768) + (setrlimit rlimit-stack rlim)) + (recur)) + (t (let ((status (wait pid))) + (w-ifsignaled status))))) + t)) + +(defmacro infexp () + ^(foo (infexp))) + +(test (so (expand '(infexp))) :so) + +(defvarl orig (get-stack-limit)) + +(mvtest + (set-stack-limit nil) orig + (set-stack-limit orig) nil + (set-stack-limit 0) orig + (set-stack-limit orig) nil + (set-stack-limit 65536) orig + (set-stack-limit orig) 65536) + +(set-sig-handler sig-segv + (lambda (signal async-p) + (assert (null (get-stack-limit))) + (throw 'out))) + +(test + (catch + (raise sig-segv) + (out () :sig)) + :sig) diff --git a/tests/012/stack2.expected b/tests/012/stack2.expected new file mode 100644 index 00000000..cad99e12 --- /dev/null +++ b/tests/012/stack2.expected @@ -0,0 +1 @@ +caught diff --git a/tests/012/stack2.txr b/tests/012/stack2.txr new file mode 100644 index 00000000..3652a764 --- /dev/null +++ b/tests/012/stack2.txr @@ -0,0 +1,9 @@ +@(define recur ()) +@(recur) +@(end) +@(do (set-stack-limit 32768)) +@(try) +@(recur) +@(catch stack-overflow (arg)) +@(do (put-line "caught")) +@(end) diff --git a/tests/012/struct.expected b/tests/012/struct.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/struct.expected +++ /dev/null diff --git a/tests/012/struct.tl b/tests/012/struct.tl index 9de3f832..33431780 100644 --- a/tests/012/struct.tl +++ b/tests/012/struct.tl @@ -16,7 +16,7 @@ (test (expand '^#S(bar b ,(+ 2 2))) (sys:make-struct-lit 'bar (list 'b (+ 2 2)))) -(defvar s (eval ^#S(bar b ,(+ 2 2)))) +(defvarl s (eval ^#S(bar b ,(+ 2 2)))) (test (set (slot s 'a) 100) 100) @@ -28,32 +28,36 @@ (slot (slot (slot a 'b) 'c) 'd)) -(test (expand 's.a) +(defmacro get-current-menv (:env e) e) +(defvarl menv (let (s a b c d) (macro-time (get-current-menv)))) + +(test (expand 's.a menv) (slot s 'a)) -(test (expand 's.[a]) - [(slot s 'a)]) -(test (expand 's.[a b c]) - [(slot s 'a) b c]) +(test (expand 's.[a] menv) + [(slot s 'a) s]) +(test (expand 's.[a b c] menv) + [(slot s 'a) s b c]) (set *gensym-counter* 0) -(stest (ignwarn (expand 's.(a))) + +(stest (ignwarn (expand 's.(a) menv)) "(call (slot s 'a)\n \ \ s)") (set *gensym-counter* 0) -(stest (ignwarn (expand 's.(a b c))) +(stest (ignwarn (expand 's.(a b c) menv)) "(call (slot s 'a)\n \ \ s b c)") -(test (expand 's.[a].d) - (slot [(slot s 'a)] 'd)) -(test (expand 's.[a b c].d) - (slot [(slot s 'a) b c] 'd)) +(test (expand 's.[a].b menv) + (slot [(slot s 'a) s] 'b)) +(test (expand 's.[a b c].b menv) + (slot [(slot s 'a) s b c] 'b)) (set *gensym-counter* 0) -(stest (ignwarn (expand 's.(a).d)) +(stest (ignwarn (expand 's.(a).d menv)) "(slot (call (slot s 'a)\n \ \ s)\n \ \ 'd)") (set *gensym-counter* 0) -(stest (ignwarn (expand 's.(a b c).d)) +(stest (ignwarn (expand 's.(a b c).d menv)) "(slot (call (slot s 'a)\n \ \ s b c)\n \ \ 'd)") @@ -62,7 +66,7 @@ (test (new foo) #S(foo a 42)) -(set *gensym-counter* 0) +(set *gensym-counter* 4) (stest (expand '(defstruct (boa x y) nil (x 0) (y 0))) "(sys:make-struct-type 'boa '() '()\n \ @@ -104,7 +108,7 @@ (stest bz "#S(baz array #(1 2 3) increment #<interpreted fun: lambda (self which delta)>)") -(test bz.[array 2] 3) +(test [bz.array 2] 3) (test bz.(increment 0 42) 43) (test bz.array #(43 2 3)) (test [(meth bz increment) 1 5] 7) @@ -133,3 +137,11 @@ (test (equal #S(foo) #S(foo)) t) (test (equal #S(foo a 0) #S(foo a 1)) nil) (test (equal #S(bar a 3 b 3) #S(bar a 3 b 3)) t) + +(defstruct eqsub () + key + (:method equal (me) me.key)) + +(test (equal (new eqsub key '(1 2)) + (new eqsub key '(1 2))) + t) diff --git a/tests/012/stslot.expected b/tests/012/stslot.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/012/stslot.expected +++ /dev/null diff --git a/tests/012/syms.expected b/tests/012/syms.expected new file mode 100644 index 00000000..bfe9f694 --- /dev/null +++ b/tests/012/syms.expected @@ -0,0 +1,6 @@ +(loc-0 loc-1 loc-2 cons) +(loc-0 loc-1 loc-2 cons) +(fb-2:loc-0 fb-2:loc-1 loc-2 cons) +(loc-0 loc-1 loc-2 cons) +(fb-2:loc-0 fb-2:loc-1 loc-2 cons) +(fb-1:loc-0 loc-1 loc-2 cons) diff --git a/tests/012/syms.tl b/tests/012/syms.tl new file mode 100644 index 00000000..007125e2 --- /dev/null +++ b/tests/012/syms.tl @@ -0,0 +1,28 @@ +(load "../common") + +(defpackage fb-2 + (:local loc-0 loc-1 loc-2) + (:fallback usr)) + +(defpackage fb-1 + (:local loc-0 loc-1) + (:fallback fb-2 usr)) + +(defpackage main + (:local loc-0) + (:fallback fb-1 fb-2 usr)) + +(in-package fb-2) + +(prinl '(loc-0 loc-1 loc-2 cons)) + +(in-package fb-1) + +(prinl '(loc-0 loc-1 loc-2 cons)) +(prinl '(fb-2:loc-0 fb-2:loc-1 fb-2:loc-2 fb-2:cons)) + +(in-package main) + +(prinl '(loc-0 loc-1 loc-2 cons)) +(prinl '(fb-2:loc-0 fb-2:loc-1 fb-2:loc-2 fb-2:cons)) +(prinl '(fb-1:loc-0 fb-1:loc-1 fb-1:loc-2 fb-1:cons)) diff --git a/tests/012/syntax.tl b/tests/012/syntax.tl new file mode 100644 index 00000000..bc7d9668 --- /dev/null +++ b/tests/012/syntax.tl @@ -0,0 +1,74 @@ +(load "../common") + +"top level literal" + +".." + +"." + +#;(commented out list) +#;3.14 +#;abc +#;.foo +#; .foo +#;a.b + +'(#;.foo) +'(#; .foo) + +(test + #;(commented out list) + #;3.14 + #;abc + #;.foo + #; .foo + #;a.b + 42 42) + +(mtest + '(#;abc) nil + '(#; abc 1) (1) + '(0 #; abc 1) (0 1) + '(0 #; abc) (0)) + +(mtest + '(#; .abc) nil + '(#; .abc 1) (1) + '(0 #; .abc 1) (0 1) + '(0 #; .abc) (0)) + +(mtest + '(-,1) (- (sys:unquote 1)) + 1,2 12 + 1,,2 12 + 1,,,2 12 + 1,2,3 1,2,3 + -0,1 -1 + '(1,a) (1 (sys:unquote a))) + +(mtest + (read "#x,ff") :error + (read "#o,1") :error + (read "#b,1") :error + '(#xff,ff,z) (65535 (sys:unquote z)) + '(#xff,ff,a) (1048570)) + +(mtest + #xff,ff 65535 + #o7,7,7 511 + #b1101,1110 #xDE) + +(mtest + 1,234,567.890,123E13 1234567.890123E13 + '(1.234,e+12) (1.234 (sys:unquote e+12)) + '(1.,234) (1.0 (sys:unquote 234))) + +(mtest + (read "0..1") (rcons 0 1) + (read "0..1..2") (rcons 0 (rcons 1 2))) + +(mtest + (tostring '(rcons 0 1)) "0..1" + (tostring '(rcons 0 (rcons 1 2))) "0..1..2" + (tostring '(rcons (rcons 0 1) 2)) "(rcons 0..1 2)" + (tostring '(rcons (rcons 0 1) (rcons 2 3))) "(rcons 0..1 2..3)") diff --git a/tests/012/type.tl b/tests/012/type.tl new file mode 100644 index 00000000..97007b3c --- /dev/null +++ b/tests/012/type.tl @@ -0,0 +1,68 @@ +(load "../common") + +(mtest + (subtypep 'a 'a) t + (subtypep t t) t + (subtypep nil t) t + (subtypep t nil) nil + (subtypep nil nil) t + (subtypep 'null nil) nil + (subtypep nil 'null) t + (subtypep 'null t) t + (subtypep 'null 'a) nil + (subtypep 'a 'null) nil + (subtypep nil 'a) t + (subtypep 'a nil) nil + (subtypep 'a t) t) + +(mtest + (subtypep 'stream 'stdio-stream) nil + (subtypep 'stdio-stream 'stream) t) + +(defstruct xtime time) +(defstruct nottime nil) + +(mtest + (typep #S(time) 'time) t + (typep #S(time) (find-struct-type 'time)) t + (typep #S(xtime) 'time) t + (typep #S(xtime) (find-struct-type 'time)) t + (typep #S(nottime) 'time) nil + (typep #S(nottime) (find-struct-type 'time)) nil) + +(mtest + (subtypep (find-struct-type 'time) (find-struct-type 'time)) t + (subtypep (find-struct-type 'time) 'time) t + (subtypep 'time (find-struct-type 'time)) t) + +(mtest + (subtypep (find-struct-type 'xtime) (find-struct-type 'time)) t + (subtypep (find-struct-type 'xtime) 'time) t + (subtypep 'xtime (find-struct-type 'time)) t) + +(mtest + (subtypep (find-struct-type 'time) (find-struct-type 'xtime)) nil + (subtypep (find-struct-type 'time) 'xtime) nil + (subtypep 'time (find-struct-type 'xtime)) nil) + +(mtest + (subtypep 'time 'struct) t + (subtypep (find-struct-type 'time) 'struct) t + (subtypep 'hash 'struct) nil) + +(defstruct listlike nil + (:method car (me))) + +(defstruct veclike nil + (:method length (me))) + +(mtest + (subtypep 'listlike 'sequence) t + (subtypep (find-struct-type 'listlike) 'sequence) t + (subtypep 'veclike 'sequence) t + (subtypep (find-struct-type 'veclike) 'sequence) t + (subtypep 'time 'sequence) nil + (subtypep 'hash 'sequence) nil + (subtypep 'str 'sequence) t + (subtypep 'string 'sequence) t + (subtypep 'vec 'sequence) t) diff --git a/tests/012/typecase.tl b/tests/012/typecase.tl new file mode 100644 index 00000000..97b3da48 --- /dev/null +++ b/tests/012/typecase.tl @@ -0,0 +1,18 @@ +(load "../common") + +(mtest + (typecase) :error + (typecase nil) nil + (typecase nil a) :error + (typecase 0 (symbol 1)) nil + (typecase 0 (integer 1)) 1 + (typecase 0 (integer 1) (integer 2)) 1 + (typecase 0 (t 3) (integer 1)) 3) + +(mtest + (etypecase) :error + (etypecase nil) :error + (etypecase nil a) :error + (etypecase 0 (string 1)) :error + (etypecase 0 (string 1) (integer 2)) 2 + (etypecase 0 (string 1) (t 2)) 2) diff --git a/tests/012/use-as.tl b/tests/012/use-as.tl new file mode 100644 index 00000000..eb736d9d --- /dev/null +++ b/tests/012/use-as.tl @@ -0,0 +1,39 @@ +(load "../common") + +(defpackage lottery + (:local draw) + (:fallback usr)) + +(defpackage graphics + (:local draw) + (:fallback usr)) + +(defpackage gui-lottery + (:fallback lottery graphics usr pub) + (:use-syms-as lottery:draw ldraw + graphics:draw gdraw)) + +(in-package gui-lottery) + +(mtest + (package-name (symbol-package 'ldraw)) "lottery" + (package-name (symbol-package 'gdraw)) "graphics" + (symbol-name 'ldraw) "draw" + (symbol-name 'gdraw) "draw") + +(mtest + (tostring 'ldraw) "draw" + (tostring 'gdraw) "graphics:draw") + +(mtest + (use-sym-as 3 '#:foo) :error + (use-sym-as 'ldraw 3) :error + (use-sym-as 'x 'x) x) + +(mtest + (find-symbol "ldraw") lottery:draw + (find-symbol "gdraw") graphics:draw + (unuse-sym 'ldraw) lottery:draw + (unuse-sym 'gdraw) graphics:draw + (find-symbol "ldraw") nil + (find-symbol "gdraw") nil) diff --git a/tests/013/chksum.tl b/tests/013/chksum.tl new file mode 100644 index 00000000..6c9e7add --- /dev/null +++ b/tests/013/chksum.tl @@ -0,0 +1,40 @@ +(load "../common") + +(mtest + (crc32 "") 0 + (sha1 "") #b'da39a3ee 5e6b4b0d 3255bfef 95601890 afd80709' + (sha256 "") #b'e3b0c442 98fc1c14 9afbf4c8 996fb924 27ae41e4 649b934c a495991b 7852b855' + (md5 "") #b'd41d8cd9 8f00b204 e9800998 ecf8427e') + +(mtest + (crc32 "abc") #x352441c2 + (sha1 "abc") #b'a9993e36 4706816a ba3e2571 7850c26c 9cd0d89d' + (sha256 "abc") #b'ba7816bf 8f01cfea 414140de 5dae2223 b00361a3 96177a9c b410ff61 f20015ad' + (md5 "abc") #b'90015098 3cd24fb0 d6963f7d 28e17f72') + +(defvarl algs (list + [list sha1 sha1-begin sha1-hash sha1-end sha1-stream] + [list sha256 sha256-begin sha256-hash sha256-end sha256-stream] + [list md5 md5-begin md5-hash md5-end md5-stream])) + +(defvarl testbuf (make-buf 20000 #xAA)) + +(test + (crc32 testbuf) #xf35324f0) + +(each-match ((@hashfn @begfn @updatefn @endfn @streamfn) algs) + (let ((h0 [hashfn testbuf]) + (h1 (let ((ctx [begfn])) + (each ((piece (tuples 1 testbuf))) + [updatefn ctx piece]) + [endfn ctx])) + (h2 (let ((ctx [begfn])) + (each ((piece (tuples 100 testbuf))) + [updatefn ctx piece]) + [endfn ctx])) + (h3 (let ((s (make-buf-stream testbuf))) + [streamfn s]))) + (mtest + (equal h0 h1) t + (equal h0 h2) t + (equal h0 h3) t))) diff --git a/tests/013/maze.expected b/tests/013/maze.expected index b9c26ae0..8cf588e4 100644 --- a/tests/013/maze.expected +++ b/tests/013/maze.expected @@ -1,61 +1,61 @@ + +----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+ -| | | | | | | | | -| | | | | | | | | -+----+ + +----+ + + + + + +----+----+ + +----+----+ +----+ + + -| | | | | | | | | | | | | | -| | | | | | | | | | | | | | -+ +----+ +----+----+----+ +----+----+ + + + + + + + + +----+ + -| | | | | | | | | -| | | | | | | | | -+----+----+----+----+----+ +----+ +----+----+----+ +----+ + +----+----+----+ +----+ -| | | | | | | | | | -| | | | | | | | | | -+ + +----+----+----+----+ +----+----+ + +----+ + + +----+----+ +----+ + -| | | | | | | | | | | | | -| | | | | | | | | | | | | -+ + + + +----+ + + + + + + +----+----+ +----+ + +----+----+ -| | | | | | | | | | | | | -| | | | | | | | | | | | | -+----+----+ +----+ + + +----+----+----+ +----+----+ +----+ +----+----+ + + -| | | | | | | | | | -| | | | | | | | | | -+ +----+----+ +----+ +----+ +----+ +----+ +----+----+ + + +----+----+ + -| | | | | | | | | | | | | -| | | | | | | | | | | | | -+----+ + +----+ + + +----+ +----+ +----+ + +----+ + +----+ + + -| | | | | | | | | | | | -| | | | | | | | | | | | -+ +----+----+ + + +----+ + + +----+ +----+----+ +----+----+----+----+ + -| | | | | | | | | | | -| | | | | | | | | | | -+----+----+ +----+----+----+ + + + + + +----+ +----+ + + + +----+ -| | | | | | | | | | | | | | | -| | | | | | | | | | | | | | | -+ + + + + +----+----+ + + + +----+ +----+----+----+----+ + + + -| | | | | | | | | | | | -| | | | | | | | | | | | -+----+ + + +----+----+ + +----+----+----+ +----+----+ +----+----+ +----+ + -| | | | | | | | | | | | | -| | | | | | | | | | | | | -+ +----+ + +----+ + + +----+ + + + + +----+ + +----+ + + -| | | | | | | | | | | | | | -| | | | | | | | | | | | | | -+ +----+----+ + +----+ + + +----+ +----+----+ +----+ + + +----+ + -| | | | | | | | | | | | -| | | | | | | | | | | | -+----+ + + +----+ +----+----+ +----+----+----+----+----+ + + +----+----+ + -| | | | | | | | | | -| | | | | | | | | | -+ + +----+----+ +----+ + +----+ +----+----+ + + + +----+ + + + -| | | | | | | | | | | | | | -| | | | | | | | | | | | | | -+ + +----+----+----+ + +----+ +----+----+ + + + +----+----+----+ + + -| | | | | | | | | | | | -| | | | | | | | | | | | -+ +----+ + + +----+----+----+ +----+----+ + +----+----+ + + + +----+ -| | | | | | | | | | | | | -| | | | | | | | | | | | | -+ +----+----+ +----+ +----+----+ + + +----+----+ + +----+ + +----+ + -| | | | | | -| | | | | | +| | | | | | | | +| | | | | | | | ++ +----+----+ + +----+ + +----+ +----+----+ +----+ +----+----+ +----+ + +| | | | | | | | | | | +| | | | | | | | | | | ++ + +----+----+----+ +----+----+ +----+ + +----+----+----+ +----+----+ + + +| | | | | | | | | | | +| | | | | | | | | | | ++ +----+ + +----+ + +----+----+----+----+ + + + +----+ + +----+ + +| | | | | | | | | | +| | | | | | | | | | ++----+----+----+----+ + +----+ +----+ +----+----+ + +----+ + +----+----+ + +| | | | | | | | | | | +| | | | | | | | | | | ++ + + +----+----+ + +----+ + +----+ + +----+ +----+ +----+----+ + +| | | | | | | | | | | | +| | | | | | | | | | | | ++----+ +----+ +----+----+ +----+----+ + +----+ +----+----+----+----+----+ +----+ +| | | | | | | | | +| | | | | | | | | ++ +----+ +----+ + + +----+ + +----+----+----+----+ +----+ +----+ +----+ +| | | | | | | | | | | | | +| | | | | | | | | | | | | ++ + +----+ + + +----+----+ +----+ + +----+ + + +----+----+----+ + +| | | | | | | | | | | | +| | | | | | | | | | | | ++ + +----+----+ + +----+----+----+ + + + +----+ +----+ + +----+ + +| | | | | | | | | | | | +| | | | | | | | | | | | ++ +----+----+----+ + +----+ +----+ + + + +----+----+ + + +----+----+ +| | | | | | | | | | | | | +| | | | | | | | | | | | | ++ + + + + +----+----+----+ + +----+ +----+ + +----+ +----+----+ + +| | | | | | | | | | | | +| | | | | | | | | | | | ++ +----+ +----+----+ + +----+----+ + + + +----+ + +----+ +----+ + +| | | | | | | | | | | | | | +| | | | | | | | | | | | | | ++----+ +----+ + + +----+----+ +----+ + + + + + + + + + + +| | | | | | | | | | | | | | | | | | +| | | | | | | | | | | | | | | | | | ++ +----+ +----+ +----+ + +----+ + + + + + + + + + +----+ +| | | | | | | | | | | | | | +| | | | | | | | | | | | | | ++ + +----+ +----+ +----+ + +----+----+----+----+ + +----+ + +----+ + +| | | | | | | | | | | | +| | | | | | | | | | | | ++ + + +----+ + + + + +----+----+----+----+----+----+ + +----+----+ + +| | | | | | | | | | +| | | | | | | | | | ++----+----+ + +----+----+ + +----+----+----+----+----+ + +----+----+ + +----+ +| | | | | | | | | | | +| | | | | | | | | | | ++ +----+ + +----+----+----+ + +----+ + + + +----+ + +----+----+ + +| | | | | | | | | | | | | +| | | | | | | | | | | | | ++ +----+----+----+ + + +----+ +----+----+ +----+ + +----+ + + + + +| | | | | | | +| | | | | | | +----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+----+ + diff --git a/tests/013/maze.tl b/tests/013/maze.tl index 5cb989d6..38dca3e3 100644 --- a/tests/013/maze.tl +++ b/tests/013/maze.tl @@ -1,7 +1,3 @@ -(defvar vi) ;; visited hash -(defvar pa) ;; path connectivity hash -(defvar sc) ;; count, derived from straightness fator - (defun scramble (list) (let ((out ())) (each ((item list)) @@ -18,7 +14,7 @@ (list (- x 1)..y (+ x 1)..y x..(- y 1) x..(+ y 1)))) -(defun make-maze-impl (cu) +(defun make-maze-impl (vi pa sc cu) (let ((fr (hash :equal-based)) (q (list cu)) (c sc)) @@ -38,16 +34,16 @@ (pop q))))))) (defun make-maze (w h sf) - (let ((vi (hash :equal-based)) - (pa (hash :equal-based)) - (sc (max 1 (int-flo (trunc (* sf w h) 100.0))))) + (let ((vi (hash :equal-based)) ;; visited hash + (pa (hash :equal-based)) ;; path connectivity hash + (sc (max 1 (int-flo (trunc (* sf w h) 100.0))))) ;; go straight count (each ((x (range -1 w))) (set [vi x..-1] t) (set [vi x..h] t)) (each ((y (range* 0 h))) (set [vi -1..y] t) (set [vi w..y] t)) - (make-maze-impl 0..0) + (make-maze-impl vi pa sc 0..0) ;; Open start and end (push 0..-1 [pa 0..0]) (push (- w 1)..(- h 1) [pa (- w 1)..h]) @@ -78,7 +74,7 @@ (let ((invocation (ldiff *full-args* *args*))) (put-line "usage: ") (put-line `@invocation <width> <height> [<straightness>]`) - (put-line "straightness-factor is a percentage, defaulting to 15") + (put-line "straightness is a percentage, defaulting to 15") (exit 1))) (let ((args [mapcar num-str *args*])) diff --git a/tests/013/rand.tl b/tests/013/rand.tl new file mode 100644 index 00000000..f593c39c --- /dev/null +++ b/tests/013/rand.tl @@ -0,0 +1,84 @@ +(load "../common") + +(mtest + (random-state-get-vec (make-random-state #b'' 0)) + #(740765398 1304255849 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #b'FF' 0)) + #(4278190080 1304255849 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #b'FFFF' 0)) + #(4294901760 1304255849 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #b'FFFFFF' 0)) + #(4294967040 1304255849 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #b'FFFFFFFF' 0)) + #(4294967295 1304255849 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #b'FFFFFFFFFF' 0)) + #(4294967295 4278190080 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state (make-buf (* 4 16) #xff) 0)) + #(4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 + 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 + 4294967295 4294967295 4294967295 4294967295 0) + (random-state-get-vec (make-random-state (make-buf (* 5 16) #xff) 0)) + #(4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 + 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 + 4294967295 4294967295 4294967295 4294967295 0)) + +(mtest + (random-state-get-vec (make-random-state 0 0)) + #(740765398 1304255849 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #xFF 0)) + #(255 1304255849 3309840409 338361566 4155223728 1162561521 4236628653 + 446542199 639181595 1801947880 2890206840 2695457564 2292665861 + 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #xFFFF 0)) + #(65535 1304255849 3309840409 338361566 4155223728 1162561521 4236628653 + 446542199 639181595 1801947880 2890206840 2695457564 2292665861 + 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #xFFFFFF 0)) + #(16777215 1304255849 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #xFFFFFFFF 0)) + #(4294967295 1304255849 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state #xFFFFFFFFFF 0)) + #(4294967295 255 3309840409 338361566 4155223728 1162561521 4236628653 + 446542199 639181595 1801947880 2890206840 2695457564 2292665861 + 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state (expt 2 (* 8 4 16)) 0)) + #(740765398 1304255849 3309840409 338361566 4155223728 1162561521 + 4236628653 446542199 639181595 1801947880 2890206840 2695457564 + 2292665861 3251351234 2171649709 704313206 0) + (random-state-get-vec (make-random-state (pred (expt 2 (* 8 4 16))) 0)) + #(4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 + 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 + 4294967295 4294967295 4294967295 4294967295 0) + (random-state-get-vec (make-random-state (pred (expt 2 (* 8 4 17))) 0)) + #(4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 + 4294967295 4294967295 4294967295 4294967295 4294967295 4294967295 + 4294967295 4294967295 4294967295 4294967295 0)) + +(mtest + (random-state-get-vec (make-random-state + #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))) + #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) + (random-state-get-vec (make-random-state + #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17))) + #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17) + (random-state-get-vec (make-random-state + #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17) 10)) + #(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17)) diff --git a/tests/013/well512a.expected b/tests/013/well512a.expected new file mode 100644 index 00000000..ecde9a65 --- /dev/null +++ b/tests/013/well512a.expected @@ -0,0 +1,16 @@ +419341993 +1818026447 +3020103184 +3141358934 +187862696 +512541134 +1416267688 +4256491982 +731233432 +1852014262 +1248293699 +206481201 +750755084 +1094637740 +2806919360 +2752871950 diff --git a/tests/013/well512a.tl b/tests/013/well512a.tl new file mode 100644 index 00000000..3f238925 --- /dev/null +++ b/tests/013/well512a.tl @@ -0,0 +1,8 @@ +(let ((rs (make-random-state #(#x01010101 #x11111111 #x22222222 #x33333333 + #x44444444 #x55555555 #x66666666 #x77777777 + #x88888888 #x99999999 #xAAAAAAAA #xBBBBBBBB + #xCCCCCCCC #xDDDDDDDD #xEEEEEEEE #xFFFFFFFF + 0))) + (mod (expt 2 32))) + (for ((i 0)) ((< i 16)) ((inc i)) + (pprinl (rand mod rs)))) diff --git a/tests/014/dgram-stream.expected b/tests/014/dgram-stream.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/014/dgram-stream.expected +++ /dev/null diff --git a/tests/014/dgram-stream.tl b/tests/014/dgram-stream.tl index 5902a84d..6890e300 100644 --- a/tests/014/dgram-stream.tl +++ b/tests/014/dgram-stream.tl @@ -1,7 +1,7 @@ (load "../common.tl") (load "../sock-common.tl") -(defvar family) +(defvar *family*) (defun server (svc-sock) (whilet ((acc-sock (sock-accept svc-sock)) @@ -10,7 +10,7 @@ (close-stream acc-sock))) (defun client (addr) - (with-stream (cli-sock (open-socket family sock-dgram)) + (with-stream (cli-sock (open-socket *family* sock-dgram)) (sock-connect cli-sock addr) (dotimes (i 1000) (print i cli-sock) @@ -22,7 +22,7 @@ (flush-stream cli-sock))) (defun dgram-test () - (let* ((svc-sock (open-socket family sock-dgram)) + (let* ((svc-sock (open-socket *family* sock-dgram)) (svc-addr (bindfree svc-sock 1025 65535)) (server-pid (fork))) (cond @@ -37,6 +37,6 @@ (fboundp 'fork)) (let ((maybe-ipv6 (if (memq (os-symbol) '(:linux :macos :cygwin :cygnal)) (list af-inet6)))) - (each ((family ^(,af-inet ,*maybe-ipv6))) + (each ((*family* ^(,af-inet ,*maybe-ipv6))) (unless (dgram-test) (error "test failed"))))) diff --git a/tests/014/in6addr-str.tl b/tests/014/in6addr-str.tl new file mode 100644 index 00000000..a85da416 --- /dev/null +++ b/tests/014/in6addr-str.tl @@ -0,0 +1,120 @@ +(load "../common.tl") + +(test (in6addr-str "junk") :error) + +(test (in6addr-str "0:0:0:0:0:0:0:0:0") :error) +(test (in6addr-str "0:0:0:0:0:0") :error) +(test (in6addr-str "0:0:0:0") :error) +(test (in6addr-str "") :error) + +(test (in6addr-str "0:0:0:0:0:0:0:x:0") :error) + +(test (in6addr-str ":0:0:0:0:0:0:0:0:0") :error) +(test (in6addr-str "0:0:0:0:0:0:0:0:0:") :error) + +(test (in6addr-str "0:0:0:0:0:0:0:0:FFFFF") :error) +(test (in6addr-str "0:0:0:0:0:0:0:FFFFF:0") :error) +(test (in6addr-str "0:0:0:0:0:0:FFFFF:0:0") :error) +(test (in6addr-str "0:0:0:0:0:FFFFF:0:0:0") :error) +(test (in6addr-str "0:0:0:0:FFFFF:0:0:0:0") :error) +(test (in6addr-str "0:0:0:FFFFF:0:0:0:0:0") :error) +(test (in6addr-str "0:0:FFFFF:0:0:0:0:0:0") :error) +(test (in6addr-str "0:FFFFF:0:0:0:0:0:0:0") :error) +(test (in6addr-str "FFFFF:0:0:0:0:0:0:0:0") :error) + +(test (in6addr-str "0:0:0:0:0:0:0:0/") :error) +(test (in6addr-str "0:0:0:0:0:0:0:0/129") :error) +(test (in6addr-str "[0:0:0:0:0:0:0:0]:") :error) +(test (in6addr-str "[0:0:0:0:0:0:0:0]:65536") :error) + +(test (in6addr-str "0:0:0:0:0:0:0:0") + #S(sockaddr-in6 addr 0 + port 0 flow-info 0 scope-id 0 prefix 128)) +(test (in6addr-str "1111:2222:3333:4444:5555:6666:7777:8888") + #S(sockaddr-in6 addr 22685837286468424649968941046919825544 + port 0 flow-info 0 scope-id 0 prefix 128)) +(test (in6addr-str "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF") + #S(sockaddr-in6 addr 340282366920938463463374607431768211455 + port 0 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "[0:0:0:0:0:0:0:0]:42") + #S(sockaddr-in6 addr 0 + port 42 flow-info 0 scope-id 0 prefix 128)) +(test (in6addr-str "[1111:2222:3333:4444:5555:6666:7777:8888]:42") + #S(sockaddr-in6 addr 22685837286468424649968941046919825544 + port 42 flow-info 0 scope-id 0 prefix 128)) +(test (in6addr-str "[FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF]:42") + #S(sockaddr-in6 addr 340282366920938463463374607431768211455 + port 42 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "0:0:0:0:0:0:0:0/16") + #S(sockaddr-in6 addr 0 + port 0 flow-info 0 scope-id 0 prefix 16)) +(test (in6addr-str "1111:2222:3333:4444:5555:6666:7777:8888/16") + #S(sockaddr-in6 addr 22685144974938661909049738462362599424 + port 0 flow-info 0 scope-id 0 prefix 16)) +(test (in6addr-str "FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF/16") + #S(sockaddr-in6 addr 340277174624079928635746076935438991360 + port 0 flow-info 0 scope-id 0 prefix 16)) +(test (in6addr-str "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff/16") + #S(sockaddr-in6 addr 340277174624079928635746076935438991360 + port 0 flow-info 0 scope-id 0 prefix 16)) + +(test (in6addr-str "[0:0:0:0:0:0:0:0/16]:42") + #S(sockaddr-in6 addr 0 + port 42 flow-info 0 scope-id 0 prefix 16)) +(test (in6addr-str "[1111:2222:3333:4444:5555:6666:7777:8888/16]:42") + #S(sockaddr-in6 addr 22685144974938661909049738462362599424 + port 42 flow-info 0 scope-id 0 prefix 16)) +(test (in6addr-str "[FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF/16]:42") + #S(sockaddr-in6 addr 340277174624079928635746076935438991360 + port 42 flow-info 0 scope-id 0 prefix 16)) + +(test (in6addr-str "1:2:3:4:5:6::7:8:9") :error) +(test (in6addr-str "1:2:3:4:5:6::7:8:9") :error) +(test (in6addr-str "1:2:3:4:5:6::7:8") :error) + +(test (in6addr-str "::1") + #S(sockaddr-in6 addr 1 + port 0 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "1::") + #S(sockaddr-in6 addr 5192296858534827628530496329220096 + port 0 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "1::1") + #S(sockaddr-in6 addr 5192296858534827628530496329220097 + port 0 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "1:2::3:4") + #S(sockaddr-in6 addr 5192455314859856157205683417317380 + port 0 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "::ffff:1.2.3.4.5") :error) +(test (in6addr-str "::ffff:1.2.3.4:5") :error) +(test (in6addr-str "::ffff:1.2.3") :error) +(test (in6addr-str "::ffff:1.2.3:4") :error) + +(test (in6addr-str "::ffff:1.2.3.4") + #S(sockaddr-in6 addr 281470698652420 + port 0 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "::FFFF:1.2.3.4") + #S(sockaddr-in6 addr 281470698652420 + port 0 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "::FfFf:1.2.3.4") + #S(sockaddr-in6 addr 281470698652420 + port 0 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "::FFFF:1.2.3.4/96") + #S(sockaddr-in6 addr 281470681743360 + port 0 flow-info 0 scope-id 0 prefix 96)) + +(test (in6addr-str "[::ffff:1.2.3.4]:42") + #S(sockaddr-in6 addr 281470698652420 + port 42 flow-info 0 scope-id 0 prefix 128)) + +(test (in6addr-str "[::FFFF:1.2.3.4/96]:42") + #S(sockaddr-in6 addr 281470681743360 + port 42 flow-info 0 scope-id 0 prefix 96)) diff --git a/tests/014/inaddr-str.tl b/tests/014/inaddr-str.tl new file mode 100644 index 00000000..67283188 --- /dev/null +++ b/tests/014/inaddr-str.tl @@ -0,0 +1,78 @@ +(load "../common.tl") + +(test (inaddr-str "junk") :error) +(test (inaddr-str "0.0.0.0.0") :error) +(test (inaddr-str "0.0.0") :error) +(test (inaddr-str "0") :error) +(test (inaddr-str "") :error) +(test (inaddr-str "0.0.0.nnn") :error) +(test (inaddr-str "0.0.0.256") :error) +(test (inaddr-str "0.0.256.0") :error) +(test (inaddr-str "0.256.0.0") :error) +(test (inaddr-str "256.0.0.0") :error) +(test (inaddr-str "0.0.0.0:65537") :error) +(test (inaddr-str "0.0.0.0/33") :error) +(test (inaddr-str "0.0.0.0/32:65537") :error) +(test (inaddr-str "0.0.0.0/33:0") :error) +(test (inaddr-str "0.0.0.0:0/0") :error) +(test (inaddr-str "0.0.0.") :error) +(test (inaddr-str "0.0..0") :error) +(test (inaddr-str "0..0.0") :error) +(test (inaddr-str ".0.0.0") :error) +(test (inaddr-str "0.0.0.0:") :error) + +(test (inaddr-str "0.0.0.0") + #S(sockaddr-in addr 0 port 0 prefix 32)) +(test (inaddr-str "1.2.3.4") + #S(sockaddr-in addr 16909060 port 0 prefix 32)) +(test (inaddr-str "255.255.255.255") + #S(sockaddr-in addr 4294967295 port 0 prefix 32)) + +(test (inaddr-str "0.0.0.0:0") + #S(sockaddr-in addr 0 port 0 prefix 32)) +(test (inaddr-str "1.2.3.4:5") + #S(sockaddr-in addr 16909060 port 5 prefix 32)) +(test (inaddr-str "255.255.255.255:65535") + #S(sockaddr-in addr 4294967295 port 65535 prefix 32)) + +(test (inaddr-str "0.0.0.0/0") + #S(sockaddr-in addr 0 port 0 prefix 0)) +(test (inaddr-str "1.2.3.4/8") + #S(sockaddr-in addr 16777216 port 0 prefix 8)) +(test (inaddr-str "255.255.255.255/24") + #S(sockaddr-in addr 4294967040 port 0 prefix 24)) + +(test (inaddr-str "0.0.0/0") + #S(sockaddr-in addr 0 port 0 prefix 0)) +(test (inaddr-str "0.0/0") + #S(sockaddr-in addr 0 port 0 prefix 0)) +(test (inaddr-str "0/0") + #S(sockaddr-in addr 0 port 0 prefix 0)) + +(test (inaddr-str "1.2.3/8") + #S(sockaddr-in addr 16777216 port 0 prefix 8)) +(test (inaddr-str "1.2/8") + #S(sockaddr-in addr 16777216 port 0 prefix 8)) +(test (inaddr-str "1/8") + #S(sockaddr-in addr 16777216 port 0 prefix 8)) + +(test (inaddr-str "0.0.0.0/0:1234") + #S(sockaddr-in addr 0 port 1234 prefix 0)) +(test (inaddr-str "1.2.3.4/8:1234") + #S(sockaddr-in addr 16777216 port 1234 prefix 8)) +(test (inaddr-str "255.255.255.255/24:1234") + #S(sockaddr-in addr 4294967040 port 1234 prefix 24)) + +(test (inaddr-str "0.0.0/0:1234") + #S(sockaddr-in addr 0 port 1234 prefix 0)) +(test (inaddr-str "0.0/0:1234") + #S(sockaddr-in addr 0 port 1234 prefix 0)) +(test (inaddr-str "0/0:1234") + #S(sockaddr-in addr 0 port 1234 prefix 0)) + +(test (inaddr-str "1.2.3/8:1234") + #S(sockaddr-in addr 16777216 port 1234 prefix 8)) +(test (inaddr-str "1.2/8:1234") + #S(sockaddr-in addr 16777216 port 1234 prefix 8)) +(test (inaddr-str "1/8:1234") + #S(sockaddr-in addr 16777216 port 1234 prefix 8)) diff --git a/tests/014/sockaddr-str.tl b/tests/014/sockaddr-str.tl new file mode 100644 index 00000000..183c1a02 --- /dev/null +++ b/tests/014/sockaddr-str.tl @@ -0,0 +1,49 @@ +(load "../common.tl") + +(mtest + (sockaddr-str "") :error + (sockaddr-str "1") :error + (sockaddr-str "x") :error + (sockaddr-str "1:2") :error + (sockaddr-str "[]:") :error) + +(mtest + (sockaddr-str "[::1]:-1") :error + (sockaddr-str "[::1]:65536") :error + (sockaddr-str "1.2.3.4:-1") :error + (sockaddr-str "1.2.3.4:65536") :error + (sockaddr-str "1:2/8") :error) + +(mtest + (sockaddr-str "/") #S(sockaddr-un canonname nil path "/") + (sockaddr-str "/abc") #S(sockaddr-un canonname nil path "/abc")) + +(mtest + (sockaddr-str "[::1]:2") #S(sockaddr-in6 addr 1 port 2) + (sockaddr-str "[::1/1]:2") #S(sockaddr-in6 addr 0 port 2 prefix 1)) + +(mtest + (sockaddr-str "::1") #S(sockaddr-in6 addr 1) + (sockaddr-str "::1/1") #S(sockaddr-in6 addr 0 prefix 1)) + +(mtest + (sockaddr-str "::ffff:1.2.3.4") #S(sockaddr-in6 addr 281470698652420) + (sockaddr-str "::ffff:1.2.3.4/96") #S(sockaddr-in6 addr 281470681743360 prefix 96)) + +(mtest + (sockaddr-str "1.2.3.4") #S(sockaddr-in addr 16909060) + (sockaddr-str "1.2.3.4/8") #S(sockaddr-in addr 16777216 prefix 8) + (sockaddr-str "1.2.3.4:16") #S(sockaddr-in addr 16909060 port 16) + (sockaddr-str "1.2.3.4/8:16") #S(sockaddr-in addr 16777216 prefix 8 port 16)) + +(mtest + (sockaddr-str "1/8") #S(sockaddr-in addr 16777216 prefix 8) + (sockaddr-str "1.2/8") #S(sockaddr-in addr 16777216 prefix 8) + (sockaddr-str "1/8:5") #S(sockaddr-in addr 16777216 prefix 8 port 5) + (sockaddr-str "1.2/8:5") #S(sockaddr-in addr 16777216 prefix 8 port 5)) + +(mtest + (sockaddr-str "1:2:3:4:5:6:7:8/127") + #S(sockaddr-in6 addr 5192455318486707404433266433261576 prefix 127) + (sockaddr-str "[1:2:3:4:5:6:7:8/127]:5") + #S(sockaddr-in6 addr 5192455318486707404433266433261576 prefix 127 port 5)) diff --git a/tests/014/socket-basic.expected b/tests/014/socket-basic.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/014/socket-basic.expected +++ /dev/null diff --git a/tests/014/socket-basic.tl b/tests/014/socket-basic.tl index efeed2d6..2e4d57a0 100644 --- a/tests/014/socket-basic.tl +++ b/tests/014/socket-basic.tl @@ -1,22 +1,25 @@ (load "../sock-common.tl") +(load "../common.tl") -(defvar socktype) +(defvar *socktype*) + +(defvarl %iters% (if (meql (os-symbol) :macos :bsd :openbsd) 2000 5000)) (defun client (addr) - (with-stream (cli-sock (open-socket af-inet socktype)) + (with-stream (cli-sock (open-socket af-inet *socktype*)) (sock-connect cli-sock addr) (put-string "5000" cli-sock) (sock-shutdown cli-sock) - (equal (read cli-sock) (range 1 5000)))) + (equal (read cli-sock) (range 1 %iters%)))) (defun server (svc-sock) (let* ((acc-sock (sock-accept svc-sock)) (query (read acc-sock))) - (print (range 1 5000) acc-sock) + (print (range 1 %iters%) acc-sock) (close-stream acc-sock))) -(defun test () - (let* ((svc-sock (open-socket af-inet socktype)) +(defun sock-test () + (let* ((svc-sock (open-socket af-inet *socktype*)) (svc-addr (bindfree svc-sock 1025 65535)) (child-pid (fork))) (cond @@ -26,6 +29,6 @@ (if (and (fboundp 'open-socket) (fboundp 'fork)) - (each ((socktype (list sock-dgram sock-stream))) - (unless (test) + (each ((*socktype* (list sock-dgram sock-stream))) + (unless (sock-test) (error "test failed")))) diff --git a/tests/014/socket-misc.tl b/tests/014/socket-misc.tl new file mode 100644 index 00000000..5f533529 --- /dev/null +++ b/tests/014/socket-misc.tl @@ -0,0 +1,20 @@ +(load "../sock-common") +(load "../common") + +(defmacro set-and-get (:env env place val) + (with-update-expander (getter setter) place env + ^(progn (,setter ,val) (,getter)))) + +(with-stream (s (open-socket af-inet (logior sock-dgram sock-nonblock))) + (test (sock-listen s) t) + (let* ((orig #S(sockaddr-in)) + (addr orig)) + (rotate addr (sock-peer s)) + (vtest (sock-peer s) orig))) + +(with-stream (s (open-socket af-inet sock-stream)) + (test (nzerop (set-and-get (sock-opt s sol-socket so-reuseaddr) 1)) t) + (test (set-and-get (sock-opt s sol-socket so-reuseaddr (ffi int)) 0) 0) + (whenlet ((addr (bindfree s 1025 65535))) + ;; sock-bind enables so-reuseaddr. + (test (nzerop (sock-opt s sol-socket so-reuseaddr)) t))) diff --git a/tests/014/str-addr.tl b/tests/014/str-addr.tl new file mode 100644 index 00000000..49bc844a --- /dev/null +++ b/tests/014/str-addr.tl @@ -0,0 +1,68 @@ +(load "../common.tl") + +(mtest + #S(sockaddr-un path "/foo").(str-addr) "/foo" + #S(sockaddr-un path nil).(str-addr) :error) + +(mtest + #S(sockaddr-in addr 0).(str-addr) "0.0.0.0" + #S(sockaddr-in addr #x01020304).(str-addr) "1.2.3.4" + #S(sockaddr-in addr #x01020304 prefix 8).(str-addr) "1.2.3.4/8" + #S(sockaddr-in addr #x01020304 prefix 16).(str-addr) "1.2.3.4/16" + #S(sockaddr-in addr #x01020304 prefix 24).(str-addr) "1.2.3.4/24" + #S(sockaddr-in addr #x01020304 prefix 31).(str-addr) "1.2.3.4/31" + #S(sockaddr-in addr #x01020304 prefix 32).(str-addr) "1.2.3.4" + #S(sockaddr-in addr #x01000000 prefix 8).(str-addr) "1/8" + #S(sockaddr-in addr #x01000000 prefix 16).(str-addr) "1/16" + #S(sockaddr-in addr #x01020000 prefix 16).(str-addr) "1.2/16" + #S(sockaddr-in addr #x01000000 prefix 24).(str-addr) "1/24" + #S(sockaddr-in addr #x01020000 prefix 24).(str-addr) "1.2/24" + #S(sockaddr-in addr #x01020300 prefix 24).(str-addr) "1.2.3/24" + #S(sockaddr-in addr #x01000000 prefix 31).(str-addr) "1/31" + #S(sockaddr-in addr 0 port 123).(str-addr) "0.0.0.0:123" + #S(sockaddr-in addr #x01020304 port 123).(str-addr) "1.2.3.4:123" + #S(sockaddr-in addr #x01020304 port 123 prefix 8).(str-addr) "1.2.3.4/8:123" + #S(sockaddr-in addr #x01020304 port 123 prefix 16).(str-addr) "1.2.3.4/16:123" + #S(sockaddr-in addr #x01020304 port 123 prefix 24).(str-addr) "1.2.3.4/24:123" + #S(sockaddr-in addr #x01020304 port 123 prefix 24).(str-addr) "1.2.3.4/24:123" + #S(sockaddr-in addr #x01020304 port 123 prefix 31).(str-addr) "1.2.3.4/31:123" + #S(sockaddr-in addr #x01020304 port 123 prefix 32).(str-addr) "1.2.3.4:123" + #S(sockaddr-in addr #x01000000 port 123 prefix 8).(str-addr) "1/8:123" + #S(sockaddr-in addr #x01000000 port 123 prefix 16).(str-addr) "1/16:123" + #S(sockaddr-in addr #x01020000 port 123 prefix 16).(str-addr) "1.2/16:123" + #S(sockaddr-in addr #x01000000 port 123 prefix 24).(str-addr) "1/24:123" + #S(sockaddr-in addr #x01020000 port 123 prefix 24).(str-addr) "1.2/24:123" + #S(sockaddr-in addr #x01020300 port 123 prefix 24).(str-addr) "1.2.3/24:123" + #S(sockaddr-in addr #x01000000 port 123 prefix 31).(str-addr) "1/31:123") + +(mtest + #S(sockaddr-in6 addr 0).(str-addr) "::" + #S(sockaddr-in6 addr #x80000000000000000000000000000001).(str-addr) "8000::1" + #S(sockaddr-in6 addr #x00000000000000000000000000000001).(str-addr) "::1" + #S(sockaddr-in6 addr #x80000000000000000000000000000000).(str-addr) "8000::" + #S(sockaddr-in6 addr #x00008000000000000000000000000001).(str-addr) "0:8000::1" + #S(sockaddr-in6 addr #x00000000000000000000000000010000).(str-addr) "::1:0" + #S(sockaddr-in6 addr #x00008000000000000000000000010000).(str-addr) "0:8000::1:0" + #S(sockaddr-in6 addr #x000000000000abcd0000000000000000).(str-addr) "0:0:0:abcd::" + #S(sockaddr-in6 addr #x0000000000000000abcd000000000000).(str-addr) "::abcd:0:0:0" + #S(sockaddr-in6 addr #x11112222333344445555666677778888).(str-addr) "1111:2222:3333:4444:5555:6666:7777:8888" + #S(sockaddr-in6 addr #x01000200030004000500060007000800).(str-addr) "100:200:300:400:500:600:700:800" + #S(sockaddr-in6 addr #x00008000000000000000000000010000 port 0).(str-addr) "0:8000::1:0" + #S(sockaddr-in6 addr #x00008000000000000000000000010000 port 123).(str-addr) "[0:8000::1:0]:123" + #S(sockaddr-in6 addr #x00008000000000000000000000010000 prefix 128).(str-addr) "0:8000::1:0" + #S(sockaddr-in6 addr #x00008000000000000000000000010000 prefix 127).(str-addr) "0:8000::1:0/127" + #S(sockaddr-in6 addr #x00008000000000000000000000010000 port 123 prefix 127).(str-addr) "[0:8000::1:0/127]:123") + +(mtest + #S(sockaddr-in6 addr #xffff00000000).(str-addr) "::ffff:0.0.0.0" + #S(sockaddr-in6 addr #xffff00000000 prefix 24).(str-addr) "::ffff:0/24" + #S(sockaddr-in6 addr #xffff01000000 prefix 24).(str-addr) "::ffff:1/24" + #S(sockaddr-in6 addr #xffff01020000 prefix 24).(str-addr) "::ffff:1.2/24" + #S(sockaddr-in6 addr #xffff01020300 prefix 24).(str-addr) "::ffff:1.2.3/24" + #S(sockaddr-in6 addr #xffff01020304 prefix 24).(str-addr) "::ffff:1.2.3.4/24" + #S(sockaddr-in6 addr #xffff00000000 port 123 ).(str-addr) "[::ffff:0.0.0.0]:123" + #S(sockaddr-in6 addr #xffff00000000 port 123 prefix 24).(str-addr) "[::ffff:0/24]:123" + #S(sockaddr-in6 addr #xffff01000000 port 123 prefix 24).(str-addr) "[::ffff:1/24]:123" + #S(sockaddr-in6 addr #xffff01020000 port 123 prefix 24).(str-addr) "[::ffff:1.2/24]:123" + #S(sockaddr-in6 addr #xffff01020300 port 123 prefix 24).(str-addr) "[::ffff:1.2.3/24]:123" + #S(sockaddr-in6 addr #xffff01020304 port 123 prefix 24).(str-addr) "[::ffff:1.2.3.4/24]:123") diff --git a/tests/015/awk-fconv.tl b/tests/015/awk-fconv.tl new file mode 100644 index 00000000..2affa4e0 --- /dev/null +++ b/tests/015/awk-fconv.tl @@ -0,0 +1,21 @@ +(load "../common") + +(defvarl inputs '("10E3 junk 20E3 30E3 40E3 50E3")) + +(defmacro tfconv (fconv expected) + ^(test (awk (:inputs inputs) + (t (fconv ,*fconv)) + (:end f)) + ,expected)) + +(tfconv (i) (10 "junk" "20E3" "30E3" "40E3" "50E3")) +(tfconv (: : i) ("10E3" "junk" "20E3" "30E3" "40E3" 50)) +(tfconv (: : o) ("10E3" "junk" "20E3" "30E3" "40E3" 40)) +(tfconv (: : x) ("10E3" "junk" "20E3" "30E3" "40E3" #x50E3)) +(tfconv (: x) (#x10E3 nil #x20E3 #x30E3 #x40E3 #x50E3)) +(tfconv (: r) (10000.0 nil 20000.0 30000.0 40000.0 50000.0)) +(tfconv (: b) (2 nil nil nil nil nil)) +(tfconv (: bz) (2 0 0 0 0 0)) +(tfconv (i : : x) (10 "junk" "20E3" "30E3" "40E3" #x50E3)) +(tfconv (- : i : -) ("10E3" nil 20 30 40 "50E3")) +(tfconv (i : o r : x) (10 nil 20000.0 #o30 40000.0 #x50E3)) diff --git a/tests/015/awk-fields.tl b/tests/015/awk-fields.tl new file mode 100644 index 00000000..7bb2f599 --- /dev/null +++ b/tests/015/awk-fields.tl @@ -0,0 +1,37 @@ +(load "../common") + +(mtest + (awk (:fields) (:begin (return-from awk))) nil + (awk (:fields t) (:begin (return-from awk))) :error + (awk (:fields nil) (:begin (return-from awk))) :error + (awk (:fields - -) (:begin (return-from awk))) nil + (awk (:fields a - - b) (:begin (return-from awk))) nil + (awk (:fields (a foo) - - (a bar)) (:begin (return-from awk))) :error + (awk (:fields (a foo) - - (b bar)) (:begin (return-from awk))) nil + (awk (:fields (a foo) (-) - (b bar)) (:begin (return-from awk))) :error + (awk (:fields (a foo) (- i) - (b bar)) (:begin (return-from awk))) :error + (awk (:fields a) (:fields b) (:begin (return-from awk))) :error) + +(test + (build + (awk + (:inputs '("How now brown cow")) + (:fields h n - c) + (t (add h n c)))) + ("How" "now" "cow")) + +(test + (build + (awk + (:inputs '("1 x 2" "a x 1" "4 x b")) + (:fields (foo iz) - (bar iz)) + (t (add (+ foo bar))))) + (3 1 4)) + +(test + (build + (awk + (:inputs '("1")) + (:fields (a iz) - (c iz)) + (t (add (+ a c) nf)))) + (1 3)) diff --git a/tests/015/awk-misc.tl b/tests/015/awk-misc.tl new file mode 100644 index 00000000..af61857d --- /dev/null +++ b/tests/015/awk-misc.tl @@ -0,0 +1,10 @@ +(load "../common") + +(let ((*stdout* *stdnull*)) + (test + (build + (awk + (:inputs '("")) + (t (add (prn 1 2 3)) + (add (prn))))) + (nil nil))) diff --git a/tests/015/awk-redir.tl b/tests/015/awk-redir.tl new file mode 100644 index 00000000..5359ea2b --- /dev/null +++ b/tests/015/awk-redir.tl @@ -0,0 +1,42 @@ +(load "../common") + +(push-after-load + (each ((f '#"file1.out file2.out file3.out")) + (remove-path f))) + +(file-put-lines "file1.out" '("old")) +(file-put-lines "file2.out" '("old")) + +(awk + (:begin (->> "file1.out" (prn "abc")) + (->> "file1.out" (prn "def")))) + +(test + (file-get-lines "file1.out") + #"old abc def") + +(awk + (:begin (-> "file2.out" (prn "abc")) + (-> "file2.out" (prn "def")))) + +(test + (file-get-lines "file2.out") + #"abc def") + +(test + (build + (awk + (:begin (<- "file1.out" (add (get-line))) + (<- "file1.out" (add (get-line)))))) + #"old abc") + + +(awk (:begin (!> "cat > file3.out" (prn "out")))) + +(test (file-get-string "file3.out") "out\n") + +(test + (build + (awk + (:begin (<! "cat file3.out" (add (get-line)))))) + #"out") diff --git a/tests/015/awk-res.tl b/tests/015/awk-res.tl new file mode 100644 index 00000000..6c919320 --- /dev/null +++ b/tests/015/awk-res.tl @@ -0,0 +1,8 @@ +(load "../common") + +(test + (build + (awk + (:inputs '#"How about it now brown cow") + (#/.ow/ (add res)))) + ("How" "now" "row" "cow")) diff --git a/tests/015/comb.tl b/tests/015/comb.tl new file mode 100644 index 00000000..9973e94d --- /dev/null +++ b/tests/015/comb.tl @@ -0,0 +1,443 @@ +(load "../common") + +(defun normtype (obj) + (etypecase obj + (null 'list) + (cons 'list) + (lit 'string) + (str 'string) + (vec 'vec))) + +(defun test-comb (s k) + (let ((out (comb s k)) + (nCk (n-choose-k (len s) k))) + (if (> k (len s)) + (test out nil) + (mvtest + (len out) nCk + (len (uniq out)) nCk)) + (vtest + (sort out) out) + (unless (empty out) + (let ((stype (normtype s)) + (otype (normtype (first out)))) + (vtest stype otype))))) + +(defun test-rcomb (s k) + (let ((out (rcomb s k)) + (nCk (n-choose-k (+ (len s) k -1) k))) + (if (and (empty s) (plusp k)) + (test out nil) + (mvtest + (len out) nCk + (len (uniq out)) nCk)) + (vtest + (sort out) out) + (unless (empty out) + (let ((stype (normtype s)) + (otype (normtype (first out)))) + (vtest stype otype))))) + +(defun test-perm (s k) + (let ((out (perm s k)) + (nPk (n-perm-k (len s) k))) + (if (> k (len s)) + (test out nil) + (mvtest + (len out) nPk + (len (uniq out)) nPk)) + (unless (empty out) + (let ((stype (normtype s)) + (otype (normtype (first out)))) + (vtest stype otype))))) + +(defun test-rperm (s k) + (let ((out (rperm s k)) + (exp (expt (len s) k))) + (mvtest + (len out) exp + (len (uniq out)) exp) + (vtest + (sort out) out) + (unless (empty out) + (let ((stype (normtype s)) + (otype (normtype (first out)))) + (vtest stype otype))))) + +(test-comb #() 0) +(test-comb #() 1) +(test-comb #(1) 0) +(test-comb #(1) 1) +(test-comb #(1) 2) +(test-comb #(1 2) 0) +(test-comb #(1 2) 1) +(test-comb #(1 2) 2) +(test-comb #(1 2) 3) +(test-comb #(1 2 3) 0) +(test-comb #(1 2 3) 1) +(test-comb #(1 2 3) 2) +(test-comb #(1 2 3) 3) +(test-comb #(1 2 3) 4) +(test-comb #(1 2 3 4) 0) +(test-comb #(1 2 3 4) 1) +(test-comb #(1 2 3 4) 2) +(test-comb #(1 2 3 4) 3) +(test-comb #(1 2 3 4) 4) +(test-comb #(1 2 3 4) 5) +(test-comb #(1 2 3 4 5) 0) +(test-comb #(1 2 3 4 5) 1) +(test-comb #(1 2 3 4 5) 2) +(test-comb #(1 2 3 4 5) 3) +(test-comb #(1 2 3 4 5) 4) +(test-comb #(1 2 3 4 5) 5) +(test-comb #(1 2 3 4 5) 5) + +(test-comb '() 0) +(test-comb '() 1) +(test-comb '(1) 0) +(test-comb '(1) 1) +(test-comb '(1) 2) +(test-comb '(1 2) 0) +(test-comb '(1 2) 1) +(test-comb '(1 2) 2) +(test-comb '(1 2) 3) +(test-comb '(1 2 3) 0) +(test-comb '(1 2 3) 1) +(test-comb '(1 2 3) 2) +(test-comb '(1 2 3) 3) +(test-comb '(1 2 3) 4) +(test-comb '(1 2 3 4) 0) +(test-comb '(1 2 3 4) 1) +(test-comb '(1 2 3 4) 2) +(test-comb '(1 2 3 4) 3) +(test-comb '(1 2 3 4) 4) +(test-comb '(1 2 3 4) 5) +(test-comb '(1 2 3 4 5) 0) +(test-comb '(1 2 3 4 5) 1) +(test-comb '(1 2 3 4 5) 2) +(test-comb '(1 2 3 4 5) 3) +(test-comb '(1 2 3 4 5) 4) +(test-comb '(1 2 3 4 5) 5) +(test-comb '(1 2 3 4 5) 5) + +(test-comb "" 0) +(test-comb "" 1) +(test-comb "1" 0) +(test-comb "1" 1) +(test-comb "1" 2) +(test-comb "12" 0) +(test-comb "12" 1) +(test-comb "12" 2) +(test-comb "12" 3) +(test-comb "123" 0) +(test-comb "123" 1) +(test-comb "123" 2) +(test-comb "123" 3) +(test-comb "123" 4) +(test-comb "1234" 0) +(test-comb "1234" 1) +(test-comb "1234" 2) +(test-comb "1234" 3) +(test-comb "1234" 4) +(test-comb "1234" 5) +(test-comb "12345" 0) +(test-comb "12345" 1) +(test-comb "12345" 2) +(test-comb "12345" 3) +(test-comb "12345" 4) +(test-comb "12345" 5) +(test-comb "12345" 5) + +(mtest + (comb #() -1) :error + (comb #(1) -1) :error + (comb () -1) :error + (comb '(1) -1) :error + (comb "" -1) :error + (comb "a" -1) :error) + +(test-rcomb #() 0) +(test-rcomb #() 1) +(test-rcomb #(1) 0) +(test-rcomb #(1) 1) +(test-rcomb #(1) 2) +(test-rcomb #(1 2) 0) +(test-rcomb #(1 2) 1) +(test-rcomb #(1 2) 2) +(test-rcomb #(1 2) 3) +(test-rcomb #(1 2 3) 0) +(test-rcomb #(1 2 3) 1) +(test-rcomb #(1 2 3) 2) +(test-rcomb #(1 2 3) 3) +(test-rcomb #(1 2 3) 4) +(test-rcomb #(1 2 3 4) 0) +(test-rcomb #(1 2 3 4) 1) +(test-rcomb #(1 2 3 4) 2) +(test-rcomb #(1 2 3 4) 3) +(test-rcomb #(1 2 3 4) 4) +(test-rcomb #(1 2 3 4) 5) +(test-rcomb #(1 2 3 4 5) 0) +(test-rcomb #(1 2 3 4 5) 1) +(test-rcomb #(1 2 3 4 5) 2) +(test-rcomb #(1 2 3 4 5) 3) +(test-rcomb #(1 2 3 4 5) 4) +(test-rcomb #(1 2 3 4 5) 5) +(test-rcomb #(1 2 3 4 5) 5) + +(test-rcomb '() 0) +(test-rcomb '() 1) +(test-rcomb '(1) 0) +(test-rcomb '(1) 1) +(test-rcomb '(1) 2) +(test-rcomb '(1 2) 0) +(test-rcomb '(1 2) 1) +(test-rcomb '(1 2) 2) +(test-rcomb '(1 2) 3) +(test-rcomb '(1 2 3) 0) +(test-rcomb '(1 2 3) 1) +(test-rcomb '(1 2 3) 2) +(test-rcomb '(1 2 3) 3) +(test-rcomb '(1 2 3) 4) +(test-rcomb '(1 2 3 4) 0) +(test-rcomb '(1 2 3 4) 1) +(test-rcomb '(1 2 3 4) 2) +(test-rcomb '(1 2 3 4) 3) +(test-rcomb '(1 2 3 4) 4) +(test-rcomb '(1 2 3 4) 5) +(test-rcomb '(1 2 3 4 5) 0) +(test-rcomb '(1 2 3 4 5) 1) +(test-rcomb '(1 2 3 4 5) 2) +(test-rcomb '(1 2 3 4 5) 3) +(test-rcomb '(1 2 3 4 5) 4) +(test-rcomb '(1 2 3 4 5) 5) +(test-rcomb '(1 2 3 4 5) 5) + +(test-rcomb "" 0) +(test-rcomb "" 1) +(test-rcomb "1" 0) +(test-rcomb "1" 1) +(test-rcomb "1" 2) +(test-rcomb "12" 0) +(test-rcomb "12" 1) +(test-rcomb "12" 2) +(test-rcomb "12" 3) +(test-rcomb "123" 0) +(test-rcomb "123" 1) +(test-rcomb "123" 2) +(test-rcomb "123" 3) +(test-rcomb "123" 4) +(test-rcomb "1234" 0) +(test-rcomb "1234" 1) +(test-rcomb "1234" 2) +(test-rcomb "1234" 3) +(test-rcomb "1234" 4) +(test-rcomb "1234" 5) +(test-rcomb "12345" 0) +(test-rcomb "12345" 1) +(test-rcomb "12345" 2) +(test-rcomb "12345" 3) +(test-rcomb "12345" 4) +(test-rcomb "12345" 5) +(test-rcomb "12345" 5) + +(mtest + (rcomb #() -1) :error + (rcomb #(1) -1) :error + (rcomb () -1) :error + (rcomb '(1) -1) :error + (rcomb "" -1) :error + (rcomb "a" -1) :error) + +(test-perm #() 0) +(test-perm #() 1) +(test-perm #(1) 0) +(test-perm #(1) 1) +(test-perm #(1) 2) +(test-perm #(1 2) 0) +(test-perm #(1 2) 1) +(test-perm #(1 2) 2) +(test-perm #(1 2) 3) +(test-perm #(1 2 3) 0) +(test-perm #(1 2 3) 1) +(test-perm #(1 2 3) 2) +(test-perm #(1 2 3) 3) +(test-perm #(1 2 3) 4) +(test-perm #(1 2 3 4) 0) +(test-perm #(1 2 3 4) 1) +(test-perm #(1 2 3 4) 2) +(test-perm #(1 2 3 4) 3) +(test-perm #(1 2 3 4) 4) +(test-perm #(1 2 3 4) 5) +(test-perm #(1 2 3 4 5) 0) +(test-perm #(1 2 3 4 5) 1) +(test-perm #(1 2 3 4 5) 2) +(test-perm #(1 2 3 4 5) 3) +(test-perm #(1 2 3 4 5) 4) +(test-perm #(1 2 3 4 5) 5) +(test-perm #(1 2 3 4 5) 5) + +(test-perm '() 0) +(test-perm '() 1) +(test-perm '(1) 0) +(test-perm '(1) 1) +(test-perm '(1) 2) +(test-perm '(1 2) 0) +(test-perm '(1 2) 1) +(test-perm '(1 2) 2) +(test-perm '(1 2) 3) +(test-perm '(1 2 3) 0) +(test-perm '(1 2 3) 1) +(test-perm '(1 2 3) 2) +(test-perm '(1 2 3) 3) +(test-perm '(1 2 3) 4) +(test-perm '(1 2 3 4) 0) +(test-perm '(1 2 3 4) 1) +(test-perm '(1 2 3 4) 2) +(test-perm '(1 2 3 4) 3) +(test-perm '(1 2 3 4) 4) +(test-perm '(1 2 3 4) 5) +(test-perm '(1 2 3 4 5) 0) +(test-perm '(1 2 3 4 5) 1) +(test-perm '(1 2 3 4 5) 2) +(test-perm '(1 2 3 4 5) 3) +(test-perm '(1 2 3 4 5) 4) +(test-perm '(1 2 3 4 5) 5) +(test-perm '(1 2 3 4 5) 5) + +(test-perm "" 0) +(test-perm "" 1) +(test-perm "1" 0) +(test-perm "1" 1) +(test-perm "1" 2) +(test-perm "12" 0) +(test-perm "12" 1) +(test-perm "12" 2) +(test-perm "12" 3) +(test-perm "123" 0) +(test-perm "123" 1) +(test-perm "123" 2) +(test-perm "123" 3) +(test-perm "123" 4) +(test-perm "1234" 0) +(test-perm "1234" 1) +(test-perm "1234" 2) +(test-perm "1234" 3) +(test-perm "1234" 4) +(test-perm "1234" 5) +(test-perm "12345" 0) +(test-perm "12345" 1) +(test-perm "12345" 2) +(test-perm "12345" 3) +(test-perm "12345" 4) +(test-perm "12345" 5) +(test-perm "12345" 5) + +(mtest + (perm #() -1) :error + (perm #(1) -1) :error + (perm () -1) :error + (perm '(1) -1) :error + (perm "" -1) :error + (perm "a" -1) :error) + +(test-rperm #() 0) +(test-rperm #() 1) +(test-rperm #(1) 0) +(test-rperm #(1) 1) +(test-rperm #(1) 2) +(test-rperm #(1 2) 0) +(test-rperm #(1 2) 1) +(test-rperm #(1 2) 2) +(test-rperm #(1 2) 3) +(test-rperm #(1 2 3) 0) +(test-rperm #(1 2 3) 1) +(test-rperm #(1 2 3) 2) +(test-rperm #(1 2 3) 3) +(test-rperm #(1 2 3) 4) +(test-rperm #(1 2 3 4) 0) +(test-rperm #(1 2 3 4) 1) +(test-rperm #(1 2 3 4) 2) +(test-rperm #(1 2 3 4) 3) +(test-rperm #(1 2 3 4) 4) +(test-rperm #(1 2 3 4) 5) +(test-rperm #(1 2 3 4 5) 0) +(test-rperm #(1 2 3 4 5) 1) +(test-rperm #(1 2 3 4 5) 2) +(test-rperm #(1 2 3 4 5) 3) +(test-rperm #(1 2 3 4 5) 4) +(test-rperm #(1 2 3 4 5) 5) +(test-rperm #(1 2 3 4 5) 5) + +(test-rperm '() 0) +(test-rperm '() 1) +(test-rperm '(1) 0) +(test-rperm '(1) 1) +(test-rperm '(1) 2) +(test-rperm '(1 2) 0) +(test-rperm '(1 2) 1) +(test-rperm '(1 2) 2) +(test-rperm '(1 2) 3) +(test-rperm '(1 2 3) 0) +(test-rperm '(1 2 3) 1) +(test-rperm '(1 2 3) 2) +(test-rperm '(1 2 3) 3) +(test-rperm '(1 2 3) 4) +(test-rperm '(1 2 3 4) 0) +(test-rperm '(1 2 3 4) 1) +(test-rperm '(1 2 3 4) 2) +(test-rperm '(1 2 3 4) 3) +(test-rperm '(1 2 3 4) 4) +(test-rperm '(1 2 3 4) 5) +(test-rperm '(1 2 3 4 5) 0) +(test-rperm '(1 2 3 4 5) 1) +(test-rperm '(1 2 3 4 5) 2) +(test-rperm '(1 2 3 4 5) 3) +(test-rperm '(1 2 3 4 5) 4) +(test-rperm '(1 2 3 4 5) 5) +(test-rperm '(1 2 3 4 5) 5) + +(test-rperm "" 0) +(test-rperm "" 1) +(test-rperm "1" 0) +(test-rperm "1" 1) +(test-rperm "1" 2) +(test-rperm "12" 0) +(test-rperm "12" 1) +(test-rperm "12" 2) +(test-rperm "12" 3) +(test-rperm "123" 0) +(test-rperm "123" 1) +(test-rperm "123" 2) +(test-rperm "123" 3) +(test-rperm "123" 4) +(test-rperm "1234" 0) +(test-rperm "1234" 1) +(test-rperm "1234" 2) +(test-rperm "1234" 3) +(test-rperm "1234" 4) +(test-rperm "1234" 5) +(test-rperm "12345" 0) +(test-rperm "12345" 1) +(test-rperm "12345" 2) +(test-rperm "12345" 3) +(test-rperm "12345" 4) +(test-rperm "12345" 5) +(test-rperm "12345" 5) + +(mtest + (rperm #() -1) :error + (rperm #(1) -1) :error + (rperm () -1) :error + (rperm '(1) -1) :error + (rperm "" -1) :error + (rperm "a" -1) :error) + +(mtest + (comb "a".."c" 2) (("a" "b") ("a" "c") ("b" "c")) + (rcomb "a".."c" 2) (("a" "a") ("a" "b") ("a" "c") + ("b" "b") ("b" "c") ("c" "c")) + (perm "a".."c" 2) (("a" "b") ("a" "c") ("b" "a") + ("b" "c") ("c" "a") ("c" "b")) + (rperm "a".."c" 2) (("a" "a") ("a" "b") ("a" "c") + ("b" "a") ("b" "b") ("b" "c") + ("c" "a") ("c" "b") ("c" "c"))) diff --git a/tests/015/esc.tl b/tests/015/esc.tl new file mode 100644 index 00000000..cf3619c8 --- /dev/null +++ b/tests/015/esc.tl @@ -0,0 +1,39 @@ +(load "../common") + +(mtest + (str-esc "$*." "~" "") "" + (str-esc "$*." "~" "a") "a" + (str-esc "$*." "~" "~") "~" + (str-esc "$*." "~" "*") "~*" + (str-esc "$*." "~" ".") "~.") + +(mtest + (str-esc "$*." "~" "aa") "aa" + (str-esc "$*." "~" "a~") "a~" + (str-esc "$*." "~" "a$") "a~$" + (str-esc "$*." "~" "a*") "a~*" + (str-esc "$*." "~" "a.") "a~.") + +(mtest + (str-esc "$*." "~" "~a") "~a" + (str-esc "$*." "~" "$a") "~$a" + (str-esc "$*." "~" "*a") "~*a" + (str-esc "$*." "~" ".a") "~.a") + +(mtest + (str-esc "$*." "~" "a~b") "a~b" + (str-esc "$*." "~" "a$b") "a~$b" + (str-esc "$*." "~" "a*b") "a~*b" + (str-esc "$*." "~" "a.b") "a~.b") + +(mtest + (str-esc "$*." "~" "~a~") "~a~" + (str-esc "$*." "~" "$a$") "~$a~$" + (str-esc "$*." "~" "*a*") "~*a~*" + (str-esc "$*." "~" ".a.") "~.a~.") + +(test + (str-esc "$*." "~" "$*.a$*.b") "~$~*~.a~$~*~.b") + +(test + (str-esc "<>" "<" "(<<>>)") "(<<<<<><>)") diff --git a/tests/015/lazy-str.tl b/tests/015/lazy-str.tl new file mode 100644 index 00000000..bfcd6328 --- /dev/null +++ b/tests/015/lazy-str.tl @@ -0,0 +1,98 @@ +(load "../common") + +(defvarl words '#"the quick") + +(defvarl lz0 (lazy-str words)) + +(test (lazy-str-get-trailing-list (copy lz0) 0) #"the quick") +(test (lazy-str-get-trailing-list (copy lz0) 1) #"he quick") +(test (lazy-str-get-trailing-list (copy lz0) 2) #"e quick") +(test (lazy-str-get-trailing-list (copy lz0) 3) ("" . #"quick")) +(test (lazy-str-get-trailing-list (copy lz0) 4) #"quick") +(test (lazy-str-get-trailing-list (copy lz0) 5) #"uick") +(test (lazy-str-get-trailing-list (copy lz0) 6) #"ick") +(test (lazy-str-get-trailing-list (copy lz0) 7) #"ck") +(test (lazy-str-get-trailing-list (copy lz0) 8) #"k") +(test (lazy-str-get-trailing-list (copy lz0) 9) ("")) +(test (lazy-str-get-trailing-list (copy lz0) 10) ()) +(test (lazy-str-get-trailing-list (copy lz0) 11) ()) + +(defvarl lz1 (lazy-str words ":")) + +(test (lazy-str-get-trailing-list (copy lz1) 0) #"the quick") +(test (lazy-str-get-trailing-list (copy lz1) 1) #"he quick") +(test (lazy-str-get-trailing-list (copy lz1) 2) #"e quick") +(test (lazy-str-get-trailing-list (copy lz1) 3) ("" . #"quick")) +(test (lazy-str-get-trailing-list (copy lz1) 4) #"quick") +(test (lazy-str-get-trailing-list (copy lz1) 5) #"uick") +(test (lazy-str-get-trailing-list (copy lz1) 6) #"ick") +(test (lazy-str-get-trailing-list (copy lz1) 7) #"ck") +(test (lazy-str-get-trailing-list (copy lz1) 8) #"k") +(test (lazy-str-get-trailing-list (copy lz1) 9) ("")) +(test (lazy-str-get-trailing-list (copy lz1) 10) ()) +(test (lazy-str-get-trailing-list (copy lz1) 11) ()) + +(test [(copy lz1) 0..0] "") +(test [(copy lz1) 0..1] "t") +(test [(copy lz1) 0..2] "th") +(test [(copy lz1) 0..3] "the") +(test [(copy lz1) 0..4] "the:") +(test [(copy lz1) 0..5] "the:q") +(test [(copy lz1) 0..6] "the:qu") +(test [(copy lz1) 0..7] "the:qui") +(test [(copy lz1) 0..8] "the:quic") +(test [(copy lz1) 0..9] "the:quick") +(test [(copy lz1) 0..10] "the:quick:") +(test [(copy lz1) 0..11] "the:quick:") + +(defvarl lz2 (lazy-str '#"the quick brown fox" ":" 2)) + +(test (lazy-str-get-trailing-list (copy lz2) 0) #"the quick brown fox") +(test (lazy-str-get-trailing-list (copy lz2) 1) #"he quick brown fox") +(test (lazy-str-get-trailing-list (copy lz2) 2) #"e quick brown fox") +(test (lazy-str-get-trailing-list (copy lz2) 3) ("" . #"quick brown fox")) +(test (lazy-str-get-trailing-list (copy lz2) 4) #"quick brown fox") +(test (lazy-str-get-trailing-list (copy lz2) 5) #"uick brown fox") +(test (lazy-str-get-trailing-list (copy lz2) 6) #"ick brown fox") +(test (lazy-str-get-trailing-list (copy lz2) 7) #"ck brown fox") +(test (lazy-str-get-trailing-list (copy lz2) 8) #"k brown fox") +(test (lazy-str-get-trailing-list (copy lz2) 9) ("" . #"brown fox")) +(test (lazy-str-get-trailing-list (copy lz2) 10) #"brown fox") +(test (lazy-str-get-trailing-list (copy lz2) 11) #"brown fox") + +(test [(copy lz2) 0..0] "") +(test [(copy lz2) 0..1] "t") +(test [(copy lz2) 0..2] "th") +(test [(copy lz2) 0..3] "the") +(test [(copy lz2) 0..4] "the:") +(test [(copy lz2) 0..5] "the:q") +(test [(copy lz2) 0..6] "the:qu") +(test [(copy lz2) 0..7] "the:qui") +(test [(copy lz2) 0..8] "the:quic") +(test [(copy lz2) 0..9] "the:quick") +(test [(copy lz2) 0..10] "the:quick:") +(test [(copy lz2) 0..11] "the:quick:") + +(defvarl lz3 (lazy-str words "")) + +(test (lazy-str-get-trailing-list (copy lz3) 0) #"t h e quick") +(test (lazy-str-get-trailing-list (copy lz3) 1) #"h e quick") +(test (lazy-str-get-trailing-list (copy lz3) 2) #"e quick") +(test (lazy-str-get-trailing-list (copy lz3) 3) #"q u i c k") +(test (lazy-str-get-trailing-list (copy lz3) 4) #"u i c k") +(test (lazy-str-get-trailing-list (copy lz3) 5) #"i c k") +(test (lazy-str-get-trailing-list (copy lz3) 6) #"c k") +(test (lazy-str-get-trailing-list (copy lz3) 7) #"k") +(test (lazy-str-get-trailing-list (copy lz3) 8) ()) +(test (lazy-str-get-trailing-list (copy lz3) 9) ()) + +(test [(copy lz3) 0..0] "") +(test [(copy lz3) 0..1] "t") +(test [(copy lz3) 0..2] "th") +(test [(copy lz3) 0..3] "the") +(test [(copy lz3) 0..4] "theq") +(test [(copy lz3) 0..5] "thequ") +(test [(copy lz3) 0..6] "thequi") +(test [(copy lz3) 0..7] "thequic") +(test [(copy lz3) 0..8] "thequick") +(test [(copy lz3) 0..9] "thequick") diff --git a/tests/015/match-str.tl b/tests/015/match-str.tl new file mode 100644 index 00000000..2ce34b8f --- /dev/null +++ b/tests/015/match-str.tl @@ -0,0 +1,69 @@ +(load "../common") + +(defun lz (str) + (lazy-str (spl "" str) "")) + +(defun lz* (str) + (lazy-str (append (spl "" str) 42) "")) + +(mtest + (match-str "" "") 0 + (match-str "a" "a") 1 + (match-str "a" "") 0 + (match-str "a" "" 1) 1 + (match-str "a" "" 2) nil + (match-str "abc" "c" 2) 3 + (match-str "abc" "b" 1) 2 + (match-str "abc" "a" 0) 1 + (match-str "abc" "b" 2) nil + (match-str "abc" "a" 1) nil + (match-str "abc" "c" 0) nil + (match-str "abc" "c" 3) nil + (match-str "abc" "c" 4) nil + (match-str "abc" "abcd") nil) + +(mtest + (match-str (lz* "abc#") "c" 2) 3 + (match-str "abc#" (lz "c") 2) 3 + (match-str (lz* "abc#") (lz "c") 2) 3 + (match-str (lz "abc") (lz "c") 2) 3 + (match-str (lz "abc") (lz "b") 1) 2 + (match-str (lz "abc") (lz "a") 0) 1 + (match-str (lz "abc") (lz "b") 2) nil + (match-str (lz "abc") (lz "a") 1) nil + (match-str (lz "abc") (lz "c") 0) nil + (match-str (lz "abc") (lz "c") 3) nil + (match-str (lz "abc") (lz "c") 4) nil + (match-str (lz "abc") (lz "abcd")) nil) + +(mtest + (match-str "" "" -1) nil + (match-str "a" "" -1) 1 + (match-str "a" "a" -1) 0 + (match-str "ab" "a" -1) nil + (match-str "ab" "a" -2) 0 + (match-str "abc" "abc" -1) 0 + (match-str "abc" "c" -1) 2 + (match-str "abc" "b" -2) 1 + (match-str "abc" "a" -3) 0 + (match-str "abc" "a" -4) nil + (match-str "abcd" "cd" -1) 2 + (match-str "abcd" "bc" -2) 1 + (match-str "abcd" "ab" -3) 0 + (match-str "abcd" "ab" -4) nil + (match-str "abcd" "ab" -5) nil + (match-str (lz "abcd") "cd" -1) 2 + (match-str (lz "abcd") "bc" -2) 1 + (match-str (lz "abcd") "ab" -3) 0 + (match-str (lz "abcd") "ab" -4) nil + (match-str (lz "abcd") "ab" -5) nil + (match-str "abcd" (lz "cd") -1) 2 + (match-str "abcd" (lz "bc") -2) 1 + (match-str "abcd" (lz "ab") -3) 0 + (match-str "abcd" (lz "ab") -4) nil + (match-str "abcd" (lz "ab") -5) nil + (match-str (lz "abcd") (lz "cd") -1) 2 + (match-str (lz "abcd") (lz "bc") -2) 1 + (match-str (lz "abcd") (lz "ab") -3) 0 + (match-str (lz "abcd") (lz "ab") -4) nil + (match-str (lz "abcd") (lz "ab") -5) nil) diff --git a/tests/015/split.expected b/tests/015/split.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/015/split.expected +++ /dev/null diff --git a/tests/015/split.tl b/tests/015/split.tl index ae77a642..1cb13647 100644 --- a/tests/015/split.tl +++ b/tests/015/split.tl @@ -194,3 +194,120 @@ (mtest (tok-str "abcacabcac" #/ab?/) #"ab a ab a" (tok-str "abcacabcac" #/ab?/ t) ("" "ab" "c" "a" "c" "ab" "c" "a" "c")) + +(mtest + (tok-str "" #/[^,]/ : 0) () + (tok-str "a,b,c" #/[^,]/ : 0) ("a,b,c") + (tok-str "a,b,c" #/[^,]/ : 1) ("a" ",b,c") + (tok-str "a,b,c" #/[^,]/ : 2) ("a" "b" ",c") + (tok-str "a,b,c" #/[^,]/ : 3) #"a b c" + (tok-str "a,b,c" #/[^,]/ : 4) #"a b c") + +(mtest + (tok-str "a,b,c" #/[^,]/ t 0) ("a,b,c") + (tok-str "a,b,c" #/[^,]/ t 1) ("" "a" ",b,c") + (tok-str "a,b,c" #/[^,]/ t 2) ("" "a" "," "b" ",c") + (tok-str "a,b,c" #/[^,]/ t 3) ("" "a" "," "b" "," "c" "") + (tok-str "a,b,c" #/[^,]/ t 4) ("" "a" "," "b" "," "c" "")) + +(mtest + (tok #/[^,]/ "a,b,c") #"a b c" + (tokn : #/[^,]/ "a,b,c") :error + (tokn nil #/[^,]/ "a,b,c") :error + (tokn 0 #/[^,]/ "a,b,c") ("a,b,c") + (tokn 1 #/[^,]/ "a,b,c") ("a" ",b,c") + (tokn 2 #/[^,]/ "a,b,c") ("a" "b" ",c") + (tokn 3 #/[^,]/ "a,b,c") ("a" "b" "c") + (tokn 4 #/[^,]/ "a,b,c") ("a" "b" "c")) + +(mtest + (tokn 0 #/[^,]/ t "a,b,c") ("a,b,c") + (tokn 1 #/[^,]/ t "a,b,c") ("" "a" ",b,c") + (tokn 2 #/[^,]/ t "a,b,c") ("" "a" "," "b" ",c") + (tokn 3 #/[^,]/ t "a,b,c") ("" "a" "," "b" "," "c" "") + (tokn 4 #/[^,]/ t "a,b,c") ("" "a" "," "b" "," "c" "")) + +(mtest + (join) "" + (join "") "" + (join "" "") "" + (join #\a) "a" + (join "a") "a" + (join #\a "b") "ab" + (join "a" #\b) "ab" + (join #\a #\b) "ab" + (join "a" "b") "ab" + (join "a" "b" "cde") "abcde") + +(mtest + (join-with #\a) "" + (join-with #\a #\b) "b" + (join-with #\a "b") "b" + (join-with "a") "" + (join-with "a" #\b) "b" + (join-with "a" "b") "b" + (join-with "a" "b") "b" + (join-with "--" "b" "c" "d") "b--c--d" + (join-with #\- "b" "c" "d") "b-c-d") + +(mtest + (split-str "abc" "" : 0) ("abc") + (split-str "abc" "" : 1) ("a" "bc") + (split-str "abc" "" : 2) ("a" "b" "c") + (split-str "abc" "" : 3) ("a" "b" "c") + (split-str "abc" "" : -1) :error) + +(mtest + (split-str "abc" "" t 0) ("abc") + (split-str "abc" "" t 1) ("a" "" "bc") + (split-str "abc" "" t 2) ("a" "" "b" "" "c") + (split-str "abc" "" t 3) ("a" "" "b" "" "c")) + +(mtest + (split-str "a,b,c" "," : 0) ("a,b,c") + (split-str "a,b,c" "," : 1) ("a" "b,c") + (split-str "a,b,c" "," : 2) ("a" "b" "c") + (split-str "a,b,c" "," : 3) ("a" "b" "c")) + +(mtest + (split-str "a,b,c" "," t 0) ("a,b,c") + (split-str "a,b,c" "," t 1) ("a" "," "b,c") + (split-str "a,b,c" "," t 2) ("a" "," "b" "," "c") + (split-str "a,b,c" "," t 3) ("a" "," "b" "," "c")) + +(mtest + (split-str "a12b34c567d" #/[0-9]+/ : 0) ("a12b34c567d") + (split-str "a12b34c567d" #/[0-9]+/ : 1) ("a" "b34c567d") + (split-str "a12b34c567d" #/[0-9]+/ : 2) ("a" "b" "c567d") + (split-str "a12b34c567d" #/[0-9]+/ : 3) ("a" "b" "c" "d") + (split-str "a12b34c567d" #/[0-9]+/ : 4) ("a" "b" "c" "d")) + +(mtest + (split-str "a12b34c567d" #/[0-9]+/ t 0) ("a12b34c567d") + (split-str "a12b34c567d" #/[0-9]+/ t 1) ("a" "12" "b34c567d") + (split-str "a12b34c567d" #/[0-9]+/ t 2) ("a" "12" "b" "34" "c567d") + (split-str "a12b34c567d" #/[0-9]+/ t 3) ("a" "12" "b" "34" "c" "567" "d") + (split-str "a12b34c567d" #/[0-9]+/ t 4) ("a" "12" "b" "34" "c" "567" "d")) + +(mtest + (spl "," "a,b,c") #"a b c" + (spln : "," "a,b,c") :error + (spln nil "," "a,b,c") :error + (spln 0 "," "a,b,c") ("a,b,c") + (spln 1 "," "a,b,c") ("a" "b,c") + (spln 2 "," "a,b,c") ("a" "b" "c") + (spln 3 "," "a,b,c") ("a" "b" "c") + (spln 4 "," "a,b,c") ("a" "b" "c")) + +(mtest + (cat-str '()) "" + (cat-str '() "-") "" + (cat-str '(()) "-") "" + (cat-str '((()) ()) "-") "" + (cat-str '((()) #()) "-") "" + (cat-str '((("a" ("b")) #(#\c))) "-") "a-b-c") + +(mtest + (join-with "--" '()) "" + (join-with "--" '(("b"))) "b" + (join-with "--" '("b" #(("c") ()) "d")) "b--c--d") diff --git a/tests/015/str.tl b/tests/015/str.tl new file mode 100644 index 00000000..c0d8dc58 --- /dev/null +++ b/tests/015/str.tl @@ -0,0 +1,28 @@ +(load "../common") + +(mtest + (str "x") :error + (str 0) "" + (str 0 5) :error + (str 0 "abcd") "" + (str 0 "") "" + (str 0 #\x) "" + (str -1) :error + (str -1 #\x) :error + (str -1 "") :error + (str -1 "abc") :error) + +(mtest + (str 10) " " + (str 10 "") " " + (str 10 #\a) "aaaaaaaaaa" + (str 10 "a") "aaaaaaaaaa" + (str 10 "ab") "ababababab" + (str 10 "abc") "abcabcabca" + (str 10 "abcd") "abcdabcdab" + (str 10 "abcde") "abcdeabcde" + (str 10 "abcdef") "abcdefabcd" + (str 10 "abcdefghij") "abcdefghij" + (str 10 "abcdefghijk") "abcdefghij" + (str 10 "abcdefghijklmnopqrst") "abcdefghij" + (str 10 "abcdefghijklmnopqrstuvwxyz") "abcdefghij") diff --git a/tests/015/trie.tl b/tests/015/trie.tl new file mode 100644 index 00000000..c145c060 --- /dev/null +++ b/tests/015/trie.tl @@ -0,0 +1,58 @@ +(load "../common") + +(defvarl tr0 (make-trie)) +(defvarl tr1 (make-trie)) + +(defvarl dat ; '#"aaa aab aac aba abb abc caa cab cac") + '("2" "3" "5" "7" "11" "13" "17" "19" "23" "29" "31" "37" "41" + "43" "47" "53" "59" "61" "67" "71" "73" "79" "83" "89" "97" "101" + "103" "107" "109" "113" "127" "131" "137" "139" "149" "151" "157" + "163" "167" "173" "179" "181" "191" "193" "197" "199" "211" "223" + "227" "229" "233" "239" "241" "251" "257" "263" "269" "271" "277" + "281" "283" "293" "307" "311" "313" "317" "331" "337" "347" "349" + "353" "359" "367" "373" "379" "383" "389" "397" "401" "409" "419" + "421" "431" "433" "439" "443" "449" "457" "461" "463" "467" "479" + "487" "491" "499" "503" "509" "521" "523" "541" "547" "557" "563" + "569" "571" "577" "587" "593" "599" "601" "607" "613" "617" "619" + "631" "641" "643" "647" "653" "659" "661" "673" "677" "683" "691" + "701" "709" "719" "727" "733" "739" "743" "751" "757" "761" "769" + "773" "787" "797" "809" "811" "821" "823" "827" "829" "839" "853" + "857" "859" "863" "877" "881" "883" "887" "907" "911" "919" "929" + "937" "941" "947" "953" "967" "971" "977" "983" "991" "997")) + +(defvarl enu [mapcar tostring (range* 0 (len dat))]) +(defvarl ndt [mapcar (op mapcar (op + 64)) dat]) +(defvarl fdt [mapcar (ret `x@{1}y`) dat]) +(defvarl fen [mapcar (ret `x@{1}y`) enu]) + +(each ((d dat) + (n enu)) + (trie-add tr0 d n) + (trie-add tr1 d n)) + +(trie-compress tr1) + +(defvarl rx0 (regex-compile (regex-from-trie tr0))) +(defvarl rx1 (regex-compile (regex-from-trie tr1))) + +(mvtest + (build (each ((d dat)) (add (filter-string-tree tr0 d)))) enu + (build (each ((x ndt)) (add (filter-string-tree tr0 x)))) ndt + (build (each ((f fdt)) (add (filter-string-tree tr0 f)))) fen) + +(mvtest + (build (each ((d dat)) (add (filter-string-tree tr1 d)))) enu + (build (each ((x ndt)) (add (filter-string-tree tr1 x)))) ndt + (build (each ((f fdt)) (add (filter-string-tree tr1 f)))) fen) + +(mvtest + (build (each ((d dat)) (add [rx0 d]))) dat + (build (each ((n ndt)) (add [rx0 n]))) (repeat '(nil) (len dat))) + +(mvtest + (build (each ((d dat)) (add [rx1 d]))) dat + (build (each ((n ndt)) (add [rx1 n]))) (repeat '(nil) (len dat))) + +(mtest + (regex-from-trie (make-trie)) t + (regex-from-trie (trie-compress (make-trie))) t) diff --git a/tests/015/trim.tl b/tests/015/trim.tl new file mode 100644 index 00000000..da1fc0c1 --- /dev/null +++ b/tests/015/trim.tl @@ -0,0 +1,41 @@ +(load "../common") + +(mtest + (trim-left "" "") "" + (trim-left 1 "") :error + (trim-left "" 1) :error + (trim-left 1 1) :error) + +(mtest + (trim-left "" "abc") "abc" + (trim-left "a" "abc") "bc" + (trim-left "ab" "abc") "c" + (trim-left "abc" "abc") "" + (trim-left "abcd" "abc") "abc" + (trim-left "z" "abc") "abc") + +(mtest + (trim-left #// "abc") "abc" + (trim-left #/./ "abc") "bc" + (trim-left #/../ "abc") "c" + (trim-left #/.../ "abc") "" + (trim-left #/.*/ "abc") "" + (trim-left #/..../ "abc") "abc" + (trim-left #/z/ "abc") "abc") + +(mtest + (trim-right "" "abc") "abc" + (trim-right "c" "abc") "ab" + (trim-right "bc" "abc") "a" + (trim-right "abc" "abc") "" + (trim-right "xabc" "abc") "abc" + (trim-right "z" "abc") "abc") + +(mtest + (trim-right #// "abc") "abc" + (trim-right #/./ "abc") "ab" + (trim-right #/../ "abc") "a" + (trim-right #/.../ "abc") "" + (trim-right #/.*/ "abc") "" + (trim-right #/..../ "abc") "abc" + (trim-right #/z/ "abc") "abc") diff --git a/tests/016/arith.expected b/tests/016/arith.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/016/arith.expected +++ /dev/null diff --git a/tests/016/arith.tl b/tests/016/arith.tl index 6a99b24a..d67b9908 100644 --- a/tests/016/arith.tl +++ b/tests/016/arith.tl @@ -71,3 +71,344 @@ (test [apply bracket '(15 10 20 30)] 1) (test [apply bracket '(25 10 20 30)] 2) (test [apply bracket '(30 10 20 30)] 3) + +(test (typeof fixnum-max) fixnum) +(test (typeof (succ fixnum-max)) bignum) +(test (typeof fixnum-min) fixnum) +(test (typeof (pred fixnum-min)) bignum) + +(test (< fixnum-min fixnum-max) t) +(test (< (pred fixnum-min) fixnum-min) t) +(test (> (succ fixnum-max) fixnum-max) t) + +(test (ffi-put #xA5 (ffi le-int16)) + #b'A500') +(test (ffi-put #xA5 (ffi be-int16)) + #b'00A5') +(test (mequal (ffi-put #xA5 (ffi int16)) + #b'A500' + #b'00A5') t) + +(test (ffi-put #xAABBCC (ffi le-int32)) + #b'CCBBAA00') +(test (ffi-put #xAABBCC (ffi be-int32)) + #b'00AABBCC') +(test (mequal (ffi-put #xAABBCC (ffi int32)) + #b'CCBBAA00' + #b'00AABBCC') t) + +(test (ffi-put #xAABBCCDDEE (ffi le-int64)) + #b'EEDDCCBBAA000000') +(test (ffi-put #xAABBCCDDEE (ffi be-int64)) + #b'000000AABBCCDDEE') +(test (mequal (ffi-put #xAABBCCDDEE (ffi int64)) + #b'EEDDCCBBAA000000' + #b'000000AABBCCDDEE') t) + +(test (ffi-get #b'A500' (ffi le-int16)) + #xA5) +(test (ffi-get #b'00A5' (ffi be-int16)) + #xA5) + + +(test (ffi-get #b'CCBBAA00' (ffi le-int32)) + #xAABBCC) +(test (ffi-get #b'00AABBCC' (ffi be-int32)) + #xAABBCC) + + +(test (ffi-get #b'EEDDCCBBAA000000' (ffi le-int64)) + #xAABBCCDDEE) +(test (ffi-get #b'000000AABBCCDDEE' (ffi be-int64)) + #xAABBCCDDEE) + +(test (mequal (ffi-put #x-8000 (ffi int16)) + #b'0080' + #b'8000') t) + +(test (ffi-get (ffi-put #x-8000 (ffi int16)) (ffi int16)) + #x-8000) + +(test (mequal (ffi-put #x-80000000 (ffi int32)) + #b'00000080' + #b'80000000') t) + +(test (ffi-get (ffi-put #x-80000000 (ffi int32)) (ffi int32)) + #x-80000000) + +(test (mequal (ffi-put #x-8000000000000000 (ffi int64)) + #b'0000000000000080' + #b'8000000000000000') t) + +(test (ffi-get (ffi-put #x-8000000000000000 (ffi int64)) (ffi int64)) + #x-8000000000000000) + +(mtest + (sum #()) 0 + (sum #(1)) 1 + (sum #(1 2)) 3 + (sum #(1 2 3)) 6 + (sum #() (op * 10)) 0 + (sum #(1) (op * 10)) 10 + (sum #(1 2) (op * 10)) 30 + (sum #(1 2 3) (op * 10)) 60 + (sum 1..10) 45 + (sum 2..10) 44) + +(mtest + (prod #()) 1 + (prod #(1)) 1 + (prod #(1 2)) 2 + (prod #(1 2 3)) 6 + (prod #() (op * 10)) 1 + (prod #(1) (op * 10)) 10 + (prod #(1 2) (op * 10)) 200 + (prod #(1 2 3) (op * 10)) 6000 + (prod 2..8) 5040 + (prod 3..8) 2520) + +(mtest + (< 1 2) t + (< 2 1) nil + (< 1.0 2) t + (< 2 1.0) nil + (< #\c #\d) t + (< #\d #\c) nil + (< 1.0 1) nil + (< #R(0 0) #R(0 0)) nil + (< #R(0 0) #R(0 1)) t + (< #R(0 0) #R(1 0)) t + (< #R(0 0) #R(1 1)) t + (< #R(1 0) #R(1 0)) nil + (< #R(1 0) #R(1 1)) t + (< 1 #R(1 0)) :error + (< #R(1 0) 1) :error + (< 1.0 #R(1 0)) :error + (< #R(1 0) 1.0) :error + (< #\c #R(1 0)) :error + (< #R(1 0) #\c) :error + (< 1 "abc") :error + (< "abc" 1) :error + (< 1 nil) :error + (< nil 1) :error + (< 1 '(1 2 3)) :error + (< '(1 2 3) 1) :error + (< 1 #(1 2 3)) :error + (< #(1 2 3) 1) :error) + +(mtest + (< #\A 66 67.0) t + (> 67.0 66 #\A) t + (>= #\A 65.0 65) t) + +(mtest + (< "abc" "abc") nil + (<= "abc" "abc") t + (< "abc" "abcd") t + (< "abc" "abd") t + (< #(1 2 3) #(1 2 3)) nil + (< #(1 2 3) #(1 2 3.0)) nil + (< #(1 2 3) #(1 2 3 4)) t + (< #(1 2 3) #(1 2 4)) t + (< #(1 2 3) '(1 2 3)) nil + (< #(1 2 3) '(1 2 3.0)) nil + (< #(1 2 3) '(1 2 3 4)) t + (< #(1 2 3) '(1 2 4)) t + (< '(1 2 3) '(1 2 3)) nil + (< '(1 2 3) '(1 2 3.0)) nil + (< '(1 2 3) '(1 2 3 4)) t + (< '(1 2 3) '(1 2 4)) t + (< '(1 2 3) #(1 2 3)) nil + (< '(1 2 3) #(1 2 3.0)) nil + (< '(1 2 3) #(1 2 3 4)) t + (< '(1 2 3) #(1 2 4)) t) + +(let ((*print-flo-precision* 14)) + (sstest + (let ((q (quantile 0.5))) + [q 0.02 0.5 0.74 3.39 0.83] + [mapcar q '(22.37 10.15 15.43 38.62 15.92 + 34.60 10.28 1.47 0.40 0.05 11.39 + 0.27 0.42 0.09 11.37)]) + (0.74 0.74 2.0616666666667 4.5517592592593 4.5517592592593 9.1519618055556 + 9.1519618055556 9.1519618055556 9.1519618055556 6.1797614914021 + 6.1797614914021 6.1797614914021 6.1797614914021 4.2462394088036 + 4.2462394088036))) + +(test + (let ((q (quantile 0))) + (cons [q] [mapcar q '(1 2 3 4 5)])) + (0.0 1.0 1.5 2.0 2.5 3.0)) + +(test + (let ((q (quantile 0 5 0.5))) + [mapcar q '(1.0 2.0 3.0 4.0 5.0 + 0.0 0.0 0.0 0.0 0.0)]) + (1.0 1.5 2.0 2.5 3.0 + 1.5 0.75 0.375 0.1875 0.09375)) + +(test + (let ((q (quantile 0 5 0.5))) + [mapcar q '(0.0 0.0 0.0 0.0 0.0 + 3.0 3.0 3.0 3.0 3.0)]) + (0.0 0.0 0.0 0.0 0.0 + 1.5 2.25 2.625 2.8125 2.90625)) + +(mtest + (sum-each ()) + 0 + (sum-each ((x nil))) + 0 + (sum-each ((x '(1 2 3)) + (y '(4 5 6))) + (* x y)) + 32 + (mul-each ()) + 1 + (mul-each ((x nil))) + 1 + (mul-each ((x '(1 2 3)) + (y '(4 5 6))) + (+ x y)) + 315 + (sum-each* ((x '(1 2 3)) + (y (cdr x))) + (* x y)) + 8 + (mul-each* ((x '(1 2 3)) + (y (cdr x))) + (+ x y)) + 15 + (sum-each ((x '(1 2 3)) + (y (cdr x))) + (* x y)) + :error + (mul-each ((x '(1 2 3)) + (y (cdr x))) + (+ x y)) + :error) + +(mtest + (sum-each-prod ()) + 0 + (sum-each-prod ((x nil))) + 0 + (sum-each-prod ((x '(4))) x) + 4 + (sum-each-prod ((x '(1 2 3)) + (y '(4 3 2))) + (* x y)) + 54 + (sum-each-prod* ((x '(1 2 3 4)) + (y (cdr x))) + (* x y)) + 90 + (sum-each-prod ((x '(1 2 3 4)) + (y (cdr x))) + (* x y)) + :error) + +(mvtest + (mul-each-prod ()) + 1 + (mul-each-prod ((x nil))) + 1 + (mul-each-prod ((x '(4))) x) + 4 + (mul-each-prod ((x '(1 2 3)) + (y '(4 3 2))) + (+ x y)) + (* (+ 1 4) (+ 1 3) (+ 1 2) + (+ 2 4) (+ 2 3) (+ 2 2) + (+ 3 4) (+ 3 3) (+ 3 2)) + (mul-each-prod* ((x '(1 2 3)) + (y (cdr x))) + (+ x y)) + (* (+ 1 2) (+ 1 3) + (+ 2 2) (+ 2 3) + (+ 3 2) (+ 3 3)) + (sum-each-prod ((x '(1 2 3)) + (y (cdr x))) + (* x y)) + :error) + +(mtest + (each-true ()) t + (each-true ((a ()))) t + (each-true ((a ())) nil) t + (each-true ((a '(1 2 3))) a) 3 + (each-true ((a '(nil 2 3))) a) nil + (each-true ((a '(1 2 3)) (b '(4 5 6))) (< a b)) t + (each-true ((a '(1 2 3)) (b '(4 0 6))) (< a b)) nil) + +(mtest + (some-true ()) nil + (some-true ((a ()))) nil + (some-true ((a ())) nil) nil + (some-true ((a '(1 2 3))) a) 1 + (some-true ((a '(nil 2 3))) a) 2 + (some-true ((a '(nil nil nil))) a) nil + (some-true ((a '(1 2 3)) (b '(4 5 6))) (< a b)) t + (some-true ((a '(1 2 3)) (b '(4 0 6))) (< a b)) t + (some-true ((a '(1 2 3)) (b '(0 1 2))) (< a b)) nil) + +(mtest + (each-false ()) t + (each-false ((a ()))) t + (each-false ((a ())) t) t + (each-false ((a '(1 2 3))) a) nil + (each-false ((a '(nil))) a) t + (each-false ((a '(nil nil))) a) t + (each-false ((a '(1 2 3)) (b '(4 5 6))) (> a b)) t + (each-false ((a '(1 2 3)) (b '(4 0 6))) (> a b)) nil) + +(mtest + (some-false ()) nil + (some-false ((a ()))) nil + (some-false ((a ())) nil) nil + (some-false ((a '(1 2 3))) a) nil + (some-false ((a '(nil 2 3))) a) t + (some-false ((a '(nil nil nil))) a) t + (some-false ((a '(1 2 3)) (b '(4 5 6))) (> a b)) t + (some-false ((a '(1 2 3)) (b '(4 0 6))) (> a b)) t + (some-false ((a '(1 2 3)) (b '(0 1 2))) (> a b)) nil) + + +(mvtest + (gcd 0 0) 0 + (gcd 0 1) 1 + (gcd 1 0) 1 + (gcd 100 0) 100 + (gcd 0 100) 100 + (gcd 0 (expt 10 60)) (expt 10 60) + (gcd (expt 10 60) 0) (expt 10 60)) + +(defun power-set (s) + (mappend* (op comb s) (range 0 (len s)))) + +(defun gcd-grind (primes) + (each-prod ((lp (cdr (power-set primes))) + (rp (cdr (power-set primes)))) + (let ((ip (isec lp rp))) + (vtest (gcd (* . lp) (* . rp)) (* . ip))))) + +(each ((x 0..64) + (y 0..64)) + (vtest (gcd (ash 1 x) (ash 1 y)) (ash 1 (min x y))) + (vtest (gcd (ash 3 x) (ash 5 y)) (ash 1 (min x y))) + (vtest (gcd (ash 6 x) (ash 15 y)) (ash 3 (min x y)))) + +(gcd-grind '(2 3 5 7 11 13 17 19 23)) + +(gcd-grind '(2 3 5 4294967291 4294967311 4294967357 4294967371)) + +(test + (build (each-prod* ((i '(b c)) (j (cons 'a i))) (add (list i j)))) + ((b a) (b b) (b c) (c a) (c b) (c c))) + +(mtest + (arithp #\a) t + (arithp 42) t + (arithp 3.14) t + (arithp (expt 2 200)) t + (arithp #R(nil nil)) t) diff --git a/tests/016/conv.tl b/tests/016/conv.tl new file mode 100644 index 00000000..34f5b7c7 --- /dev/null +++ b/tests/016/conv.tl @@ -0,0 +1,50 @@ +(load "../common.tl") + +(each ((b 2..36)) + (mtest + (int-str "" b) nil + (int-str "$" b) nil + (int-str "-" b) nil + (int-str "+" b) nil + (int-str "0" b) 0 + (int-str "00" b) 0 + (int-str "0x" b) 0 + (int-str "0x3" b) 0 + (int-str "0xz" b) 0)) + +(mtest + (int-str "+123") 123 + (int-str "-123") -123 + (int-str "0123") 123 + (int-str "00123") 123 + (int-str "999999999999999999999999999999") 999999999999999999999999999999 + (int-str "+999999999999999999999999999999") 999999999999999999999999999999 + (int-str "-999999999999999999999999999999") -999999999999999999999999999999) + +(let ((c #\c)) + (mtest + (int-str "+123" c) 123 + (int-str "-123" c) -123 + (int-str "0123" c) 83 + (int-str "00123" c) 83 + (int-str "0x123" c) 291 + (int-str "-0x123" c) -291 + (int-str "+0xFFFFFFFFFFFFFFFFFFFF" c) #xFFFFFFFFFFFFFFFFFFFF + (int-str "-0xFFFFFFFFFFFFFFFFFFFF" c) #x-FFFFFFFFFFFFFFFFFFFF)) + +(mtest + (int-str "zZz" 35) nil + (int-str "zZz" 36) 46655 + (int-str "-zZz" 36) -46655 + (int-str "+zZz" 36) 46655 + (int-str "+0zZz" 36) 46655 + (int-str "-0zZz" 36) -46655 + (int-str "0zZz" 36) 46655 + (int-str "1" 36) 1 + (int-str "10" 36) 36 + (int-str "100" 36) 1296 + (int-str "zzzzzzzzzzzzzzzzzzzzzzzz" 36) 22452257707354557240087211123792674815 + (int-str "-zzzzzzzzzzzzzzzzzzzzzzzz" 36) -22452257707354557240087211123792674815 + (int-str "0zzzzzzzzzzzzzzzzzzzzzzzz" 36) 22452257707354557240087211123792674815 + (int-str "-0zzzzzzzzzzzzzzzzzzzzzzzz" 36) -22452257707354557240087211123792674815 + (int-str "+0zzzzzzzzzzzzzzzzzzzzzzzz" 36) 22452257707354557240087211123792674815) diff --git a/tests/016/ud-arith.expected b/tests/016/ud-arith.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/016/ud-arith.expected +++ /dev/null diff --git a/tests/016/ud-arith.tl b/tests/016/ud-arith.tl index 052fcaed..8a8e50df 100644 --- a/tests/016/ud-arith.tl +++ b/tests/016/ud-arith.tl @@ -65,7 +65,53 @@ (:method ash (me arg) ^(ash ,me.v ,arg)) (:method bit (me arg) ^(bit ,me.v ,arg)) (:method width (me) ^(width ,me.v)) - (:method logcount (me) ^(logcount ,me.v))) + (:method logcount (me) ^(logcount ,me.v)) + (:method cbrt (me) ^(cbrt ,me.v)) + (:method erf (me) ^(erf ,me.v)) + (:method erfc (me) ^(erfc ,me.v)) + (:method exp10 (me) ^(exp10 ,me.v)) + (:method exp2 (me) ^(exp2 ,me.v)) + (:method expm1 (me) ^(expm1 ,me.v)) + (:method gamma (me) ^(gamma ,me.v)) + (:method j0 (me) ^(j0 ,me.v)) + (:method j1 (me) ^(j1 ,me.v)) + (:method lgamma (me) ^(lgamma ,me.v)) + (:method log1p (me) ^(log1p ,me.v)) + (:method logb (me) ^(logb ,me.v)) + (:method nearbyint (me) ^(nearbyint ,me.v)) + (:method rint (me) ^(rint ,me.v)) + (:method significand (me) ^(significand ,me.v)) + (:method tgamma (me) ^(tgamma ,me.v)) + (:method y0 (me) ^(y0 ,me.v)) + (:method y1 (me) ^(y1 ,me.v)) + (:method copysign (me arg) ^(copysign ,me.v ,arg)) + (:method drem (me arg) ^(drem ,me.v ,arg)) + (:method fdim (me arg) ^(fdim ,me.v ,arg)) + (:method fmax (me arg) ^(fmax ,me.v ,arg)) + (:method fmin (me arg) ^(fmin ,me.v ,arg)) + (:method hypot (me arg) ^(hypot ,me.v ,arg)) + (:method jn (me arg) ^(jn ,me.v ,arg)) + (:method ldexp (me arg) ^(ldexp ,me.v ,arg)) + (:method nextafter (me arg) ^(nextafter ,me.v ,arg)) + (:method remainder (me arg) ^(remainder ,me.v ,arg)) + (:method scalb (me arg) ^(scalb ,me.v ,arg)) + (:method scalbln (me arg) ^(scalbln ,me.v ,arg)) + (:method yn (me arg) ^(yn ,me.v ,arg)) + (:method r-copysign (me arg) ^(copysign ,arg ,me.v)) + (:method r-drem (me arg) ^(drem ,arg ,me.v)) + (:method r-fdim (me arg) ^(fdim ,arg ,me.v)) + (:method r-fmax (me arg) ^(fmax ,arg ,me.v)) + (:method r-fmin (me arg) ^(fmin ,arg ,me.v)) + (:method r-hypot (me arg) ^(hypot ,arg ,me.v)) + (:method r-jn (me arg) ^(jn ,arg ,me.v)) + (:method r-ldexp (me arg) ^(ldexp ,arg ,me.v)) + (:method r-nextafter (me arg) ^(nextafter ,arg ,me.v)) + (:method r-remainder (me arg) ^(remainder ,arg ,me.v)) + (:method r-scalb (me arg) ^(scalb ,arg ,me.v)) + (:method r-scalbln (me arg) ^(scalbln ,arg ,me.v)) + (:method r-yn (me arg) ^(yn ,arg ,me.v)) + (:method tofloat (me) ^(tofloat ,me.v)) + (:method toint (me) ^(toint ,me.v))) (defvarl n (new numbase v 1)) @@ -138,3 +184,51 @@ (test (ash n 0) (ash 1 0)) (test (width n) (width 1)) (test (logcount n) (logcount 1)) +(test (cbrt n) (cbrt 1)) +(test (erf n) (erf 1)) +(test (erfc n) (erfc 1)) +(test (exp10 n) (exp10 1)) +(test (exp2 n) (exp2 1)) +(test (expm1 n) (expm1 1)) +(test (gamma n) (gamma 1)) +(test (j0 n) (j0 1)) +(test (j1 n) (j1 1)) +(test (lgamma n) (lgamma 1)) +(test (log1p n) (log1p 1)) +(test (logb n) (logb 1)) +(test (nearbyint n) (nearbyint 1)) +(test (rint n) (rint 1)) +(test (significand n) (significand 1)) +(test (tgamma n) (tgamma 1)) +(test (y0 n) (y0 1)) +(test (y1 n) (y1 1)) +(test (copysign n 0) (copysign 1 0)) +(test (drem n 0) (drem 1 0)) +(test (fdim n 0) (fdim 1 0)) +(test (fmax n 0) (fmax 1 0)) +(test (fmin n 0) (fmin 1 0)) +(test (hypot n 0) (hypot 1 0)) +(test (jn n 0) (jn 1 0)) +(test (ldexp n 0) (ldexp 1 0)) +(test (nextafter n 0) (nextafter 1 0)) +(test (remainder n 0) (remainder 1 0)) +(test (scalb n 0) (scalb 1 0)) +(test (scalbln n 0) (scalbln 1 0)) +(test (yn n 0) (yn 1 0)) +(test (copysign 0 n) (copysign 0 1)) +(test (drem 0 n) (drem 0 1)) +(test (fdim 0 n) (fdim 0 1)) +(test (fmax 0 n) (fmax 0 1)) +(test (fmin 0 n) (fmin 0 1)) +(test (hypot 0 n) (hypot 0 1)) +(test (jn 0 n) (jn 0 1)) +(test (ldexp 0 n) (ldexp 0 1)) +(test (nextafter 0 n) (nextafter 0 1)) +(test (remainder 0 n) (remainder 0 1)) +(test (scalb 0 n) (scalb 0 1)) +(test (scalbln 0 n) (scalbln 0 1)) +(test (yn 0 n) (yn 0 1)) +(test (tofloat n) (tofloat 1)) +(test (toint n) (toint 1)) + +(test (arithp n) t) diff --git a/tests/017/bitfields.tl b/tests/017/bitfields.tl new file mode 100644 index 00000000..155a8b95 --- /dev/null +++ b/tests/017/bitfields.tl @@ -0,0 +1,607 @@ +(load "../common") + +(defmacro conv-test (struct buf) + (let ((type (typeof struct))) + ^(mtest (sizeof ,type) ,(len buf) + (ffi-put ,struct (ffi ,type)) ,buf + (ffi-get ,buf (ffi ,type)) ,struct))) + +(typedef s0 (struct s0 + (a (bit 1 be-uint32)) + (nil (bit 0 uint32)) + (b (bit 1 be-uint32)))) + +(conv-test #S(s0 a 1 b 1) #b'8000000080000000') + +(typedef s1 (struct s1 + (nil (bit 0 uint32)) + (b (bit 1 be-uint32)))) + +(conv-test #S(s1 b 1) #b'80000000') + +(typedef s2 (struct s2 + (a (bit 1 be-uint32)) + (nil (bit 0 uint32)))) + +(conv-test #S(s2 a 1) #b'80000000') + +(typedef s3 (struct s3 + (b00 (bit 1 be-uint32)) (b01 (bit 1 be-uint32)) + (b02 (bit 1 be-uint32)) (b03 (bit 1 be-uint32)) + (b04 (bit 1 be-uint32)) (b05 (bit 1 be-uint32)) + (b06 (bit 1 be-uint32)) (b07 (bit 1 be-uint32)) + (b08 (bit 1 be-uint32)) (b09 (bit 1 be-uint32)) + (b10 (bit 1 be-uint32)) (b11 (bit 1 be-uint32)) + (b12 (bit 1 be-uint32)) (b13 (bit 1 be-uint32)) + (b14 (bit 1 be-uint32)) (b15 (bit 1 be-uint32)) + (b16 (bit 1 be-uint32)) (b17 (bit 1 be-uint32)) + (b18 (bit 1 be-uint32)) (b19 (bit 1 be-uint32)) + (b20 (bit 1 be-uint32)) (b21 (bit 1 be-uint32)) + (b22 (bit 1 be-uint32)) (b23 (bit 1 be-uint32)) + (b24 (bit 1 be-uint32)) (b25 (bit 1 be-uint32)) + (b26 (bit 1 be-uint32)) (b27 (bit 1 be-uint32)) + (b28 (bit 1 be-uint32)) (b29 (bit 1 be-uint32)) + (b30 (bit 1 be-uint32)) (b31 (bit 1 be-uint32)))) + +(conv-test #S(s3 b00 1 b01 1 b02 1 b03 1 b04 1 b05 1 b06 1 b07 1 + b08 1 b09 1 b10 1 b11 1 b12 1 b13 1 b14 1 b15 1 + b16 1 b17 1 b18 1 b19 1 b20 1 b21 1 b22 1 b23 1 + b24 1 b25 1 b26 1 b27 1 b28 1 b29 1 b30 1 b31 1) + #b'FFFFFFFF') + +(conv-test #S(s3 b00 1 b01 0 b02 1 b03 0 b04 1 b05 0 b06 1 b07 0 + b08 1 b09 0 b10 1 b11 0 b12 1 b13 0 b14 1 b15 0 + b16 1 b17 0 b18 1 b19 0 b20 1 b21 0 b22 1 b23 0 + b24 1 b25 0 b26 1 b27 0 b28 1 b29 0 b30 1 b31 0) + #b'AAAAAAAA') + +(conv-test #S(s3 b00 0 b01 1 b02 0 b03 1 b04 0 b05 1 b06 0 b07 1 + b08 0 b09 1 b10 0 b11 1 b12 0 b13 1 b14 0 b15 1 + b16 0 b17 1 b18 0 b19 1 b20 0 b21 1 b22 0 b23 1 + b24 0 b25 1 b26 0 b27 1 b28 0 b29 1 b30 0 b31 1) + #b'55555555') + +(conv-test #S(s3 b00 0 b01 1 b02 0 b03 1 b04 0 b05 1 b06 0 b07 1 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 1 b18 0 b19 1 b20 0 b21 1 b22 0 b23 1 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'55005500') + +(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'00000000') + +(conv-test #S(s3 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 1 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 1 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'80808080') + +(conv-test #S(s3 b00 0 b01 1 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 1 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'40404040') + +(conv-test #S(s3 b00 0 b01 0 b02 1 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 1 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 1 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'20202020') + +(conv-test #S(s3 b00 0 b01 0 b02 0 b03 1 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 1 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 1 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0) + #b'10101010') + +(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 1 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 1 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 1 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0) + #b'08080808') + +(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 0 b05 1 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 1 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 1 b30 0 b31 0) + #b'04040404') + +(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 1 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 1 b31 0) + #b'02020202') + +(conv-test #S(s3 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 1 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 1 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1) + #b'01010101') + +(conv-test #S(s3 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1 + b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0 + b16 0 b17 0 b18 1 b19 0 b20 0 b21 1 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 1 b28 1 b29 0 b30 0 b31 0) + #b'81422418') + +(conv-test #S(s3 b00 0 b01 0 b02 0 b03 1 b04 1 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 1 b11 0 b12 0 b13 1 b14 0 b15 0 + b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0 + b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1) + #b'18244281') + +(typedef s4 (struct s4 + (b00 (bit 1 le-uint32)) (b01 (bit 1 le-uint32)) + (b02 (bit 1 le-uint32)) (b03 (bit 1 le-uint32)) + (b04 (bit 1 le-uint32)) (b05 (bit 1 le-uint32)) + (b06 (bit 1 le-uint32)) (b07 (bit 1 le-uint32)) + (b08 (bit 1 le-uint32)) (b09 (bit 1 le-uint32)) + (b10 (bit 1 le-uint32)) (b11 (bit 1 le-uint32)) + (b12 (bit 1 le-uint32)) (b13 (bit 1 le-uint32)) + (b14 (bit 1 le-uint32)) (b15 (bit 1 le-uint32)) + (b16 (bit 1 le-uint32)) (b17 (bit 1 le-uint32)) + (b18 (bit 1 le-uint32)) (b19 (bit 1 le-uint32)) + (b20 (bit 1 le-uint32)) (b21 (bit 1 le-uint32)) + (b22 (bit 1 le-uint32)) (b23 (bit 1 le-uint32)) + (b24 (bit 1 le-uint32)) (b25 (bit 1 le-uint32)) + (b26 (bit 1 le-uint32)) (b27 (bit 1 le-uint32)) + (b28 (bit 1 le-uint32)) (b29 (bit 1 le-uint32)) + (b30 (bit 1 le-uint32)) (b31 (bit 1 le-uint32)))) + +(conv-test #S(s4 b00 1 b01 1 b02 1 b03 1 b04 1 b05 1 b06 1 b07 1 + b08 1 b09 1 b10 1 b11 1 b12 1 b13 1 b14 1 b15 1 + b16 1 b17 1 b18 1 b19 1 b20 1 b21 1 b22 1 b23 1 + b24 1 b25 1 b26 1 b27 1 b28 1 b29 1 b30 1 b31 1) + #b'FFFFFFFF') + +(conv-test #S(s4 b00 1 b01 0 b02 1 b03 0 b04 1 b05 0 b06 1 b07 0 + b08 1 b09 0 b10 1 b11 0 b12 1 b13 0 b14 1 b15 0 + b16 1 b17 0 b18 1 b19 0 b20 1 b21 0 b22 1 b23 0 + b24 1 b25 0 b26 1 b27 0 b28 1 b29 0 b30 1 b31 0) + #b'55555555') + +(conv-test #S(s4 b00 0 b01 1 b02 0 b03 1 b04 0 b05 1 b06 0 b07 1 + b08 0 b09 1 b10 0 b11 1 b12 0 b13 1 b14 0 b15 1 + b16 0 b17 1 b18 0 b19 1 b20 0 b21 1 b22 0 b23 1 + b24 0 b25 1 b26 0 b27 1 b28 0 b29 1 b30 0 b31 1) + #b'AAAAAAAA') + +(conv-test #S(s4 b00 0 b01 1 b02 0 b03 1 b04 0 b05 1 b06 0 b07 1 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 1 b18 0 b19 1 b20 0 b21 1 b22 0 b23 1 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'AA00AA00') + +(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'00000000') + +(conv-test #S(s4 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 1 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 1 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'01010101') + +(conv-test #S(s4 b00 0 b01 1 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 1 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'02020202') + +(conv-test #S(s4 b00 0 b01 0 b02 1 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 1 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 1 b27 0 b28 0 b29 0 b30 0 b31 0) + #b'04040404') + +(conv-test #S(s4 b00 0 b01 0 b02 0 b03 1 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 1 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 1 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0) + #b'08080808') + +(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 1 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 1 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 1 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0) + #b'10101010') + +(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 0 b05 1 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 1 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 1 b30 0 b31 0) + #b'20202020') + +(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 1 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 1 b31 0) + #b'40404040') + +(conv-test #S(s4 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 1 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 1 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1) + #b'80808080') + +(conv-test #S(s4 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1 + b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0 + b16 0 b17 0 b18 1 b19 0 b20 0 b21 1 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 1 b28 1 b29 0 b30 0 b31 0) + #b'81422418') + +(conv-test #S(s4 b00 0 b01 0 b02 0 b03 1 b04 1 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 1 b11 0 b12 0 b13 1 b14 0 b15 0 + b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0 + b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1) + #b'18244281') + +(typedef s5 (struct s5 + (b00 (bit 1 be-uint64)) (b01 (bit 1 be-uint64)) + (b02 (bit 1 be-uint64)) (b03 (bit 1 be-uint64)) + (b04 (bit 1 be-uint64)) (b05 (bit 1 be-uint64)) + (b06 (bit 1 be-uint64)) (b07 (bit 1 be-uint64)) + (b08 (bit 1 be-uint64)) (b09 (bit 1 be-uint64)) + (b10 (bit 1 be-uint64)) (b11 (bit 1 be-uint64)) + (b12 (bit 1 be-uint64)) (b13 (bit 1 be-uint64)) + (b14 (bit 1 be-uint64)) (b15 (bit 1 be-uint64)) + (b16 (bit 1 be-uint64)) (b17 (bit 1 be-uint64)) + (b18 (bit 1 be-uint64)) (b19 (bit 1 be-uint64)) + (b20 (bit 1 be-uint64)) (b21 (bit 1 be-uint64)) + (b22 (bit 1 be-uint64)) (b23 (bit 1 be-uint64)) + (b24 (bit 1 be-uint64)) (b25 (bit 1 be-uint64)) + (b26 (bit 1 be-uint64)) (b27 (bit 1 be-uint64)) + (b28 (bit 1 be-uint64)) (b29 (bit 1 be-uint64)) + (b30 (bit 1 be-uint64)) (b31 (bit 1 be-uint64)) + (b32 (bit 1 be-uint64)) (b33 (bit 1 be-uint64)) + (b34 (bit 1 be-uint64)) (b35 (bit 1 be-uint64)) + (b36 (bit 1 be-uint64)) (b37 (bit 1 be-uint64)) + (b38 (bit 1 be-uint64)) (b39 (bit 1 be-uint64)) + (b40 (bit 1 be-uint64)) (b41 (bit 1 be-uint64)) + (b42 (bit 1 be-uint64)) (b43 (bit 1 be-uint64)) + (b44 (bit 1 be-uint64)) (b45 (bit 1 be-uint64)) + (b46 (bit 1 be-uint64)) (b47 (bit 1 be-uint64)) + (b48 (bit 1 be-uint64)) (b49 (bit 1 be-uint64)) + (b50 (bit 1 be-uint64)) (b51 (bit 1 be-uint64)) + (b52 (bit 1 be-uint64)) (b53 (bit 1 be-uint64)) + (b54 (bit 1 be-uint64)) (b55 (bit 1 be-uint64)) + (b56 (bit 1 be-uint64)) (b57 (bit 1 be-uint64)) + (b58 (bit 1 be-uint64)) (b59 (bit 1 be-uint64)) + (b60 (bit 1 be-uint64)) (b61 (bit 1 be-uint64)) + (b62 (bit 1 be-uint64)) (b63 (bit 1 be-uint64)))) + +(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'0000000000000000') + +(conv-test #S(s5 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 1 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 1 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0 + b32 1 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0 + b40 1 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 1 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'8080808080808080') + +(conv-test #S(s5 b00 0 b01 1 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 1 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 1 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 1 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 0 b57 1 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'4040404040404040') + +(conv-test #S(s5 b00 0 b01 0 b02 1 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 1 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 1 b27 0 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 1 b35 0 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 0 b50 1 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 0 b57 0 b58 1 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'2020202020202020') + +(conv-test #S(s5 b00 0 b01 0 b02 0 b03 1 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 1 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 1 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 1 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 1 b52 0 b53 0 b54 0 b55 0 + b56 0 b57 0 b58 0 b59 1 b60 0 b61 0 b62 0 b63 0) + #b'1010101010101010') + +(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 1 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 1 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 1 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 1 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 1 b45 0 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 1 b53 0 b54 0 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 1 b61 0 b62 0 b63 0) + #b'0808080808080808') + +(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 1 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 1 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 1 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 0 b37 1 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 1 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 1 b54 0 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 1 b62 0 b63 0) + #b'0404040404040404') + +(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 1 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 1 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 1 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 1 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 1 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 1 b63 0) + #b'0202020202020202') + +(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 1 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 1 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1 + b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 1 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 1 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 1 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 1) + #b'0101010101010101') + +(conv-test #S(s5 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 1 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 1 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 1 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 1) + #b'8040201008040201') + +(conv-test #S(s5 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'0102040810204080') + +(typedef s6 (struct s6 + (b00 (bit 1 le-uint64)) (b01 (bit 1 le-uint64)) + (b02 (bit 1 le-uint64)) (b03 (bit 1 le-uint64)) + (b04 (bit 1 le-uint64)) (b05 (bit 1 le-uint64)) + (b06 (bit 1 le-uint64)) (b07 (bit 1 le-uint64)) + (b08 (bit 1 le-uint64)) (b09 (bit 1 le-uint64)) + (b10 (bit 1 le-uint64)) (b11 (bit 1 le-uint64)) + (b12 (bit 1 le-uint64)) (b13 (bit 1 le-uint64)) + (b14 (bit 1 le-uint64)) (b15 (bit 1 le-uint64)) + (b16 (bit 1 le-uint64)) (b17 (bit 1 le-uint64)) + (b18 (bit 1 le-uint64)) (b19 (bit 1 le-uint64)) + (b20 (bit 1 le-uint64)) (b21 (bit 1 le-uint64)) + (b22 (bit 1 le-uint64)) (b23 (bit 1 le-uint64)) + (b24 (bit 1 le-uint64)) (b25 (bit 1 le-uint64)) + (b26 (bit 1 le-uint64)) (b27 (bit 1 le-uint64)) + (b28 (bit 1 le-uint64)) (b29 (bit 1 le-uint64)) + (b30 (bit 1 le-uint64)) (b31 (bit 1 le-uint64)) + (b32 (bit 1 le-uint64)) (b33 (bit 1 le-uint64)) + (b34 (bit 1 le-uint64)) (b35 (bit 1 le-uint64)) + (b36 (bit 1 le-uint64)) (b37 (bit 1 le-uint64)) + (b38 (bit 1 le-uint64)) (b39 (bit 1 le-uint64)) + (b40 (bit 1 le-uint64)) (b41 (bit 1 le-uint64)) + (b42 (bit 1 le-uint64)) (b43 (bit 1 le-uint64)) + (b44 (bit 1 le-uint64)) (b45 (bit 1 le-uint64)) + (b46 (bit 1 le-uint64)) (b47 (bit 1 le-uint64)) + (b48 (bit 1 le-uint64)) (b49 (bit 1 le-uint64)) + (b50 (bit 1 le-uint64)) (b51 (bit 1 le-uint64)) + (b52 (bit 1 le-uint64)) (b53 (bit 1 le-uint64)) + (b54 (bit 1 le-uint64)) (b55 (bit 1 le-uint64)) + (b56 (bit 1 le-uint64)) (b57 (bit 1 le-uint64)) + (b58 (bit 1 le-uint64)) (b59 (bit 1 le-uint64)) + (b60 (bit 1 le-uint64)) (b61 (bit 1 le-uint64)) + (b62 (bit 1 le-uint64)) (b63 (bit 1 le-uint64)))) + +(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'0000000000000000') + +(conv-test #S(s6 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 1 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 1 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 1 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0 + b32 1 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0 + b40 1 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 1 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'0101010101010101') + +(conv-test #S(s6 b00 0 b01 1 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 1 b18 0 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 1 b26 0 b27 0 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 1 b34 0 b35 0 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 1 b42 0 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 0 b57 1 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'0202020202020202') + +(conv-test #S(s6 b00 0 b01 0 b02 1 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 1 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 1 b27 0 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 1 b35 0 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 0 b50 1 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 0 b57 0 b58 1 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'0404040404040404') + +(conv-test #S(s6 b00 0 b01 0 b02 0 b03 1 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 1 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 1 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 1 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 1 b52 0 b53 0 b54 0 b55 0 + b56 0 b57 0 b58 0 b59 1 b60 0 b61 0 b62 0 b63 0) + #b'0808080808080808') + +(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 1 b05 0 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 1 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 1 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 1 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 1 b45 0 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 1 b53 0 b54 0 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 1 b61 0 b62 0 b63 0) + #b'1010101010101010') + +(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 1 b06 0 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 1 b14 0 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 1 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 0 b37 1 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 1 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 1 b54 0 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 1 b62 0 b63 0) + #b'2020202020202020') + +(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 1 b07 0 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 1 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 1 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 1 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 1 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 1 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 1 b63 0) + #b'4040404040404040') + +(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 0 b15 1 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 0 b22 0 b23 1 + b24 0 b25 0 b26 0 b27 0 b28 0 b29 0 b30 0 b31 1 + b32 0 b33 0 b34 0 b35 0 b36 0 b37 0 b38 0 b39 1 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 0 b46 0 b47 1 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 0 b55 1 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 1) + #b'8080808080808080') + +(conv-test #S(s6 b00 1 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 0 + b08 0 b09 1 b10 0 b11 0 b12 0 b13 0 b14 0 b15 0 + b16 0 b17 0 b18 1 b19 0 b20 0 b21 0 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 1 b28 0 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 0 b36 1 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 0 b43 0 b44 0 b45 1 b46 0 b47 0 + b48 0 b49 0 b50 0 b51 0 b52 0 b53 0 b54 1 b55 0 + b56 0 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 1) + #b'0102040810204080') + +(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'8040201008040201') + +(conv-test #S(s6 b00 0 b01 0 b02 0 b03 0 b04 0 b05 0 b06 0 b07 1 + b08 0 b09 0 b10 0 b11 0 b12 0 b13 0 b14 1 b15 0 + b16 0 b17 0 b18 0 b19 0 b20 0 b21 1 b22 0 b23 0 + b24 0 b25 0 b26 0 b27 0 b28 1 b29 0 b30 0 b31 0 + b32 0 b33 0 b34 0 b35 1 b36 0 b37 0 b38 0 b39 0 + b40 0 b41 0 b42 1 b43 0 b44 0 b45 0 b46 0 b47 0 + b48 0 b49 1 b50 0 b51 0 b52 0 b53 0 b54 0 b55 0 + b56 1 b57 0 b58 0 b59 0 b60 0 b61 0 b62 0 b63 0) + #b'8040201008040201') + +(typedef s7 (struct s7 + (x uint8) + (b0 (bit 8 uint32)) (b1 (bit 8 uint32)) + (b2 (bit 8 uint32)) (b3 (bit 8 uint32)))) + +(conv-test #S(s7 x #xff b0 #xaa b1 #xbb b2 #xcc b3 #xdd) #b'ffaabbccdd000000') + +(typedef s8 (pack (struct s8 + (x uint8) + (b0 (bit 8 uint32)) (b1 (bit 8 uint32)) + (b2 (bit 8 uint32)) (b3 (bit 8 uint32))))) + +(conv-test #S(s8 x #xff b0 #xaa b1 #xbb b2 #xcc b3 #xdd) #b'ffaabbccdd') + +(typedef s9 (pack (struct s9 + (x uint8) + (b0 (bit 8 uint32)) (b1 (bit 8 uint32)) + (b2 (bit 8 uint32))))) + +(conv-test #S(s9 x #xff b0 #xaa b1 #xbb b2 #xcc) #b'ffaabbcc') + +(typedef s10 (struct s10 + (x uint8) + (b0 (bit 8 (pack 2 uint32))) (b1 (bit 8 (pack 2 uint32))) + (b2 (bit 8 (pack 2 uint32))))) + +(conv-test #S(s10 x #xff b0 #xaa b1 #xbb b2 #xcc) #b'ff00aa00bb00cc00') + +(typedef s11 (struct s11 + (x uint8) + (b0 (bit 8 (pack 2 uint32))) (b1 (bit 8 uint32)) + (b2 (bit 8 uint32)))) + +(conv-test #S(s11 x #xff b0 #xaa b1 #xbb b2 #xcc) #b'ff00aabbcc000000') + +(typedef s12 (struct s12 + (x (bit 7 le-uint32)) + (b0 (bit 8 (pack 1 (bit 8 le-uint32)))))) + +(conv-test #S(s12 x #x7f b0 #xff) #b'ff7f0000') + +(typedef s13 (struct s13 + (x (bit 7 le-uint32)) + (b0 (bit 8 (pack 1 (align 1 (bit 8 le-uint32))))))) + +(conv-test #S(s13 x #x7f b0 #xff) #b'7fff0000') + +(typedef s14 (pack (struct s14 + (a (bit 9 le-uint32)) + (b (bit 7 le-uint32))))) + +(conv-test #S(s14 a #x1ff b #x7f) #b'ffff') + +(typedef s15 (pack (struct s15 + (x uint8) + (a (bit 9 le-uint32)) + (b (bit 7 le-uint32))))) + +(conv-test #S(s15 x 0 a #x1ff b #x7f) #b'00ffff') + +(typedef s16 (struct s16 + (x uint8) + (a (align 2 (bit 9 le-uint32))) + (b (align 2 (bit 7 le-uint32))))) + +(conv-test #S(s16 x 0 a #x1ff b #x7f) #b'0000ff017f000000') diff --git a/tests/017/carray.tl b/tests/017/carray.tl new file mode 100644 index 00000000..1d450d1a --- /dev/null +++ b/tests/017/carray.tl @@ -0,0 +1,16 @@ +(load "../common") + +(let* ((bf (make-buf 16)) + (ca (carray-buf bf (ffi uchar)))) + (mtest + (buf-put-buf bf (make-buf 8 255) 8) #b'ffffffffffffffff' + bf #b'0000000000000000 ffffffffffffffff' + (carray-set-length ca 8) nil + (set [ca -1..10] #(1 2 3)) #(1 2 3) + bf #b'0000000000000001 ffffffffffffffff' + (set [ca 2..7] #(1 2 3)) #(1 2 3) + bf #b'0000010203010000 ffffffffffffffff' + (set [ca 3..4] #(10 11 12)) #(10 11 12) + bf #b'0000010A0B0C0301 ffffffffffffffff' + (set [ca 3..3] #(9)) #(9) + bf #b'000001090A0B0C03 ffffffffffffffff')) diff --git a/tests/017/ffi-misc.expected b/tests/017/ffi-misc.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/017/ffi-misc.expected +++ /dev/null diff --git a/tests/017/ffi-misc.tl b/tests/017/ffi-misc.tl index 1578cd2c..4d7bffab 100644 --- a/tests/017/ffi-misc.tl +++ b/tests/017/ffi-misc.tl @@ -9,3 +9,107 @@ (test (ffi-put "\x1234@@@" zar) #b'e188b440404000') (test (ffi-get (ffi-put "\x1234@@@" zar) zar) "\x1234@@@") + +(unless (meq (os-symbol) :cygwin :cygnal) + (test (ffi-get #b'EDB08100' (ffi (zarray char))) + "\xDCED\xDCB0\xDC81") + + (test (ffi-get #b'ED7F7FEDFF00' (ffi (zarray char))) + "\xDCED\x7F\x7F\xDCED\xDCFF")) + +(mtest + (typeof (ffi (enum a))) ffi-type + (typeof (ffi (enum b b0 b1 b2 (b3 -15)))) ffi-type + (typeof (ffi (enum c (c0 (expt 2 512))))) :error + (typeof (ffi (enum d d0 d0))) :error + (typeof (ffi (enum e (e0 0) (e0 1)))) :error) + +(mtest + (typeof (ffi (enumed uint16 m))) ffi-type + (typeof (ffi (enumed uint16 n n0 n1 n2 (n3 15)))) ffi-type + (typeof (ffi (enumed uint16 o (o0 (expt 2 512))))) :error + (typeof (ffi (enumed uint16 p p0 p0))) :error + (typeof (ffi (enumed uint16 q (q0 0) (q0 1)))) :error) + +(mtest + (typeof (ffi (enumed uint8 e (x 0) (y #xff)))) ffi-type + (typeof (ffi (enumed uint8 e (x -1)))) :error + (typeof (ffi (enumed uint8 e (x #x100)))) :error) + +(mtest + (typeof (ffi (enumed uint16 e (x 0) (y #xffff)))) ffi-type + (typeof (ffi (enumed uint16 e (x -1)))) :error + (typeof (ffi (enumed uint16 e (x #x10000)))) :error) + +(mtest + (typeof (ffi (enumed uint32 e (x 0) (y #xffffffff)))) ffi-type + (typeof (ffi (enumed uint32 e (x -1)))) :error + (typeof (ffi (enumed uint32 e (x #x100000000)))) :error) + +(mtest + (typeof (ffi (enumed uint64 e (x 0) (y #xffffffffffffffff)))) ffi-type + ;(typeof (ffi (enumed uint64 e (x -1)))) #:error + (typeof (ffi (enumed uint64 e (x #x10000000000000000)))) :error) + +(mtest + (typeof (ffi (enumed int8 e (x 0) (y #x7f)))) ffi-type + (typeof (ffi (enumed int8 e (x #x-81)))) :error + (typeof (ffi (enumed int8 e (x #x800)))) :error) + +(mtest + (typeof (ffi (enumed int16 e (x 0) (y #x7fff)))) ffi-type + (typeof (ffi (enumed int16 e (x #x-8001)))) :error + (typeof (ffi (enumed int16 e (x #x8000)))) :error) + +(mtest + (typeof (ffi (enumed int32 e (x 0) (y #x7fffffff)))) ffi-type + (typeof (ffi (enumed int32 e (x #x-80000001)))) :error + (typeof (ffi (enumed int32 e (x #x80000000)))) :error) + +(mtest + (typeof (ffi (enumed int64 e (x 0) (y #x7fffffffffffffff)))) ffi-type + (typeof (ffi (enumed int64 e (x #x-8000000000000001)))) :error + (typeof (ffi (enumed int64 e (x #x8000000000000000)))) :error) + +(typedef abc (struct abc + (a (enumed (bit 1 uint8) bit fals true)) + (b (enumed (bit 1 uint8) bit fals true)) + (c (enumed (bit 1 uint8) bit fals true)))) + +(mtest + (sizeof abc) 1 + (znew abc) #S(abc a fals b fals c fals)) + +(each-match ((@a @b @c) (rperm '(fals true) 3)) + (let ((s (new abc a a b b c c))) + (vtest (ffi-get (ffi-put s (ffi abc)) (ffi abc)) s))) + +(mstest + (copy-cptr (cptr-int 3)) "#<cptr: 3>" + (copy (cptr-int 3)) "#<cptr: 3>" + (copy-cptr 3) :error) + +(ffi (struct flex (x char) (y (zarray char)))) + +(mtest + (ffi-put (new flex x #\a y "bcd") (ffi (struct flex))) #b'6162636400' + (ffi-get #b'6162636400' (ffi (struct flex))) #S(flex x #\a y "bcd")) + +(defvarl %big-endian% (zerop [(ffi-put #x1 (ffi uint32)) 0])) + +(typedef foo + (struct foo + (x (bit 48 uint64)) + (y (bit 16 uint64)))) + +(if %big-endian% + (mtest + (ffi-put (new foo x 1 y 1) (ffi foo)) #b'0000000000010001' + (ffi-put (new foo x #xABCDFFFFB00B y #x1234) (ffi foo)) #b'ABCDFFFFB00B1234') + (mtest + (ffi-put (new foo x 1 y 1) (ffi foo)) #b'0100000000000100' + (ffi-put (new foo x #xABCDFFFFB00B y #x1234) (ffi foo)) #b'0BB0FFFFCDAB3412')) + +(mtest + (alignof (struct empty)) 1 + (alignof (union empty)) 1) diff --git a/tests/017/flexstruct.tl b/tests/017/flexstruct.tl new file mode 100644 index 00000000..8f91096e --- /dev/null +++ b/tests/017/flexstruct.tl @@ -0,0 +1,73 @@ +(load "../common") + +(typedef fs0 (struct fs0 + (a uint8) + (b (array char)))) + +(mtest + (sizeof fs0) 1 + (ffi-put #S(fs0 a 3 b "ABC") (ffi fs0)) #b'03414243' + (ffi-get #b'03414243' (ffi fs0)) #S(fs0 a 3 b "")) + +(defmeth fs0 length (s) + s.a) + +(mtest + (ffi-get #b'03414243' (ffi fs0)) #S(fs0 a 3 b "ABC") + (ffi-get #b'02e6bca2e5ad97' (ffi fs0)) #S(fs0 a 2 b "\xDCE6\xDCBC") + (ffi-get #b'06e6bca2e5ad97' (ffi fs0)) #S(fs0 a 6 b "漢字")) + +(typedef fs1 (struct fs1 + (a uint8) + (b (zarray char)))) + +(mtest + (sizeof fs1) 1 + (ffi-put #S(fs1 a 3 b "ABCDEF") (ffi fs1)) #b'0341424344454600' + (ffi-get #b'FF41424300' (ffi fs1)) #S(fs1 a 255 b "ABC")) + +(mtest + (ffi-get #b'0341424300' (ffi fs1)) #S(fs1 a 3 b "ABC") + (ffi-get #b'02e6bc00' (ffi fs1)) #S(fs1 a 2 b "\xDCE6\xDCBC") + (ffi-get #b'06e6bca2e5ad9700' (ffi fs1)) #S(fs1 a 6 b "漢字")) + +(typedef fs2 (struct fs2 + (a int8) + (b (array int8)))) + +(mtest + (sizeof fs2) 1 + (ffi-put #S(fs2 a 3 b "ABCD") (ffi fs2)) #b'0341424344' + (ffi-put #S(fs2 a 3 b #(65 66 67 68)) (ffi fs2)) #b'0341424344' + (ffi-get #b'FF414243' (ffi fs2)) #S(fs2 a 255 b #())) + +(defmeth fs2 length (s) + s.a) + +(mtest + (ffi-get #b'03010203' (ffi fs2)) #S(fs2 a 3 b #(1 2 3))) + +(typedef fs3 (struct fs3 + (a int8) + (b (array le-int16)))) + +(mtest + (sizeof fs3) 2 + (ffi-put #S(fs3 a 3 b "ABCD") (ffi fs3)) #b'03004100420043004400' + (ffi-put #S(fs3 a 3 b #(65 66 67 68)) (ffi fs3)) #b'03004100420043004400' + (ffi-get #b'FF414243' (ffi fs3)) #S(fs3 a 255 b #())) + +(defmeth fs3 length (s) + s.a) + +(mtest + (ffi-get #b'0300010002000300' (ffi fs3)) #S(fs3 a 3 b #(1 2 3))) + +(typedef fs4 (struct fs4 + (c int8) + (s fs0))) + +(mtest + (sizeof fs4) 2 + (ffi-put #S(fs4 c 93 s #S(fs0 a 4 b "ABCD")) (ffi fs4)) #b'5d0441424344' + (ffi-get #b'5d0441424344' (ffi fs4)) #S(fs4 c 93 s #S(fs0 a 4 b "ABCD"))) diff --git a/tests/017/glob-carray.tl b/tests/017/glob-carray.tl index 99660576..8e43266f 100644 --- a/tests/017/glob-carray.tl +++ b/tests/017/glob-carray.tl @@ -12,7 +12,7 @@ (nil int) (pathv (carray str)) (nil (array 4 cptr))))) - ((:cygnal :cygwin) + ((:cygnal :cygwin :android :bsd :openbsd) (deffi-type glob-t (struct glob-t (pathc size-t) (nil size-t) diff --git a/tests/017/glob-zarray.tl b/tests/017/glob-zarray.tl index b095e45e..a1e532fb 100644 --- a/tests/017/glob-zarray.tl +++ b/tests/017/glob-zarray.tl @@ -12,7 +12,7 @@ (nil int) (pathv (ptr-out (zarray str))) (nil (array 4 cptr))))) - ((:cygnal :cygwin) + ((:cygnal :cygwin :android :bsd :openbsd) (deffi-type glob-t (struct glob-t (pathc size-t) (nil size-t) diff --git a/tests/017/mmap.tl b/tests/017/mmap.tl new file mode 100644 index 00000000..8ec75364 --- /dev/null +++ b/tests/017/mmap.tl @@ -0,0 +1,52 @@ +(load "../common") + +(defun parent (wp mm) + (with-stream (s (open-fileno wp "w")) + (each ((i 0..1024)) + (set [mm i] i)) + (put-char #\X s))) + +(defun child (rp mm) + (let ((s (open-fileno rp "r"))) + (assert (eq (get-char s) #\X)) + (each ((i 0..1024)) + (assert (eql [mm i] i))))) + +(let ((mm (mmap (ffi uint32) 4096 + (logior prot-read prot-write) + (logior map-anon map-shared)))) + (tree-bind (rp . wp) (pipe) + (match-ecase (fork) + (0 (child rp mm) + (exit t)) + (-1 (error "fork failed")) + (@pid (parent wp mm) + (tree-bind (p . s) (wait pid) + (unless (zerop s) + (error "child failed"))))))) + +(assert (plusp page-size)) + +(let* ((rndbuf0 (random-buf page-size)) + (rndbuf1 (random-buf page-size)) + (fname "rand.bin")) + (unwind-protect + (progn + (file-put-buf fname rndbuf0) + (let* ((mm (mmap (ffi uchar) page-size + (logior prot-read prot-write) + (logior map-shared) + fname))) + (each ((i 0..page-size)) + (assert (eq [rndbuf0 i] [mm i])) + (set [mm i] [rndbuf1 i])) + (msync mm ms-sync) + (assert (equal (file-get-buf fname) rndbuf1)) + (each ((i 0..page-size)) + (set [mm i] [rndbuf0 i])) + (munmap mm)) + (assert (equal (file-get-buf fname) rndbuf0))) + (remove-path fname))) + +(unless (meq (os-symbol) :bsd :openbsd) + (test (ignerr (mmap (ffi char) 4096 prot-read map-anon)) nil)) diff --git a/tests/017/pack-align.tl b/tests/017/pack-align.tl new file mode 100644 index 00000000..a1048788 --- /dev/null +++ b/tests/017/pack-align.tl @@ -0,0 +1,112 @@ +(load "../common") + +(mtest + (alignof int) 4 + (alignof (align int)) 16 + (alignof (align 1 int)) 4 + (alignof (align 6 int)) :error + (alignof (align 8 int)) 8) + +(mtest + (alignof (pack int)) 1 + (alignof (pack 1 int)) 1 + (alignof (pack 6 int)) :error + (alignof (pack 8 int)) 8) + +(mtest + (alignof (pack 1 (align 8 int))) 8 + (alignof (align 8 (pack 1 int))) 8) + +(typedef s0 (pack (struct s0 + (a char) + (b short) + (c int) + (d longlong)))) + +(mtest + (alignof s0.a) 1 + (alignof s0.b) 1 + (alignof s0.c) 1 + (alignof s0.d) 1) + +(mtest + (offsetof s0 a) 0 + (offsetof s0 b) 1 + (offsetof s0 c) 3 + (offsetof s0 d) 7 + (sizeof s0) 15) + +(typedef s1 (pack 2 (struct s1 + (a char) + (b short) + (c int) + (d longlong)))) + +(mtest + (alignof s1.a) 2 + (alignof s1.b) 2 + (alignof s1.c) 2 + (alignof s1.d) 2) + +(mtest + (offsetof s1 a) 0 + (offsetof s1 b) 2 + (offsetof s1 c) 4 + (offsetof s1 d) 8 + (sizeof s1) 16) + +(typedef s2 (pack 32 (struct s2 + (a char) + (b short) + (c int) + (d longlong)))) + +(mtest + (alignof s2.a) 32 + (alignof s2.b) 32 + (alignof s2.c) 32 + (alignof s2.d) 32) + +(mtest + (offsetof s2 a) 0 + (offsetof s2 b) 32 + (offsetof s2 c) 64 + (offsetof s2 d) 96 + (sizeof s2) 128) + +(typedef s3 (pack 1 (struct s3 + (a char) + (b (align 2 char)) + (c (align int)) + (d longlong)))) + +(mtest + (alignof s3.a) 1 + (alignof s3.b) 2 + (alignof s3.c) 16 + (alignof s3.d) 1) + +(mtest + (offsetof s3 a) 0 + (offsetof s3 b) 2 + (offsetof s3 c) 16 + (offsetof s3 d) 20 + (sizeof s3) 32) + +(typedef s4 (align 256 s3)) + +(mtest + (sizeof s4) 32 + (alignof s4) 256) + +(typedef s5 (pack s3)) + +(mtest + (sizeof s5) 32 + (alignof s5) 1) + +(typedef s6 (pack (struct s3))) + +(mtest + (sizeof s6) 32 + (alignof s6) 1) diff --git a/tests/017/realpath.tl b/tests/017/realpath.tl index d920825f..68ee7a7f 100644 --- a/tests/017/realpath.tl +++ b/tests/017/realpath.tl @@ -1,12 +1,13 @@ (load "../common") +(when (or (memq (os-symbol) '(:cygwin :solaris :android)) + (not (path-exists-p "/usr/bin"))) + (put-string (file-get-string "tests/017/realpath.expected")) + (exit 0)) + (with-dyn-lib (libc) (deffi realpath-null "realpath" str-d (str str)) (deffi realpath-buf "realpath" str-d (str (ptr-in-d (zarray 8192 char))))) -(when (memq (os-symbol) '(:cygwin :solaris)) - (put-string (file-get-string "tests/017/realpath.expected")) - (exit 0)) - (prinl (realpath-null "/usr/bin" nil)) (prinl (realpath-buf "/usr/bin" (copy ""))) diff --git a/tests/017/setjmp.expected b/tests/017/setjmp.expected new file mode 100644 index 00000000..3d7a5493 --- /dev/null +++ b/tests/017/setjmp.expected @@ -0,0 +1,4 @@ +setjmp +result 42 +libpng longjmp +libpng error 42 diff --git a/tests/017/setjmp.tl b/tests/017/setjmp.tl new file mode 100644 index 00000000..bac25957 --- /dev/null +++ b/tests/017/setjmp.tl @@ -0,0 +1,47 @@ +;; test local setjmp +(let ((jb (jmp-buf))) + (setjmp jb result + (progn (put-line "setjmp") + (longjmp jb 42)) + (put-line `result @result`))) + +(defun png-fake-output () + (put-string "libpng longjmp\nlibpng error 42\n") + (exit)) + +(unless (ignerr (let ((png (dlopen "libpng.so"))) + (nequal cptr-null (dlsym png "png_set_longjmp_fn")))) + (png-fake-output)) + +;; needed by png-set-longjmp-fn API +(defvarl libc (dlopen nil)) +(defvarl longjmp-addr (dlsym libc "longjmp")) + +(typedef png-structp (cptr png)) + +(with-dyn-lib "libpng.so" + (deffi png-get-header-ver "png_get_header_ver" str (png-structp)) + (deffi png-create-read-struct "png_create_read_struct" png-structp (str cptr cptr cptr)) + (deffi png-set-longjmp-fn "png_set_longjmp_fn" (carray uchar) (png-structp (cptr dlsym) size-t)) + (deffi png-longjmp "png_longjmp" void (png-structp int))) + +(defvar png-ver (png-get-header-ver cptr-null)) + +;; In the png.h header, png_setjmp is a macro only; you cannot +;; #undef it to get to a function. So we write the macro in +;; the same way as a Lisp macro, in terms of png-set-longjmp-fn, +;; whereby we pass the longjmp function, and sizeof (jmp_buf). +(defmacro png-setjmp (png-ptr) + (let ((jmpbuf-size (load-time (len (jmp-buf))))) + ^(png-set-longjmp-fn ,png-ptr longjmp-addr ,jmpbuf-size))) + +;;; Test + +;; get png handle +(defvar png (png-create-read-struct png-ver cptr-null cptr-null cptr-null)) + +;; get jmp_buf from png handle, setjmp it, longjmp to it. +(setjmp (png-setjmp png) err + (progn (put-line "libpng longjmp") + (png-longjmp png 42)) + (put-line `libpng error @err`)) diff --git a/tests/017/str-s.tl b/tests/017/str-s.tl new file mode 100644 index 00000000..00052cbe --- /dev/null +++ b/tests/017/str-s.tl @@ -0,0 +1,11 @@ +(load "../common") + +(with-dyn-lib (libc) + (deffi strtol "strtol" long (str (ptr-out (array 1 str-s)) int)) + (deffi bcstol "strtol" long (bstr (ptr-out (array 1 bstr-s)) int)) + (deffi wcstol "wcstol" long (wstr (ptr-out (array 1 wstr-s)) int))) + +(mtest + (let ((v (vec nil))) (list (strtol "-345x" v 0) v)) (-345 #("x")) + (let ((v (vec nil))) (list (bcstol "-345x" v 0) v)) (-345 #("x")) + (let ((v (vec nil))) (list (wcstol "-345x" v 0) v)) (-345 #("x"))) diff --git a/tests/017/variadic.expected b/tests/017/variadic.expected new file mode 100644 index 00000000..8a918349 --- /dev/null +++ b/tests/017/variadic.expected @@ -0,0 +1 @@ +foo-123 = 4.560 diff --git a/tests/017/variadic.tl b/tests/017/variadic.tl new file mode 100644 index 00000000..6fa464e0 --- /dev/null +++ b/tests/017/variadic.tl @@ -0,0 +1,6 @@ +(load "../common") + +(with-dyn-lib (libc) + (deffi printf-int-double "printf" int (str : int double))) + +(printf-int-double "foo-%d = %4.3f\n" 123 4.56) diff --git a/tests/018/chmod.expected b/tests/018/chmod.expected deleted file mode 100644 index e69de29b..00000000 --- a/tests/018/chmod.expected +++ /dev/null diff --git a/tests/018/chmod.tl b/tests/018/chmod.tl index ada3f0be..d8663b5e 100644 --- a/tests/018/chmod.tl +++ b/tests/018/chmod.tl @@ -7,7 +7,9 @@ (with-stream (s (open-file tgt "w"))) (umask #o022) -(defvarl test-sticky (progn +(defvarl os (os-symbol)) + +(defvarl test-sticky (unless (meq os :bsd :openbsd) (chmod tgt s-isvtx) (let ((st (stat tgt))) (plusp (logand s-isvtx st.mode))))) @@ -19,19 +21,19 @@ (when (or test-sticky (not (find #\t `@init@mode@expected`))) (let ((ini (dec-perm init)) - (exp (dec-perm expected))) + (exp (dec-perm expected))) (chmod tgt ini) (let* ((st (stat tgt)) - (m (mode-bits st.mode))) - (unless (eql m ini) - (error "failed to set initial mode: expected: ~s, actual: ~s " - init (enc-perm m)))) + (m (mode-bits st.mode))) + (unless (eql m ini) + (error "failed to set initial mode: expected: ~s, actual: ~s " + init (enc-perm m)))) (chmod tgt mode) (let* ((st (stat tgt)) - (m (mode-bits st.mode))) - (unless (eql m exp) - (error "failed to set mode with ~s: expected ~s, actual ~s" - mode expected (enc-perm m))))))) + (m (mode-bits st.mode))) + (unless (eql m exp) + (error "failed to set mode with ~s: expected ~s, actual ~s" + mode expected (enc-perm m))))))) (cht "------------" "a+strwx" "sgtrwxrwxrwx") (cht "------------" "+strwx" "sgtrwxr-xr-x") @@ -39,15 +41,19 @@ (cht "------------" "g+s" "-g----------") (cht "------------" "+t" "--t---------") (cht "sgtrwxrwxrwx" "=" "------------") -(cht "sgtrwxrwxrwx" "u=" "-gt---rwxrwx") -(cht "sgtrwxrwxrwx" "g=" "s-trwx---rwx") -(cht "sgtrwxrwxrwx" "o=" "sg-rwxrwx---") +;; These tests don't work on Cygwin 3.1.7, Windows 10. +;; They worked on Cygwin 2.5 on Windows 7. +(unless (eq os :cygwin) + (cht "sgtrwxrwxrwx" "u=" "-gt---rwxrwx") + (cht "sgtrwxrwxrwx" "g=" "s-trwx---rwx") + (cht "sgtrwxrwxrwx" "o=" "sg-rwxrwx---")) (cht "------------" "u+s,g+s" "sg----------") (cht "------------" "u+r,g+r,o+r,+t,+s" "sgtr--r--r--") (cht "------------" "+rwx,g-r+w,o-r+w" "---rwx-wx-wx") (cht "---------rwx" "u=rwsx" "s--rwx---rwx") -(cht "---------rwx" "u=rwsx,g=rwx,go-x" "s--rwxrw-rw-") -(cht "---------rwx" "g=o,g-w+s,u=g,o-x" "-g-r-xr-xrw-") +(unless (eq os :cygwin) + (cht "---------rwx" "u=rwsx,g=rwx,go-x" "s--rwxrw-rw-") + (cht "---------rwx" "g=o,g-w+s,u=g,o-x" "-g-r-xr-xrw-")) (cht "---------rwx" "o=o" "---------rwx") (cht "-----x------" "a+X" "-----x--x--x") (cht "-----x------" "=,a+X" "------------") diff --git a/tests/018/clean.expected b/tests/018/clean.expected new file mode 100644 index 00000000..25b0c86c --- /dev/null +++ b/tests/018/clean.expected @@ -0,0 +1,100 @@ +(let ((*load-path* + ())) + (clean-file "nabuchodonosor.tl")) +--> +(remove-path ("nabuchodonosor.tlo" nil) + nil) +(remove-path ("nabuchodonosor.tlo.gz" nil) + nil) + +(let ((*load-path* + ())) + (clean-file "nabuchodonosor.txr")) +--> +(remove-path ("nabuchodonosor.tlo" nil) + nil) +(remove-path ("nabuchodonosor.tlo.gz" nil) + nil) + +(let ((*load-path* + ())) + (clean-file "nabuchodonosor.tlo")) +--> +(remove-path ("nabuchodonosor.tlo" nil) + nil) + +(let ((*load-path* + ())) + (clean-file "nabuchodonosor.tlo.gz")) +--> +(remove-path ("nabuchodonosor.tlo.gz" nil) + nil) + +(let ((*load-path* + ())) + (clean-file "nabuchodonosor.abc")) +--> +(remove-path ("nabuchodonosor.abc.tlo" nil) + nil) +(remove-path ("nabuchodonosor.abc.tlo.gz" nil) + nil) + +(let ((*load-path* + ())) + (clean-file "nabuchodonosor")) +--> +(remove-path ("nabuchodonosor.tlo" nil) + nil) +(remove-path ("nabuchodonosor.tlo.gz" nil) + nil) + +(let ((*load-path* + "/tmp/foo.tlo")) + (clean-file "nabuchodonosor.tl")) +--> +(remove-path ("/tmp/nabuchodonosor.tlo" nil) + nil) +(remove-path ("/tmp/nabuchodonosor.tlo.gz" nil) + nil) + +(let ((*load-path* + "/tmp/foo.tlo")) + (clean-file "nabuchodonosor.txr")) +--> +(remove-path ("/tmp/nabuchodonosor.tlo" nil) + nil) +(remove-path ("/tmp/nabuchodonosor.tlo.gz" nil) + nil) + +(let ((*load-path* + "/tmp/foo.tlo")) + (clean-file "nabuchodonosor.tlo")) +--> +(remove-path ("/tmp/nabuchodonosor.tlo" nil) + nil) + +(let ((*load-path* + "/tmp/foo.tlo")) + (clean-file "nabuchodonosor.tlo.gz")) +--> +(remove-path ("/tmp/nabuchodonosor.tlo.gz" nil) + nil) + +(let ((*load-path* + "/tmp/foo.tlo")) + (clean-file "nabuchodonosor.abc")) +--> +(remove-path ("/tmp/nabuchodonosor.abc.tlo" nil) + nil) +(remove-path ("/tmp/nabuchodonosor.abc.tlo.gz" nil) + nil) + +(let ((*load-path* + "/tmp/foo.tlo")) + (clean-file "nabuchodonosor")) +--> +(remove-path ("/tmp/nabuchodonosor.tlo" nil) + nil) +(remove-path ("/tmp/nabuchodonosor.tlo.gz" nil) + nil) + diff --git a/tests/018/clean.tl b/tests/018/clean.tl new file mode 100644 index 00000000..ed6f29a3 --- /dev/null +++ b/tests/018/clean.tl @@ -0,0 +1,10 @@ +(trace remove-path) + +(each ((*load-path* '(nil "/tmp/foo.tlo"))) + (each ((name '#"nabuchodonosor.tl nabuchodonosor.txr \ + nabuchodonosor.tlo nabuchodonosor.tlo.gz \ + nabuchodonosor.abc nabuchodonosor")) + (prinl ^(let ((*load-path* , *load-path*)) (clean-file ,name))) + (put-line "-->") + (clean-file name) + (put-line))) diff --git a/tests/018/close-delegate.expected b/tests/018/close-delegate.expected new file mode 100644 index 00000000..de68447f --- /dev/null +++ b/tests/018/close-delegate.expected @@ -0,0 +1,6 @@ +close called, count 2 +close called, count 1 +40 +close called, count 2 +close called, count 1 +40 diff --git a/tests/018/close-delegate.tl b/tests/018/close-delegate.tl new file mode 100644 index 00000000..64a1dc91 --- /dev/null +++ b/tests/018/close-delegate.tl @@ -0,0 +1,40 @@ +(load "../common") + +(defstruct refcount-close stream-wrap + stream + (count 1) + + (:method close (me throw-on-error-p) + (put-line `close called, count @{me.count}`) + (when (plusp me.count) + (if (zerop (dec me.count)) + (close-stream me.stream throw-on-error-p))))) + +(flow + (with-stream (s (make-struct-delegate-stream + (new refcount-close + count 2 + stream (open-file *load-path*)))) + (get-lines s)) + len + prinl) + +(defstruct refcount-close-alt stream-wrap + stream + (count 1) + + (:method close (me throw-on-error-p) + (put-line `close called, count @{me.count}`) + (when (plusp me.count) + (if (zerop (dec me.count)) + (close-stream me.stream throw-on-error-p) + :)))) + +(flow + (with-stream (s (make-struct-delegate-stream + (new refcount-close-alt + count 2 + stream (open-file *load-path*)))) + (get-lines s)) + len + prinl) diff --git a/tests/018/close-lazy.tl b/tests/018/close-lazy.tl new file mode 100644 index 00000000..c6b08e72 --- /dev/null +++ b/tests/018/close-lazy.tl @@ -0,0 +1,3 @@ +(dotimes (i 20000) + (close-lazy-streams + (file-get-lines self-path))) diff --git a/tests/018/combine-tlo.tl b/tests/018/combine-tlo.tl new file mode 100644 index 00000000..e2dc0f83 --- /dev/null +++ b/tests/018/combine-tlo.tl @@ -0,0 +1,27 @@ +(load "../common") + +(push-after-load + (remove-path "libfile.tl") + (remove-path "libfile.tlo") + (remove-path "mainfile.tl") + (remove-path "mainfile.tlo") + (remove-path "progfile")) + +(file-put-lines + "libfile.tl" + ^(,`#!@{txr-exe-path} --lisp` + "(defun libfun ()" + " (put-line \"libfun\"))")) + +(file-put-lines + "mainfile.tl" + '("(compile-only (libfun))")) + +(compile-file "./libfile") +(compile-file "./mainfile") + +(cat-files "progfile" "libfile.tlo" "mainfile.tlo") + +(chmod "progfile" "+x") + +(test (command-get-lines "./progfile") ("libfun")) diff --git a/tests/018/crypt.tl b/tests/018/crypt.tl new file mode 100644 index 00000000..dc044878 --- /dev/null +++ b/tests/018/crypt.tl @@ -0,0 +1,23 @@ +(load "../common") + +(if (meq (os-symbol) :android :cygwin) + (exit)) + +(mtest + (crypt nil nil) :error) + +(if (neq :openbsd (os-symbol)) + (mtest + (crypt "a" "bc") "bcshMw5X24ayQ" + (crypt "a" "bcd") "bcshMw5X24ayQ")) + +(if (eq :linux (os-symbol)) + (mtest + (crypt "a" "b") :error + (crypt "a" "::") :error + (crypt "a" "$1$") "$1$$Ij31LCAysPM23KuPlm1wA/" + (crypt "a" "$1$bcd$") "$1$bcd$cgz778Ks3pkbWfyW.CWae/" + (crypt "a" "$5$") "$5$$QG6CCM7eJAxpUPcBpn0Z2K29NHtaI6Mk1fCpPrpjdj3" + (crypt "a" "$5$bcd$") "$5$bcd$OGt98FNCHtKIrT6qWAKLXOQ8eIApFT5dJngrYreMwF3" + (crypt "a" "$6$") "$6$$ek/ucQg0IM8SQLyD2D66mpoW0vAF26eA0/pqoN95V.F0nZh1IFuENNo0OikacRkDBk5frNqziMYMdVVrQ0o.51" + (crypt "a" "$6$bcd$") "$6$bcd$RK8RFj8wSE1NBJi8s.KDjGQK3EbpI474a6f4UP0LGOkQU50ZQrwykBaSjx7tZFVEpanpL44zd1p6A9q.sy.YH0")) diff --git a/tests/018/errno.tl b/tests/018/errno.tl new file mode 100644 index 00000000..ec204b23 --- /dev/null +++ b/tests/018/errno.tl @@ -0,0 +1,8 @@ +(load "../common") + +(vtest + (catch + (open-file "/NoNeXiStEnT") + (error (msg) + (string-get-code msg))) + enoent) diff --git a/tests/018/forkflush.expected b/tests/018/forkflush.expected new file mode 100644 index 00000000..475f87b1 --- /dev/null +++ b/tests/018/forkflush.expected @@ -0,0 +1,12 @@ +A +B +C +D +E +F +G +H +I +J +K +L diff --git a/tests/018/forkflush.tl b/tests/018/forkflush.tl new file mode 100644 index 00000000..296cec02 --- /dev/null +++ b/tests/018/forkflush.tl @@ -0,0 +1,36 @@ +(load "../common") + +(defvarl os (os-symbol)) + +(push-after-load (remove-path "tmpfile")) + +(with-stream (*stdout* (open-file "tmpfile" "w")) + (cond + ((eq os :cygwin) + (put-string "A\nB\nC\nD\n")) + (t (put-line "A") + (sh "echo B") + (put-line "C") + (sh "echo D")))) + +(put-string (file-get-string "tmpfile")) + +(with-stream (*stdout* (open-file "tmpfile" "w")) + (put-line "E") + (with-stream (s (open-process "cat" "w")) + (put-line "F" s)) + (put-line "G") + (with-stream (s (open-process "cat" "w")) + (put-line "H" s))) + +(put-string (file-get-string "tmpfile")) + +(with-stream (*stdout* (open-file "tmpfile" "w")) + (put-line "I") + (with-stream (s (open-command "cat" "w")) + (put-line "J" s)) + (put-line "K") + (with-stream (s (open-command "cat" "w")) + (put-line "L" s))) + +(put-string (file-get-string "tmpfile")) diff --git a/tests/018/format.tl b/tests/018/format.tl new file mode 100644 index 00000000..6fc27b4e --- /dev/null +++ b/tests/018/format.tl @@ -0,0 +1,273 @@ +(load "../common") + +(mtest + (fmt "~x" #b'') "" + (fmt "~4x" #b'') " " + (fmt "~4,02x" #b'') " 00" + (fmt "~x" #b'AF') "af" + (fmt "~4x" #b'AF') " af" + (fmt "~-4x" #b'AF') "af " + (fmt "~4,03x" #b'AF') " 0af" + (fmt "~-4,03X" #b'AF') "0AF ") + +(mtest + (fmt "~x" #\xaf) "af" + (fmt "~4x" #\xaf) " af" + (fmt "~-4x" #\xaf) "af " + (fmt "~4,03x" #\xaf) " 0af" + (fmt "~-4,03X" #\xaf) "0AF ") + +(mtest + (fmt "~x" #xaf) "af" + (fmt "~4x" #xaf) " af" + (fmt "~-4x" #xaf) "af " + (fmt "~4,03x" #xaf) " 0af" + (fmt "~-4,03X" #xaf) "0AF ") + +(test + (fmt "~x" (sha256 "abc")) + "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad") + +(mtest + (fmt "~8,02f" 12) " 0012.00" + (fmt "~8,+02f" 12) "+0012.00" + (fmt "~8,-02f" 12) "00012.00" + (fmt "~8, 02f" 12) " 0012.00" + (fmt "~8,-02f" -12) "-0012.00" + (fmt "~6,02f" 12) " 12.00" + (fmt "~6,+02f" 12) "+12.00" + (fmt "~6,-02f" 12) "012.00" + (fmt "~6,- 2f" 12) " 12.00" + (fmt "~6,-02f" -12) "-12.00" + (fmt "~5,02f" 12) "12.00" + (fmt "~5,+02f" 12) "+12.00" + (fmt "~5,-02f" 12) "12.00" + (fmt "~5,- 2f" 12) "12.00" + (fmt "~5,-02f" -12) "-12.00") + +(mtest + (fmt "~<8,02f" 12) "0012.00 " + (fmt "~<8,+02f" 12) "+0012.00" + (fmt "~<8,-02f" 12) "00012.00" + (fmt "~<8, 02f" 12) " 0012.00" + (fmt "~<8,-02f" -12) "-0012.00" + (fmt "~<6,02f" 12) "12.00 " + (fmt "~<6,+02f" 12) "+12.00" + (fmt "~<6,-02f" 12) "012.00" + (fmt "~<6,- 2f" 12) " 12.00" + (fmt "~<6,-02f" -12) "-12.00" + (fmt "~<5,02f" 12) "12.00" + (fmt "~<5,+02f" 12) "+12.00" + (fmt "~<5,-02f" 12) "12.00" + (fmt "~<5,- 2f" 12) "12.00" + (fmt "~<5,-02f" -12) "-12.00") + +(mtest + (fmt "~<8,2a" 12) "12 " + (fmt "~<8,02a" 12) "12 " + (fmt "~<8,+02a" 12) "+12 " + (fmt "~<8,-02a" 12) "012 " + (fmt "~<8, 02a" 12) " 12 " + (fmt "~<8,2a" 12.0) "12 " + (fmt "~<8,02a" 12.0) "12 " + (fmt "~<8,+02a" 12.0) "+12 " + (fmt "~<8,-02a" 12.0) "012 " + (fmt "~<8, 02a" 12.0) " 12 " + (fmt "~<8,4a" 12.0) " 12 " + (fmt "~<8,04a" 12.0) "0012 " + (fmt "~<8,+04a" 12.0) "+0012 " + (fmt "~<8,-04a" 12.0) "00012 " + (fmt "~<8, 04a" 12.0) " 0012 " + (fmt "~<8,8a" 12.0) " 12 " + (fmt "~<8,08a" 12.0) "0000012 " + (fmt "~<8,+08a" 12.0) "+0000012" + (fmt "~<8,-08a" 12.0) "00000012" + (fmt "~<8, 08a" 12.0) " 0000012") + +(mtest + (fmt "~,04a" 1) "0001" + (fmt "~,4a" 1) " 1" + (fmt "~4,a" 1) " 1" + (fmt "~<8,a" 1) "1 " + (fmt "~<8,0a" 1) "1 " + (fmt "~<8,4a" 1) " 1 " + (fmt "~<8,04a" 1) "0001 " + (fmt "~<8,+04a" 1) "+0001 " + (fmt "~<,4a" 1) " 1") + +(mtest + (fmt "~,04a" 1) "0001" + (fmt "~,4a" 1) " 1" + (fmt "~4,a" 1) " 1" + (fmt "~<8,a" 1) "1 " + (fmt "~<8,0a" 1) "1 " + (fmt "~<8,4a" 1) " 1 " + (fmt "~<8,04a" 1) "0001 " + (fmt "~<8,+04a" 1) "+0001 " + (fmt "~<,4a" 1) " 1") + +(mtest + (fmt "~e" 1.2e13) "1.200e13" + (fmt "~,2e" 1.2e13) "1.20e13" + (fmt "~,0e" 1.2e13) "1e13" + (fmt "~8,0e" 1.2e13) " 1e13" + (fmt "~8,00e" 1.2e13) " 0001e13" + (fmt "~8,-0e" 1.2e13) " 01e13" + (fmt "~8,-00e" 1.2e13) "00001e13" + (fmt "~8, 00e" 1.2e13) " 0001e13" + (fmt "~8,+00e" 1.2e13) "+0001e13" + (fmt "~8,+00e" -1.2e13) "-0001e13" + (fmt "~8,00e" -1.2e13) "-0001e13" + (fmt "~<8,0e" 1.2e13) " 1e13 " + (fmt "~<8,00e" 1.2e13) "0001e13 " + (fmt "~<8,-0e" 1.2e13) " 01e13" + (fmt "~<8,-00e" 1.2e13) "00001e13" + (fmt "~<8,+00e" 1.2e13) "+0001e13") + +(mtest + (pic "") "" + (pic "~") :error + (pic "~z") :error + (pic "#") :error + (pic "# #" 1) :error + (pic "# # #" 1 2) :error + (pic "# # #" 1 2 3 4) :warning + (pic "~<") "<" + (pic "~>") ">" + (pic "~|") "|" + (pic "~#") "#" + (pic "~0") "0" + (pic "~+") "+" + (pic "~-") "-" + (pic "~.") "." + (pic "~!") "!" + (pic "~~") "~" + (pic "x~~y") "x~y" + (pic "~~x~~~~y~~") "~x~~y~") + +(mtest + (pic "<" "a") "a" + (pic "<<" "a") "a " + (pic "<<<" "a") "a " + (pic "~<<~>" "a") "<a>" + (pic "~<<<~>" "a") "<a >" + (pic "~<<<<~>" "a") "<a >") + +(mtest + (pic ">" "a") "a" + (pic ">>" "a") " a" + (pic ">>>" "a") " a" + (pic "~>>~<" "a") ">a<" + (pic "~>>>~<" "a") "> a<" + (pic "~>>>>~<" "a") "> a<") + +(mtest + (pic "|" "a") "a" + (pic "||" "a") "a " + (pic "|||" "a") " a " + (pic "||||" "a") " a " + (pic "|||||" "a") " a " + (pic "|||||" "aaa") " aaa " + (pic "|||||" "aaaaa") "aaaaa" + (pic "|||||" "aaaaaa") "aaaaaa" + (pic "~||~|" "a") "|a|" + (pic "~|||~|" "a") "|a |" + (pic "~||||~|" "a") "| a |") + +(mtest + (pic "#" 0) "0" + (pic "#" 0.0) "0" + (pic "#" 0.1) "0" + (pic "#" 0.7) "1" + (pic "+#" 0.7) "+1" + (pic "-#" -0.7) "-1" + (pic "+#" -0.7) "-1" + (pic "-#" 0.7) " 1") + +(mtest + (pic "####" 1234) "1234" + (pic "####" 1234.1) "1234" + (pic "#" 1) "1" + (pic "#.#" 1) "1.0" + (pic "######" 1234.1) " 1234" + (pic "######.#" 1234.1) " 1234.1" + (pic "#######.##" 1234.1) " 1234.10" + (pic "#######.##" -1234.1) " -1234.10" + (pic "0######.##" 1234.1) "0001234.10" + (pic "+######.##" 1234.1) " +1234.10" + (pic "-######.##" 1234.1) " 1234.10" + (pic "+0#####.##" 1234.1) "+001234.10" + (pic "-0#####.##" 1234.1) " 001234.10") + +(mtest + (pic "#!#" 1234) "#.#" + (pic "#!#" 123) "#.#" + (pic "#.#" 123) "123.0") + +(mtest + (pic "-##!#" 12) " 12.0" + (pic "+##!#" 12) "+12.0" + (pic "-##!#" -123) "###.#" + (pic "+##!#" 123) "###.#") + +(mtest + (pic "###!" 123) "123" + (pic "###." 123) "123." + (pic "###!" 1234) "###") + +(mtest + (pic "X##.#Y<<<Z>>>W" 1 2 3) "X 1.0Y2 Z 3W" + (pic "~###.#~#<<<~#>>>~#" 1 2 3) "# 1.0#2 # 3#") + +(mtest + (pic "#,#,#,#" 1234) "1,2,3,4" + (pic "#,##,#" 1234) "1,23,4" + (pic "##,##" 1234) "12,34" + (pic "###," 1234) "1234," + (pic ",###" 1234) ",1234" + (pic "##,##" 1234.1) "12,34" + (pic "#,###,###.###,###" 1234.1) " 1,234.100,000" + (pic "#,###,###.##" -1234.1) " -1,234.10" + (pic "0,###,###.##" 1234.1) "0,001,234.10" + (pic "+#,##,###.##" 234.1) " +234.10" + (pic "+#,##,###.##" + 123456.7) "+1,23,456.70" + (pic "+#,##,###.##" 1234.1) " +1,234.10" + (pic "-#,##,###.##" 1234.1) " 1,234.10" + (pic "+0,#####.##" 1234.1) "+0,01234.10" + (pic "-0,#####.##" 1234.1) " 0,01234.10") + +(mtest + (pic "$###,###!##" 234567.89) "$234,567.89" + (pic "$###,###!##" 1234567.89) "$###,###.##" + (pic "#,#,#!" 123) "1,2,3" + (pic "#,#,#!" 1234) "#,#,#") + +(mtest + (pic "(#,###,###.##)" 123456.56) " 123,456.56 " + (pic "(#,###,###.##)" 1234566.56) " 1,234,566.56 " + (pic "(#,###,###.##)" 12345667.56) "12,345,667.56 " + (pic "(#,###,###.##)" 123456678.56) "123,456,678.56" + (pic "(#,###,###.##)" -123456.56) "( 123,456.56)" + (pic "(#,###,###.##)" -1234566.56) "(1,234,566.56)" + (pic "(#,###,###.##)" -12345667.56) "(12,345,667.56)" + (pic "(#,###,###.##)" -123456678.56) "(123,456,678.56)") + +(mtest + (pic "(0,###,###.##)" 123456.56) " 0,123,456.56 " + (pic "(0,###,###.##)" 1234566.56) " 1,234,566.56 " + (pic "(0,###,###.##)" 12345667.56) "12,345,667.56 " + (pic "(0,###,###.##)" 123456678.56) "123,456,678.56" + (pic "(0,###,###.##)" -123456.56) "(0,123,456.56)" + (pic "(0,###,###.##)" -1234566.56) "(1,234,566.56)" + (pic "(0,###,###.##)" -12345667.56) "(12,345,667.56)" + (pic "(0,###,###.##)" -123456678.56) "(123,456,678.56)") + +(test + (let ((a 2) (b "###") (c 13.5)) + (pic `abc@(+ a a)###.##@b>>>>` c "x")) + "abc4 13.50### x") + +(test + (pic "+0####.## <<<<<" 123 1) + "+00123.00 1 ") diff --git a/tests/018/getput.tl b/tests/018/getput.tl new file mode 100644 index 00000000..7e8e2be1 --- /dev/null +++ b/tests/018/getput.tl @@ -0,0 +1,33 @@ +(load "../common") + +(defvarl file "getput.data") + +(push-after-load (remove-path file)) + +(file-put-objects file '(1 2.3 (a . b) "foo")) + +(test + (file-get-lines file) ("1" "2.3" "(a . b)" "\"foo\"")) + +(file-append-objects file '(#(nil))) + +(mtest + (file-get-lines file) ("1" "2.3" "(a . b)" "\"foo\"" "#(nil)") + (file-get-objects file) (1 2.3 (a . b) "foo" #(nil))) + +(mtest + (read-objects "(a . b) #\\c") ((a . b) #\c) + (read-objects "(a") :error) + +(file-put-string file "(a") + +(mtest + (file-get file) :error + (file-get-objects file) :error) + +(let ((errors (with-out-string-stream (err) + (ignerr (file-get-objects file : err))))) + (mtest + (true (contains "syntax error" errors)) t + (true (contains "unterminated" errors)) t + (true (contains ":1" errors)) t)) diff --git a/tests/018/glob.tl b/tests/018/glob.tl new file mode 100644 index 00000000..438e4c65 --- /dev/null +++ b/tests/018/glob.tl @@ -0,0 +1,142 @@ +(load "../common") + +;; Passes on Cygwin, but too slow! +(if (eq (os-symbol) :cygwin) + (exit)) + +(mtest + (sys:brace-expand "~/{Downloads,Pictures}/*.{jpg,gif,png}") + #"~/Downloads/*.jpg ~/Downloads/*.gif ~/Downloads/*.png \ + ~/Pictures/*.jpg ~/Pictures/*.gif ~/Pictures/*.png" + (sys:brace-expand "It{{em,alic}iz,erat}e{d,}, please.") + ("Itemized, please." "Itemize, please." "Italicized, please." + "Italicize, please." "Iterated, please." "Iterate, please.") + (sys:brace-expand "{,{,gotta have{ ,\\, again\\, }}more }cowbell!") + ("cowbell!" "more cowbell!" "gotta have more cowbell!" + "gotta have\\, again\\, more cowbell!") + (sys:brace-expand "{}} some }{,{\\\\{ edge, edge} \\,}{ cases, {here} \\\\\\\\\\}") + ("{}} some }{,{\\\\ edge \\,}{ cases, {here} \\\\\\\\\\}" + "{}} some }{,{\\\\ edge \\,}{ cases, {here} \\\\\\\\\\}")) + +(mtest + (glob* "tests/**/002") ("tests/002") + (glob* "tests/**/{003,004}") ("tests/003" "tests/004")) + +(chdir "tests/002/proc") + +(mtest + (glob* "**") + ("1" "1/status" "1/tasks" "103" "103/status" "103/tasks" "1068" + "1068/status" "1068/tasks" "1235" "1235/status" "1235/tasks" + "1236" "1236/status" "1236/tasks" "15812" "15812/status" "15812/tasks" + "16" "16/status" "16/tasks" "1620" "1620/status" "1620/tasks" + "1624" "1624/status" "1624/tasks" "16248" "16248/status" "16248/tasks" + "16249" "16249/status" "16249/tasks" "1645" "1645/status" "1645/tasks" + "16598" "16598/tasks" "1665" "1665/status" "1665/tasks" "1698" + "1698/status" "1698/tasks" "17" "17/status" "17/tasks" "175" + "175/status" "175/tasks" "1766" "1766/status" "1766/tasks" "1790" + "1790/status" "1790/tasks" "1791" "1791/status" "1791/tasks" + "1821" "1821/status" "1821/tasks" "1839" "1839/status" "1839/tasks" + "1851" "1851/status" "1851/tasks" "186" "186/status" "186/tasks" + "18614" "18614/tasks" "1887" "1887/status" "1887/tasks" "1902" + "1902/status" "1902/tasks" "1921" "1921/status" "1921/tasks" + "1925" "1925/status" "1925/tasks" "1926" "1926/status" "1926/tasks" + "1927" "1927/status" "1927/tasks" "1928" "1928/status" "1928/tasks" + "1929" "1929/status" "1929/tasks" "1930" "1930/status" "1930/tasks" + "1931" "1931/status" "1931/tasks" "1932" "1932/status" "1932/tasks" + "1936" "1936/status" "1936/tasks" "1963" "1963/status" "1963/tasks" + "1989" "1989/status" "1989/tasks" "2" "2/status" "2/tasks" "2008" + "2008/status" "2008/tasks" "2027" "2027/status" "2027/tasks" + "2041" "2041/status" "2041/tasks" "2052" "2052/status" "2052/tasks" + "2062" "2062/status" "2062/tasks" "2124" "2124/status" "2124/tasks" + "2184" "2184/status" "2184/tasks" "2354" "2354/status" "2354/tasks" + "24134" "24134/tasks" "2551" "2551/status" "2551/tasks" "2579" + "2579/status" "2579/tasks" "2625" "2625/status" "2625/tasks" + "2626" "2626/status" "2626/tasks" "2631" "2631/status" "2631/tasks" + "2634" "2634/status" "2634/tasks" "2636" "2636/status" "2636/tasks" + "2638" "2638/status" "2638/tasks" "2644" "2644/status" "2644/tasks" + "2661" "2661/status" "2661/tasks" "2685" "2685/status" "2685/tasks" + "2689" "2689/status" "2689/tasks" "2691" "2691/status" "2691/tasks" + "2693" "2693/status" "2693/tasks" "2695" "2695/status" "2695/tasks" + "2698" "2698/status" "2698/tasks" "2701" "2701/status" "2701/tasks" + "2707" "2707/status" "2707/tasks" "27121" "27121/status" "27121/tasks" + "2717" "2717/status" "2717/tasks" "2718" "2718/status" "2718/tasks" + "2720" "2720/status" "2720/tasks" "2722" "2722/status" "2722/tasks" + "27243" "27243/status" "27243/tasks" "2726" "2726/status" "2726/tasks" + "2728" "2728/status" "2728/tasks" "27682" "27682/status" "27682/tasks" + "27684" "27684/status" "27684/tasks" "27685" "27685/status" "27685/tasks" + "28" "28/status" "28/tasks" "29" "29/status" "29/tasks" "29840" + "29840/status" "29840/tasks" "3" "3/status" "3/tasks" "30737" + "30737/status" "30737/tasks" "31905" "31905/status" "31905/tasks" + "31907" "31907/status" "31907/tasks" "31908" "31908/status" "31908/tasks" + "32672" "32672/status" "32672/tasks" "32674" "32674/status" "32674/tasks" + "32675" "32675/status" "32675/tasks" "4" "4/status" "4/tasks" + "5" "5/status" "5/tasks" "870" "870/status" "870/tasks") + (glob "**/") + ("1/" "103/" "1068/" "1235/" "1236/" "15812/" "16/" "1620/" "1624/" + "16248/" "16249/" "1645/" "16598/" "1665/" "1698/" "17/" "175/" + "1766/" "1790/" "1791/" "1821/" "1839/" "1851/" "186/" "18614/" + "1887/" "1902/" "1921/" "1925/" "1926/" "1927/" "1928/" "1929/" + "1930/" "1931/" "1932/" "1936/" "1963/" "1989/" "2/" "2008/" + "2027/" "2041/" "2052/" "2062/" "2124/" "2184/" "2354/" "24134/" + "2551/" "2579/" "2625/" "2626/" "2631/" "2634/" "2636/" "2638/" + "2644/" "2661/" "2685/" "2689/" "2691/" "2693/" "2695/" "2698/" + "2701/" "2707/" "27121/" "2717/" "2718/" "2720/" "2722/" "27243/" + "2726/" "2728/" "27682/" "27684/" "27685/" "28/" "29/" "29840/" + "3/" "30737/" "31905/" "31907/" "31908/" "32672/" "32674/" "32675/" + "4/" "5/" "870/")) + +(chdir "../..") + +(mtest + (glob* "**/3*/**") + ("002/proc/3/" "002/proc/3/status" "002/proc/3/tasks" "002/proc/30737/" + "002/proc/30737/status" "002/proc/30737/tasks" "002/proc/31905/" + "002/proc/31905/status" "002/proc/31905/tasks" "002/proc/31907/" + "002/proc/31907/status" "002/proc/31907/tasks" "002/proc/31908/" + "002/proc/31908/status" "002/proc/31908/tasks" "002/proc/32672/" + "002/proc/32672/status" "002/proc/32672/tasks" "002/proc/32674/" + "002/proc/32674/status" "002/proc/32674/tasks" "002/proc/32675/" + "002/proc/32675/status" "002/proc/32675/tasks") + (glob* "**/{3,4,5}*/**") + ("002/proc/3/" "002/proc/3/status" "002/proc/3/tasks" "002/proc/30737/" + "002/proc/30737/status" "002/proc/30737/tasks" "002/proc/31905/" + "002/proc/31905/status" "002/proc/31905/tasks" "002/proc/31907/" + "002/proc/31907/status" "002/proc/31907/tasks" "002/proc/31908/" + "002/proc/31908/status" "002/proc/31908/tasks" "002/proc/32672/" + "002/proc/32672/status" "002/proc/32672/tasks" "002/proc/32674/" + "002/proc/32674/status" "002/proc/32674/tasks" "002/proc/32675/" + "002/proc/32675/status" "002/proc/32675/tasks" "002/proc/4/" + "002/proc/4/status" "002/proc/4/tasks" "002/proc/5/" "002/proc/5/status" + "002/proc/5/tasks") + (glob* "**/{3,4,5}*/**" glob-xnobrace) + nil + (len (glob* "**/proc/**/**")) + 366) + +(if (neq (os-symbol) :solaris) + (test + (glob* "002/proc\\/**") + ("002/proc/1" "002/proc/103" "002/proc/1068" "002/proc/1235" "002/proc/1236" + "002/proc/15812" "002/proc/16" "002/proc/1620" "002/proc/1624" + "002/proc/16248" "002/proc/16249" "002/proc/1645" "002/proc/16598" + "002/proc/1665" "002/proc/1698" "002/proc/17" "002/proc/175" + "002/proc/1766" "002/proc/1790" "002/proc/1791" "002/proc/1821" + "002/proc/1839" "002/proc/1851" "002/proc/186" "002/proc/18614" + "002/proc/1887" "002/proc/1902" "002/proc/1921" "002/proc/1925" + "002/proc/1926" "002/proc/1927" "002/proc/1928" "002/proc/1929" + "002/proc/1930" "002/proc/1931" "002/proc/1932" "002/proc/1936" + "002/proc/1963" "002/proc/1989" "002/proc/2" "002/proc/2008" + "002/proc/2027" "002/proc/2041" "002/proc/2052" "002/proc/2062" + "002/proc/2124" "002/proc/2184" "002/proc/2354" "002/proc/24134" + "002/proc/2551" "002/proc/2579" "002/proc/2625" "002/proc/2626" + "002/proc/2631" "002/proc/2634" "002/proc/2636" "002/proc/2638" + "002/proc/2644" "002/proc/2661" "002/proc/2685" "002/proc/2689" + "002/proc/2691" "002/proc/2693" "002/proc/2695" "002/proc/2698" + "002/proc/2701" "002/proc/2707" "002/proc/27121" "002/proc/2717" + "002/proc/2718" "002/proc/2720" "002/proc/2722" "002/proc/27243" + "002/proc/2726" "002/proc/2728" "002/proc/27682" "002/proc/27684" + "002/proc/27685" "002/proc/28" "002/proc/29" "002/proc/29840" + "002/proc/3" "002/proc/30737" "002/proc/31905" "002/proc/31907" + "002/proc/31908" "002/proc/32672" "002/proc/32674" "002/proc/32675" + "002/proc/4" "002/proc/5" "002/proc/870"))) diff --git a/tests/018/gzip.tl b/tests/018/gzip.tl new file mode 100644 index 00000000..712ade3c --- /dev/null +++ b/tests/018/gzip.tl @@ -0,0 +1,59 @@ +(load "../common") + +(if (not (fboundp 'usr:buf-compress)) + (exit)) + +(defvarl %have-gzip% (sh "gzip -h > /dev/null 2> /dev/null")) + +(defun shchk (cmd) + (unless (zerop (sh cmd)) + (throw `command @cmd failed`))) + +(defun gzip (. files) + (each ((file files)) + (file-put-string `@file.gz` (file-get-string file) "z"))) + +(defun cat (dest . files) + (remove-path dest) + (each ((file files)) + (file-append-string dest (file-get-string file)))) + +(push-after-load + (each ((file '#"test-file test-file.gz \ + test-file-a.tl test-file-a.tlo test-file-a.tlo.gz \ + test-file-b.tl test-file-b.tlo test-file-b.tlo.gz \ + test-file-combined.tlo.gz")) + (remove-path file))) + +(when %have-gzip% + (file-put-string "test-file" "Hello, World!") + (remove-path "test-file.gz") + (cond ((eq (os-symbol) :openbsd) + (shchk "gzip -f test-file")) + (t (shchk "gzip test-file"))) + (test (file-get-string "test-file.gz" "z") "Hello, World!") + + (each ((mode (cons "z" (list-seq "z0".."z9")))) + (file-put-string "test-file.gz" "Goodbye, World!" mode) + (remove-path "test-file") + (shchk "gunzip test-file.gz") + (test (file-get-string "test-file") "Goodbye, World!")) + + (file-put "test-file-a.tl" '(compile-only (put-line "a"))) + (file-put "test-file-b.tl" '(compile-only (put-line "b"))) + + (compile-update-file "./test-file-a") + (compile-update-file "./test-file-b") + + (gzip "test-file-a.tlo" "test-file-b.tlo") + + (cat "test-file-combined.tlo.gz" "test-file-a.tlo.gz" "test-file-b.tlo.gz") + + (test + (with-out-string-stream (*stdout*) + (load "./test-file-combined.tlo.gz")) + "a\nb\n")) + +(when %have-gzip% + (with-stream (s (open-command "echo abc | gzip -c" "z")) + (test (get-line s) "abc"))) diff --git a/tests/018/noclose.expected b/tests/018/noclose.expected new file mode 100644 index 00000000..cad99e12 --- /dev/null +++ b/tests/018/noclose.expected @@ -0,0 +1 @@ +caught diff --git a/tests/018/noclose.txr b/tests/018/noclose.txr new file mode 100644 index 00000000..cf39b702 --- /dev/null +++ b/tests/018/noclose.txr @@ -0,0 +1,16 @@ +@(next :list [mapcar tostring (range 1 20000)]) +@(collect) +@num +@(next self-path) +@line +@(end) +@(try) +@(next :list [mapcar tostring (range 1 20000)]) +@(collect) +@num +@(next "data") +@line +@(end) +@(catch) +@(do (put-line "caught")) +@(end) diff --git a/tests/018/path-equal.tl b/tests/018/path-equal.tl new file mode 100644 index 00000000..704c414a --- /dev/null +++ b/tests/018/path-equal.tl @@ -0,0 +1,17 @@ +(load "../common") + +(mtest + (path-equal "a" "a") t + (path-equal "a" "b") nil + (path-equal "/a" "a") nil + + (path-equal "a" "a/") t + (path-equal "a/" "a/") t + + (path-equal "a/b/../c" "a/c") t + + (path-equal "a" "a/././.") t + (path-equal "a/." "a/././.") t + + (path-equal "/.." "/") t + (path-equal "/../a" "/a/") t) diff --git a/tests/018/path-safe.tl b/tests/018/path-safe.tl new file mode 100644 index 00000000..77b92321 --- /dev/null +++ b/tests/018/path-safe.tl @@ -0,0 +1,105 @@ +(load "../common") + +;; only root can do this test +(unless (zerop (geteuid)) + (exit)) + +(defvarl testdir (mkdtemp `/tmp/txr-path-safe-test`)) + +(push-after-load (remove-path-rec testdir)) + +(chmod testdir "a+rX") + +(defvarl atestdir (realpath testdir)) +(defvarl tmpdir (path-cat testdir "tmp")) + +(mkdir tmpdir) +(defvarl atmpdir (realpath tmpdir)) +(ensure-dir tmpdir) +(chmod tmpdir "a+rwt") + +(seteuid 10000) +(touch (path-cat tmpdir "10000")) +(symlink "/" (path-cat tmpdir "10000-link")) +(seteuid 0) + +(seteuid 20000) +(touch (path-cat tmpdir "20000")) +(symlink "/" (path-cat tmpdir "20000-link")) +(seteuid 0) + +(mtest + (path-components-safe tmpdir) t + (path-components-safe (path-cat tmpdir "10000")) nil + (path-components-safe (path-cat tmpdir "10000-link")) nil + (path-components-safe (path-cat tmpdir "20000")) nil) + +(mtest + (path-components-safe atmpdir) t + (path-components-safe (path-cat atmpdir "10000")) nil + (path-components-safe (path-cat atmpdir "10000-link")) nil + (path-components-safe (path-cat atmpdir "20000")) nil) + +(seteuid 10000) + +(mtest + (path-components-safe atmpdir) t + (path-components-safe (path-cat tmpdir "10000")) t + (path-components-safe (path-cat tmpdir "10000-link")) t + (path-components-safe (path-cat tmpdir "20000")) nil + (path-components-safe (path-cat tmpdir "20000-link")) nil) + +(mtest + (path-components-safe atmpdir) t + (path-components-safe (path-cat atmpdir "10000")) t + (path-components-safe (path-cat atmpdir "10000-link")) t + (path-components-safe (path-cat atmpdir "20000")) nil + (path-components-safe (path-cat atmpdir "20000-link")) nil) + +(symlink "loop/x/y" (path-cat tmpdir "loop")) + +(test + (path-components-safe (path-cat tmpdir "loop/z")) :error) + +(chdir tmpdir) +(symlink "b/c" "a") +(ensure-dir "b") +(symlink "x" "b/c") +(touch "b/x") + +(test + (path-components-safe "a") t) + +(remove-path "b/c") + +(test + (path-components-safe "a") :error) + +(seteuid 0) +(seteuid 20000) +(symlink "x" "z") + +(seteuid 0) +(rename-path "z" "b/c") + +(each ((uid '(10000 0))) + (mtest + (path-components-safe "a") nil + (path-components-safe "/proc/1") t + (path-components-safe "/proc/1/fd") t + (path-components-safe "/proc/sys/../1") t + (path-components-safe "/proc/1/cwd") nil + (path-components-safe "/proc/1/cwd/foo") nil + (path-components-safe "/proc/self/cwd") nil + (path-components-safe "/proc/self/cwd/foo") nil + (path-components-safe "/proc/1/root") nil + (path-components-safe "/proc/1/root/foo") nil + (path-components-safe "/proc/1/fd/0") nil + (path-components-safe "/proc/1/fd/0/bar") nil + (path-components-safe "/proc/1/map_files") nil + (path-components-safe "/proc/1/map_files/bar") nil + (path-components-safe "/proc/sys/../1/cwd") nil + (path-components-safe "/proc/1/task/1") t + (path-components-safe "/proc/1/task/1/fd/0") nil + (path-components-safe "/proc/1/task/1/cwd") nil + (path-components-safe "/proc/1/task/1/root") nil))1 diff --git a/tests/018/path-test.tl b/tests/018/path-test.tl new file mode 100644 index 00000000..d3aa6dce --- /dev/null +++ b/tests/018/path-test.tl @@ -0,0 +1,22 @@ +(load "../common") + +(unless (path-executable-to-me-p "/bin/sh") + (exit 0)) + +(mtest + (ends-with "/bin/sh" (path-search "sh")) t + (path-search "AlMoStCeRtAiNlLyNoNeXisTenT") nil + (path-search "") nil + (path-search "sh" nil) nil + (path-search "sh" '("AlMoStCeRtAiNlLyNoNeXisTenT")) nil + (path-search "sh" '("AlMoStCeRtAiNlLyNoNeXisTenT" "/bin")) "/bin/sh" + (path-search "sh" '("/bin")) "/bin/sh" + (path-search "sh" "AlMoStCeRtAiNlLyNoNeXisTenT") nil + (path-search "sh" "AlMoStCeRtAiNlLyNoNeXisTenT:/bin") "/bin/sh" + (path-search "sh" "/bin") "/bin/sh" + (path-search "sh" "/bin/") "/bin/sh" + (path-search "sh" ":/bin/") "/bin/sh" + (path-search "" "/bin") nil + (path-search "." "/bin") nil + (path-search ".." "/bin") nil + (path-search "foo/bar" "/bin") "foo/bar") diff --git a/tests/018/path.tl b/tests/018/path.tl new file mode 100644 index 00000000..dd22339f --- /dev/null +++ b/tests/018/path.tl @@ -0,0 +1,320 @@ +(load "../common") + +(mtest + (short-suffix 42) :error + (short-suffix #\a) :error + (short-suffix "") nil + (short-suffix "" 0) 0 + (short-suffix "a") nil + (short-suffix "a" 0) 0 + (short-suffix ".") nil + (short-suffix "a.") "." + (short-suffix "a.b.") "." + (short-suffix ".c") nil + (short-suffix "a.c") ".c" + (short-suffix ".a.c") ".c" + (short-suffix "a.b.c") ".c" + (short-suffix "foo.txt.gz") ".gz" + (short-suffix "txt.gz") ".gz" + (short-suffix ".gz") nil) + +(mtest + (long-suffix 42) :error + (long-suffix #\a) :error + (long-suffix "") nil + (long-suffix "" 0) 0 + (long-suffix "a") nil + (long-suffix "a" 0) 0 + (long-suffix ".") nil + (long-suffix "a.") "." + (long-suffix "a.b.") ".b." + (long-suffix ".c") nil + (long-suffix "a.c") ".c" + (long-suffix "a.b.c") ".b.c" + (long-suffix "foo.txt.gz") ".txt.gz" + (long-suffix ".gz") nil + (long-suffix ".txt.gz") ".gz" + (long-suffix "/.txt.gz") ".gz" + (long-suffix "a/.txt.gz") ".gz" + (long-suffix "a/.txt.tar.gz") ".tar.gz") + +(mtest + (short-suffix "/") nil + (short-suffix "a/") nil + (short-suffix "/.") nil + (short-suffix "a/.") nil + (short-suffix ".a/") nil + (short-suffix ".a/b") nil + (short-suffix ".a/c.b") ".b" + (short-suffix ".a/b/") nil + (short-suffix ".a/b/.b") nil + (short-suffix ".a/b/.b/") nil + (short-suffix ".a/b/c.b") ".b" + (short-suffix ".a/b/c.b/") ".b" + (short-suffix ".a/b/c.b//") ".b" + (short-suffix ".a/b/c.b///") ".b" + (short-suffix ".a/b/c.") "." + (short-suffix ".a/b/c./") "." + (short-suffix ".a/b/c.//") "." + (short-suffix ".a/b/c.///") ".") + +(mtest + (long-suffix "/") nil + (long-suffix "a/") nil + (long-suffix "/.") nil + (long-suffix "a/.") nil + (long-suffix ".a/") nil + (long-suffix ".a/b") nil + (long-suffix ".a/b/") nil + (long-suffix ".a/b/.b") nil + (long-suffix ".a/b/.b/") nil + (long-suffix ".a/b/c.b") ".b" + (long-suffix ".a/b/c.b/") ".b" + (long-suffix "a.b/c.d.e") ".d.e" + (long-suffix "a.b/c.d.e/") ".d.e" + (long-suffix "a.b/c.d.e/f") nil + (long-suffix "a.b/c.d.e/f.g.h") ".g.h" + (long-suffix "a.b/c.d.e//") ".d.e" + (long-suffix "a.b/c.d.e///") ".d.e" + (long-suffix "a.b/c.d.") ".d." + (long-suffix "a.b/c.d./") ".d." + (long-suffix "a.b/c.d.//") ".d." + (long-suffix "a.b/c.d.///") ".d." + (long-suffix "a.b/c.") "." + (long-suffix "a.b/c./") "." + (long-suffix "a.b/c.//") "." + (long-suffix "a.b/c.///") ".") + +(mtest + (trim-short-suffix "") "" + (trim-short-suffix ".") "." + (trim-short-suffix "/.") "/." + (trim-short-suffix ".b") ".b" + (trim-short-suffix ".a.b") ".a" + (trim-short-suffix ".a.b.c") ".a.b" + (trim-short-suffix "/.b") "/.b" + (trim-short-suffix "/.b/") "/.b/" + (trim-short-suffix "/.b//") "/.b//" + (trim-short-suffix "a.b") "a" + (trim-short-suffix "/a.b") "/a" + (trim-short-suffix "/a.b/") "/a/" + (trim-short-suffix "/a.b//") "/a//" + (trim-short-suffix "a.") "a" + (trim-short-suffix "/a.") "/a" + (trim-short-suffix "/a./") "/a/" + (trim-short-suffix "/a.//") "/a//") + +(mtest + (trim-long-suffix "") "" + (trim-long-suffix ".") "." + (trim-long-suffix "/.") "/." + (trim-long-suffix ".b") ".b" + (trim-long-suffix ".a.b") ".a" + (trim-long-suffix ".a.b.c") ".a" + (trim-long-suffix "/.b") "/.b" + (trim-long-suffix "/.b/") "/.b/" + (trim-long-suffix "/.b//") "/.b//" + (trim-long-suffix "a.b") "a" + (trim-long-suffix "/a.b") "/a" + (trim-long-suffix "/a.b/") "/a/" + (trim-long-suffix "/a.b//") "/a//" + (trim-long-suffix "/.b.c") "/.b" + (trim-long-suffix "/.b.c/") "/.b/" + (trim-long-suffix "/.b.c//") "/.b//" + (trim-long-suffix "/.b.c.d") "/.b" + (trim-long-suffix "/.b.c.d/") "/.b/" + (trim-long-suffix "/.b.c.d//") "/.b//" + (trim-long-suffix "a.b.c") "a" + (trim-long-suffix "/a.b.c") "/a" + (trim-long-suffix "/a.b.c/") "/a/" + (trim-long-suffix "/a.b.c//") "/a//" + (trim-long-suffix "a.") "a" + (trim-long-suffix "/a.") "/a" + (trim-long-suffix "/a./") "/a/" + (trim-long-suffix "/a.//") "/a//") + +(mtest + (add-suffix "" "") "" + (add-suffix "" "a") "a" + (add-suffix "." "a") ".a" + (add-suffix "." ".a") "..a" + (add-suffix "/" ".b") "/.b" + (add-suffix "//" ".b") "/.b/" + (add-suffix "//" "b") "/b/" + (add-suffix "a" "") "a" + (add-suffix "a" ".b") "a.b" + (add-suffix "a/" ".b") "a.b/" + (add-suffix "a//" ".b") "a.b//" + + (add-suffix "c://" "x") "c:/x/" + (add-suffix "0://" "x") "0:/x/" + (add-suffix "host://" "x") "host://x" + (add-suffix "host:///" "x") "host://x/" + (add-suffix "1234:///" "x") "1234://x/") + +(mtest + (base-name "") "" + (base-name "/") "/" + (base-name ".") "." + (base-name "./") "." + (base-name "a") "a" + (base-name "a/") "a" + (base-name "/a") "a" + (base-name "/a/") "a" + (base-name "/a/b") "b" + (base-name "/a/b/") "b" + (base-name "/a/b//") "b" + (base-name "/a/b///") "b") + +(mtest + (base-name "" "") "" + (base-name "/" "/") "/" + (base-name "/" "") "/" + (base-name "." ".") "." + (base-name "." "") "." + (base-name "./" "/") "." + (base-name "a" "a") "a" + (base-name "a" "") "a" + (base-name "a.b" ".b") "a" + (base-name "a.b/" ".b") "a" + (base-name "a.b/" ".b/") "a.b" + (base-name "a.b/" "a.b") "a.b") + +(mtest + (path-cat "" "") "" + (path-cat "" ".") "." + (path-cat "." "") "." + (path-cat "." ".") "." + (path-cat "abc" ".") "abc" + (path-cat "." "abc") "abc" + (path-cat "./" ".") "./" + (path-cat "." "./") "./" + (path-cat "abc/" ".") "abc/" + (path-cat "./" "abc") "abc" + (path-cat "/" ".") "/" + (path-cat "/" "abc") "/abc" + (path-cat "ab/cd" "ef") "ab/cd/ef" + (path-cat "a" "b" "c") "a/b/c" + (path-cat "a" "b" "" "c" "/") "a/b/c/") + +(mtest + (path-cat) "." + (path-cat 3) :error + (path-cat "") "" + (path-cat "/") "/" + (path-cat ".") "." + (path-cat "" "" "") "" + (path-cat "." "" "") "." + (path-cat "" "." "") "." + (path-cat "" "" ".") "." + (path-cat "." "." ".") "." + (path-cat "abc/" "/def/" "g") "abc/def/g" + (path-cat "abc/" "/def/" "g/") "abc/def/g/" + (path-cat "" "abc/" "/def/" "g/") "abc/def/g/") + +(mtest + (abs-path-p "") nil + (abs-path-p "/") t + (abs-path-p "/abc") t + (abs-path-p "abc") nil + (abs-path-p ".") nil) + +(if (eql [path-sep-chars 0] #\\) + (mtest + (abs-path-p "\\abc") t + (abs-path-p "a:\\abc") t + (abs-path-p "0:\\abc") t + (abs-path-p "AB0:\\abc") t + (abs-path-p "cd5:\\abc") t + (abs-path-p "a:/abc") t + (abs-path-p "0:/abc") t + (abs-path-p "AB0:/abc") t + (abs-path-p "cd5:/abc") t) + (mtest + (abs-path-p "\\abs") nil + (abs-path-p "a:\\abc") nil + (abs-path-p "0:\\abc") nil + (abs-path-p "AB0:\\abc") nil + (abs-path-p "cd5:\\abc") nil + (abs-path-p "a:/abc") nil + (abs-path-p "0:/abc") nil + (abs-path-p "AB0:/abc") nil + (abs-path-p "cd5:/abc") nil)) + +(mtest + (portable-abs-path-p "") nil + (portable-abs-path-p "/") t + (portable-abs-path-p "/abc") t + (portable-abs-path-p "\\abc") t + (portable-abs-path-p "abc") nil + (portable-abs-path-p ".") nil + (portable-abs-path-p "\\abc") t + (portable-abs-path-p "a:\\abc") t + (portable-abs-path-p "0:\\abc") t + (portable-abs-path-p "AB0:\\abc") t + (portable-abs-path-p "cd5:\\abc") t + (portable-abs-path-p "a:/abc") t + (portable-abs-path-p "0:/abc") t + (portable-abs-path-p "AB0:/abc") t + (portable-abs-path-p "cd5:/abc") t) + +(mtest + (pure-rel-path-p "") t + (pure-rel-path-p "/") nil + (pure-rel-path-p "\\") nil + (pure-rel-path-p "/abc") nil + (pure-rel-path-p ".") nil + (pure-rel-path-p "./") nil + (pure-rel-path-p ".\\") nil + (pure-rel-path-p ".abc") t + (pure-rel-path-p ".abc/") t + (pure-rel-path-p ".abc\\") t + (pure-rel-path-p ":") t + (pure-rel-path-p "a:") nil + (pure-rel-path-p "A:") nil + (pure-rel-path-p "0:") nil + (pure-rel-path-p "9:") nil + (pure-rel-path-p "_:") t + (pure-rel-path-p "abc") t + (pure-rel-path-p "abc/def") t + (pure-rel-path-p "abc/.") t + (pure-rel-path-p "abc\\def") t + (pure-rel-path-p "abc\\.") t) + +(mtest + (trim-path-seps "") "" + (trim-path-seps "/") "/" + (trim-path-seps "//") "/" + (trim-path-seps "///") "/" + (trim-path-seps "a///") "a" + (trim-path-seps "/a///") "/a") + +(mtest + (trim-path-seps "c:/") "c:/" + (trim-path-seps "c://") "c:/" + (trim-path-seps "c:///") "c:/" + (trim-path-seps "c:a///") "c:a" + (trim-path-seps "/c:/a///") "/c:/a" + (trim-path-seps "/c://///") "/c:") + +(mtest + (trim-path-seps "\\") "\\" + (trim-path-seps "\\\\") "\\" + (trim-path-seps "\\\\\\") "\\" + (trim-path-seps "a\\\\\\") "a" + (trim-path-seps "\\a\\\\\\") "\\a") + +(mtest + (trim-path-seps "c:\\") "c:\\" + (trim-path-seps "c:\\\\") "c:\\" + (trim-path-seps "c:\\\\\\") "c:\\" + (trim-path-seps "c:a\\\\\\") "c:a" + (trim-path-seps "\\c:\\a\\\\\\") "\\c:\\a" + (trim-path-seps "\\c:\\\\\\\\\\") "\\c:") + +(mtest + (trim-path-seps "/c:\\") "/c:" + (trim-path-seps "c:/\\/\\/") "c:/" + (trim-path-seps "c:a\\\\\\") "c:a" + (trim-path-seps "\\c:\\a/\\\\\\") "\\c:\\a" + (trim-path-seps "/c:\\\\\\\\\\") "/c:") diff --git a/tests/018/process.tl b/tests/018/process.tl new file mode 100644 index 00000000..58a12fa2 --- /dev/null +++ b/tests/018/process.tl @@ -0,0 +1,36 @@ +(load "../common") + +(unless (path-executable-to-me-p "/bin/sh") + (exit 0)) + +(defun cmd (c : (m "r")) + (with-stream (s (open-command c m)) + (get-string s))) + +(mtest + (cmd "echo foo") "foo\n" + (cmd "echo foo" ">1n") "" + (cmd "echo foo 1>&2" ">21") "foo\n") + +(defmacro fcmd (. forms) + ^(with-stream (s (open-subprocess nil "r" nil (lambda () ,*forms))) + (get-string s))) + +(mtest + (fcmd (let ((*stdout* *stdnull*)) (sh "echo foo"))) "" + (fcmd (let ((*stderr* *stdout*)) (sh "echo foo 1>&2"))) "foo\n") + +(caseq (os-symbol) + ((:cygwin :cygnal)) + (t (mtest + (let ((*child-env* '("a=b"))) + (get-lines (open-process "/usr/bin/env" "r"))) + ("a=b") + (let ((*child-env* nil)) + (get-lines (open-process "/usr/bin/env" "r"))) + nil) + (test + (fcmd + (let ((*child-env* '("a=b"))) + (run "/usr/bin/env"))) + "a=b\n"))) diff --git a/tests/018/rel-path.tl b/tests/018/rel-path.tl new file mode 100644 index 00000000..11651c17 --- /dev/null +++ b/tests/018/rel-path.tl @@ -0,0 +1,25 @@ +(load "../common") + +(mtest + (rel-path "/abc" "abc") :error + (rel-path "abc" "/abc") :error + (rel-path "." ".") "." + (rel-path "./abc" "abc") "." + (rel-path "abc" "./abc") "." + (rel-path "./abc" "./abc") "." + (rel-path "abc" "abc") "." + (rel-path "." "abc") "abc" + (rel-path "abc/def" "abc/ghi") "../ghi" + (rel-path "xyz/../abc/def" "abc/ghi") "../ghi" + (rel-path "abc" "d/e/f/g/h") "../d/e/f/g/h" + (rel-path "abc" "d/e/../g/h") "../d/g/h" + (rel-path "d/e/../g/h" ".") "../../.." + (rel-path "d/e/../g/h" "a/b") "../../../a/b" + (rel-path "x" "../../../y") "../../../../y" + (rel-path "x///" "x") "." + (rel-path "x" "x///") "." + (rel-path "///x" "/x") "." + (rel-path "../../x" "y") :error + (rel-path "" "") "." + (rel-path "a" "") ".." + (rel-path "" "a") "a") diff --git a/tests/018/sh-esc.tl b/tests/018/sh-esc.tl new file mode 100644 index 00000000..f508475e --- /dev/null +++ b/tests/018/sh-esc.tl @@ -0,0 +1,58 @@ +(load "../common") + +(mtest + (sh-esc "") "" + (sh-esc "a") "a") + +(mtest + (sh-esc "|") "\"|\"" + (sh-esc "&") "\"&\"" + (sh-esc ";") "\";\"" + (sh-esc "<") "\"<\"" + (sh-esc ">") "\">\"" + (sh-esc "(") "\"(\"" + (sh-esc ")") "\")\"" + (sh-esc " ") "\" \"" + (sh-esc "\t") "\"\t\"" + (sh-esc "\n") "\"\n\"" + (sh-esc "*") "\"*\"" + (sh-esc "?") "\"?\"" + (sh-esc "[") "\"[\"" + (sh-esc "#") "\"#\"" + (sh-esc "~") "\"~\"") + +(mtest + (sh-esc "'") "\"'\"") + +(mtest + (sh-esc "\"") "'\"'" + (sh-esc "$") "'$'" + (sh-esc "`") "'`'" + (sh-esc "\\") "'\\'") + +(mtest + (sh-esc "=") "=" + (sh-esc "%") "%" + (sh-esc-all "=") "\"=\"" + (sh-esc-all "%") "\"%\"") + +(test + (sh-esc "a\"b'c") "'a\"b'\\''c'") + +(mtest + (sh-esc "|'") "\"|'\"" + (sh-esc "|\"") "'|\"'" + (sh-esc "'$") "''\\''$'") + +(mtest + (sh-esc-all "|=") "\"|=\"" + (sh-esc-all "'=") "\"'=\"" + (sh-esc-all "\"=") "'\"='") + +(mtest + (sh-esc "|&;<>() \t\n*?[#~") "\"|&;<>() \t\n*?[#~\"" + (sh-esc "\"$`\\") "'\"$`\\'") + +(mtest + (sh-esc-dq "$`\\\"\n'abc()*~") "\\$\\`\\\\\\\"\n'abc()*~" + (sh-esc-sq "$`\\\"\n'abc()*~") "$`\\\"\n'\\''abc()*~") diff --git a/tests/019/comp-bugs.tl b/tests/019/comp-bugs.tl new file mode 100644 index 00000000..c2cb2ad7 --- /dev/null +++ b/tests/019/comp-bugs.tl @@ -0,0 +1,6 @@ +(load "../common") + +(set *compile-test* t) + +(test + (prof (for ((i 42)) ((< i 42) i) ())) (42 0 0 0)) diff --git a/tests/019/compile-package.tl b/tests/019/compile-package.tl new file mode 100644 index 00000000..2028b913 --- /dev/null +++ b/tests/019/compile-package.tl @@ -0,0 +1,7 @@ +(defpackage :foo) + +(compile-file "data/program.tl") + +(delete-package :foo) + +(load "data/program.tlo") diff --git a/tests/019/data/a b/tests/019/data/a new file mode 100755 index 00000000..8fbed4f6 --- /dev/null +++ b/tests/019/data/a @@ -0,0 +1,3 @@ +@(output) +a +@(end) diff --git a/tests/019/data/a.tl b/tests/019/data/a.tl new file mode 100755 index 00000000..6f25fed5 --- /dev/null +++ b/tests/019/data/a.tl @@ -0,0 +1 @@ +(put-line "a.tl") diff --git a/tests/019/data/a.tlo b/tests/019/data/a.tlo new file mode 100755 index 00000000..40f39e81 --- /dev/null +++ b/tests/019/data/a.tlo @@ -0,0 +1,2 @@ +(7 0 nil) +((2 3 #b'0200012000000004 02000010' #("a.tlo") #(usr:put-line))) diff --git a/tests/019/data/a.txr b/tests/019/data/a.txr new file mode 100755 index 00000000..ceab552d --- /dev/null +++ b/tests/019/data/a.txr @@ -0,0 +1,3 @@ +@(output) +a.txr +@(end) diff --git a/tests/019/data/b.tl b/tests/019/data/b.tl new file mode 100755 index 00000000..46c6dd30 --- /dev/null +++ b/tests/019/data/b.tl @@ -0,0 +1 @@ +(put-line "b.tl") diff --git a/tests/019/data/b.tlo b/tests/019/data/b.tlo new file mode 100755 index 00000000..2f432257 --- /dev/null +++ b/tests/019/data/b.tlo @@ -0,0 +1,2 @@ +(7 0 nil) +((2 3 #b'0200012000000004 02000010' #("b.tlo") #(usr:put-line))) diff --git a/tests/019/data/b.txr b/tests/019/data/b.txr new file mode 100755 index 00000000..0b8883e0 --- /dev/null +++ b/tests/019/data/b.txr @@ -0,0 +1,3 @@ +@(output) +b.txr +@(end) diff --git a/tests/019/data/c.tl b/tests/019/data/c.tl new file mode 100755 index 00000000..b9e018ea --- /dev/null +++ b/tests/019/data/c.tl @@ -0,0 +1 @@ +(put-line "c.tl") diff --git a/tests/019/data/c.txr b/tests/019/data/c.txr new file mode 100755 index 00000000..19995e8a --- /dev/null +++ b/tests/019/data/c.txr @@ -0,0 +1,3 @@ +@(output) +c.txr +@(end) diff --git a/tests/019/data/program.tl b/tests/019/data/program.tl new file mode 100644 index 00000000..e97acbc5 --- /dev/null +++ b/tests/019/data/program.tl @@ -0,0 +1,5 @@ +(defpackage :foo (:fallback usr)) + +(in-package :foo) + +(defun foo:fun ()) diff --git a/tests/019/load-args.tl b/tests/019/load-args.tl new file mode 100644 index 00000000..bd0037f1 --- /dev/null +++ b/tests/019/load-args.tl @@ -0,0 +1,72 @@ +(load "../common") + +(defvar *trace*) + +(defmacro deftrace (fun) + ^(defun ,fun (. args) + (push ^(,%fun% ,*args) *trace*))) + +(handle + (eval '(progn + (deftrace load) + (deftrace compile-update-file) + (deftrace clean-file))) + (warning (x . rest) + (throw 'continue))) + +(defmacro tr (form) + ^(let ((*trace* nil)) + ,form + (reverse *trace*))) + +(mtest + (tr (load-args-recurse '("abc"))) ((load "abc")) + (tr (load-args-recurse "abc")) ((load "abc")) + (tr (load-args-recurse "abc" "def")) ((load "abc") (load "def")) + (tr (load-args-recurse '("abc") "def")) ((load ("abc")) (load "def"))) + +(let ((*load-args* '(1 2))) + (mtest + (tr (load-args-recurse '("abc"))) ((load "abc" 1 2)) + (tr (load-args-recurse "abc")) ((load "abc" 1 2)) + (tr (load-args-recurse "abc" "def")) ((load "abc" 1 2) (load "def" 1 2)) + (tr (load-args-recurse '("abc") "def")) ((load ("abc") 1 2) (load "def" 1 2)))) + +(mtest + (tr (load-args-process '("abc"))) ((load "abc")) + (tr (load-args-process "abc")) ((load "abc")) + (tr (load-args-process "abc" "def")) ((load "abc") (load "def")) + (tr (load-args-process '("abc") "def")) ((load ("abc")) (load "def"))) + +(let ((*load-args* '(1 2))) + (mtest + (tr (load-args-process '("abc"))) ((load "abc" 1 2)) + (tr (load-args-process "abc")) ((load "abc" 1 2)) + (tr (load-args-process "abc" "def")) ((load "abc" 1 2) (load "def" 1 2)) + (tr (load-args-process '("abc") "def")) ((load ("abc") 1 2) (load "def" 1 2)))) + +(let ((*load-args* '(:compile))) + (mtest + (tr (load-args-process '("abc"))) ((compile-update-file "load-args.tl") + (compile-update-file "abc")) + (tr (load-args-process "abc")) ((compile-update-file "load-args.tl") + (compile-update-file "abc")) + (tr (load-args-process "abc" "def")) ((compile-update-file "load-args.tl") + (compile-update-file "abc") + (compile-update-file "def")) + (tr (load-args-process '("abc") "def")) ((compile-update-file "load-args.tl") + (compile-update-file ("abc")) + (compile-update-file "def")))) + +(let ((*load-args* '(:clean))) + (mtest + (tr (load-args-process '("abc"))) ((clean-file "load-args.tl") + (clean-file "abc")) + (tr (load-args-process "abc")) ((clean-file "load-args.tl") + (clean-file "abc")) + (tr (load-args-process "abc" "def")) ((clean-file "load-args.tl") + (clean-file "abc") + (clean-file "def")) + (tr (load-args-process '("abc") "def")) ((clean-file "load-args.tl") + (clean-file ("abc")) + (clean-file "def")))) diff --git a/tests/019/load-hook.tl b/tests/019/load-hook.tl new file mode 100644 index 00000000..af0b9860 --- /dev/null +++ b/tests/019/load-hook.tl @@ -0,0 +1,28 @@ +(load "../common") + +(defvarl %dir% (dir-name *load-path*)) + +(compile-file "../load-hook") +(test counter 0) + +(push (lambda () + (remove-path (path-cat %dir% "../load-hook.tlo"))) + *load-hooks*) + +(set counter nil) +(load "../load-hook.tl") +(test counter 1) + +(set counter nil) +(load "../load-hook.tlo") +(test counter 1) + +(mtest + (macroexpand-1 '(push-after-load)) + (sys:setq *load-hooks* (cons (lambda ()) *load-hooks*)) + + (macroexpand-1 '(push-after-load x)) + (sys:setq *load-hooks* (cons (lambda () x) *load-hooks*)) + + (macroexpand-1 '(pop-after-load)) + (sys:setq *load-hooks* (cdr *load-hooks*))) diff --git a/tests/019/load-ret.tl b/tests/019/load-ret.tl new file mode 100644 index 00000000..1c99281f --- /dev/null +++ b/tests/019/load-ret.tl @@ -0,0 +1,23 @@ +(load "../common") + +(mtest + (load "load-ret/module") 0 + (load "load-ret/module" 1) 1 + (load "load-ret/module" 1 2 3) 6) + +(mtest + (load-for (var abc "load-ret/module2" 'abc)) 0 + (load-for (var def "load-ret/module2" 'def 1 2 3)) 6 + (load-for (var abc "load-ret/module2" 'abc)) nil + (load-for (var abc "load-ret/module2" 'abc) + (var ghi "load-ret/module2" 'ghi 2 3 4)) 9) + +(defvarl here (dir-name self-path)) + +(mtest + (sh `@{txr-exe-path} @here/load-ret/script.tl 0`) 0 + (sh `@{txr-exe-path} @here/load-ret/script.tl 1`) 1 + (sh `@{txr-exe-path} @here/load-ret/script.tl 7`) 7) + +(test + (sh `@{txr-exe-path} @here/load-ret/bad.tl 1 2> /dev/null`) 1) diff --git a/tests/019/load-ret/bad.tl b/tests/019/load-ret/bad.tl new file mode 100644 index 00000000..2d06f376 --- /dev/null +++ b/tests/019/load-ret/bad.tl @@ -0,0 +1 @@ +( diff --git a/tests/019/load-ret/module.tl b/tests/019/load-ret/module.tl new file mode 100644 index 00000000..05d69035 --- /dev/null +++ b/tests/019/load-ret/module.tl @@ -0,0 +1 @@ +(return-from load [apply + *load-args*]) diff --git a/tests/019/load-ret/module2.tl b/tests/019/load-ret/module2.tl new file mode 100644 index 00000000..e651c3f5 --- /dev/null +++ b/tests/019/load-ret/module2.tl @@ -0,0 +1,2 @@ +(eval ^(defvar ,(pop *load-args*))) +(return-from load [apply + *load-args*]) diff --git a/tests/019/load-ret/script.tl b/tests/019/load-ret/script.tl new file mode 100644 index 00000000..8e13dabf --- /dev/null +++ b/tests/019/load-ret/script.tl @@ -0,0 +1 @@ +(return-from load (toint [*args* 0])) diff --git a/tests/019/load-search.tl b/tests/019/load-search.tl new file mode 100644 index 00000000..3ba29790 --- /dev/null +++ b/tests/019/load-search.tl @@ -0,0 +1,69 @@ +(load "../common") + +(defvarl cur (dir-name *load-path*)) + +(defun txr (. args) + (command-get-string `@{txr-exe-path} @{args " "}`)) + +(defun lod (x) + (with-out-string-stream (*stdout*) + (load x))) + +(mtest + (txr `@cur/data/a`) "a\n" + (txr `@cur/data/a.txr`) "a.txr\n" + (txr `@cur/data/a.tl`) "a.tl\n" + (txr `@cur/data/a.tlo`) "a.tlo\n") + +(mtest + (txr `@cur/data/b`) "b.txr\n" + (txr `@cur/data/b.txr`) "b.txr\n" + (txr `@cur/data/b.tl`) "b.tl\n" + (txr `@cur/data/b.tlo`) "b.tlo\n") + +(mtest + (txr `@cur/data/c`) "c.txr\n" + (txr `@cur/data/c.txr`) "c.txr\n" + (txr `@cur/data/c.tl`) "c.tl\n") + +(let ((*stderr* *stdnull*)) + (mtest + (txr "--lisp" `@cur/data/a`) "" + (txr "--compiled" `@cur/data/a`) "")) + +(mtest + (txr "--lisp" `@cur/data/b`) "b.tlo\n" + (txr "--compiled" `@cur/data/b`) "b.tlo\n") + +(mtest + (txr "--lisp" `@cur/data/c`) "c.tl\n" + (txr "--compiled" `@cur/data/c`) "c.tl\n") + +(mtest + (length *load-search-dirs*) 1 + (base-name (car *load-search-dirs*)) "lib") + +(set *load-search-dirs* (list `@cur/data`)) + +(mtest + (lod "a") :error + (lod "a.tl") "a.tl\n" + (lod "c") "c.tl\n") + +(push `@cur/nonexistent` *load-search-dirs*) + +(mtest + (lod "a") :error + (lod "a.tl") "a.tl\n" + (lod "c") "c.tl\n") + + +(unless (or (meq (os-symbol) :cygwin :cygnal) + (zerop (geteuid))) + (push `@cur/unreadable` *load-search-dirs*) + (push-after-load (rmdir `@cur/unreadable`)) + (ensure-dir `@cur/unreadable` 0) + (mtest + (lod "a") :error + (lod "a.tl") :error + (lod "c") :error)) diff --git a/tests/019/load-time.tl b/tests/019/load-time.tl new file mode 100644 index 00000000..1a326aa2 --- /dev/null +++ b/tests/019/load-time.tl @@ -0,0 +1,30 @@ +(load "../common") + +(defvarl list) + +(test + [(compile-toplevel '(progn + (push 0 list) + (load-time (push 1 list)) + list))] + (0 1)) + +(zap list) + +(test + [(compile-toplevel '(progn + (push 0 list) + (lambda () + (load-time (push 1 list))) + list))] + (0 1)) + +(zap list) + +(test + [(compile-toplevel '(progn + (load-time (push 0 list)) + (lambda () + (load-time (push 1 list))) + list))] + (1 0)) diff --git a/tests/019/pct-fun.expected b/tests/019/pct-fun.expected new file mode 100644 index 00000000..d7da7ee4 --- /dev/null +++ b/tests/019/pct-fun.expected @@ -0,0 +1,18 @@ +(foo :init) +(foo :postinit) +(foo foo) +(foo bar) +(foo :fini) +(foo :postfini) +function +function2 +mac +(foo :init) +(foo :postinit) +(foo foo) +(foo bar) +(foo :fini) +(foo :postfini) +function +function2 +mac diff --git a/tests/019/pct-fun.tl b/tests/019/pct-fun.tl new file mode 100644 index 00000000..6e45f299 --- /dev/null +++ b/tests/019/pct-fun.tl @@ -0,0 +1,42 @@ +(load "../common") + +(defstruct foo () + (:init (me) (prinl %fun%)) + (:fini (me) (prinl %fun%)) + (:postinit (me) (prinl %fun%)) + (:postfini (me) (prinl %fun%)) + (:method foo (me) (prinl %fun%))) + +(defmeth foo bar (me) + (prinl %fun%)) + +(defmeth foo pat (:match) + (prinl %fun%)) + +(defun function (: (optarg %fun%)) + (prinl %fun%)) + +(defun function2 (: (optarg %fun%)) + (prinl optarg)) + +(defmacro mac () + (prinl %fun%) + nil) + +(with-objects ((f (new foo))) + f.(foo) + f.(pat) + f.(bar)) + +(function) +(function2) + +(mac) + +(test %fun% nil) + +(compile-only + (eval-only + (with-compile-opts (nil unused) + (compile-file (base-name *load-path*) "temp.tlo")) + (remove-path "temp.tlo"))) diff --git a/tests/019/progv.tl b/tests/019/progv.tl new file mode 100644 index 00000000..7ab3aafe --- /dev/null +++ b/tests/019/progv.tl @@ -0,0 +1,29 @@ +(load "../common") + +(defvar a 42) +(defvar b 73) + +(mtest + (progv '(a) '(1) a) 1 + (progv '(a b) '(1 2) (cons a b)) (1 . 2) + (progv '(x) '(1) (let ((x 4)) (symbol-value 'x))) 1) + +(let ((n (list 'a 'b)) + (v (list 1 2))) + (mtest + (progv n v (cons a b)) (1 . 2))) + +(defvarl x) + +(let ((x 'lexical) + (vars (list 'x)) + (vals (list 'dynamic))) + (test + (progv vars vals (list x (symbol-value 'x))) + (lexical dynamic))) + +(compile-only + (eval-only + (with-compile-opts (nil unused) + (compile-file (base-name *load-path*) "temp.tlo")) + (remove-path "temp.tlo"))) diff --git a/tests/019/redef.tl b/tests/019/redef.tl new file mode 100644 index 00000000..943b5c3a --- /dev/null +++ b/tests/019/redef.tl @@ -0,0 +1,23 @@ +(load "../common") + +(defun foo () :foo) + +(defvar foov :foov) + +(defun bar () (list (foo) foov)) + +(compile 'bar) + +(test (bar) (:foo :foov)) + +(defun foo () :bar) + +(makunbound 'foov) + +(defparml foov :barv) + +(test (bar) (:bar :barv)) + +(defsymacro foov 42) + +(test (bar) :error) diff --git a/tests/019/symbol-value.tl b/tests/019/symbol-value.tl new file mode 100644 index 00000000..ca724f5a --- /dev/null +++ b/tests/019/symbol-value.tl @@ -0,0 +1,24 @@ +(load "../common") + +(defparm v 42) + +(mtest + v 42 + (symbol-value 'v) 42 + (set (symbol-value 'v) 73) 73 + (symbol-value 'v) 73 + v 73) + +(mtest + (let ((v 2)) v) 2 + (let ((v 2)) (symbol-value 'v)) 2 + (progn (let ((v 2)) (set (symbol-value 'v) 1)) v) 73 + (let ((v 2)) (set (symbol-value 'v) 1) v) 1 + v 73) + +(test + (progn + (let ((v 2)) + (set (symbol-value 'x) 73)) + x) + 73) diff --git a/tests/common.tl b/tests/common.tl index 3cd5df63..57f411fa 100644 --- a/tests/common.tl +++ b/tests/common.tl @@ -1,18 +1,55 @@ +(defvar *compile-test*) + (defmacro error-to-sym (expr) - ^(catch ,expr - (error (cond) :error))) + ^(catch ,expr + (error (cond) :error) + (warning (cond) :warning))) (defmacro vtest (:env env expr expected) - (catch - (let ((expr-expn (macroexpand expr env)) - (expval (gensym))) - ^(let ((,expval ,expected)) - (ifa (not (equal (error-to-sym ,expr-expn) ,expval)) - (error "test case ~s failed: produced ~s; expected ~s" - ',expr it ,expval)))) - (error (exc) - (unless (eq expected :error) - (error "test case ~s failed to expand: expected is ~s" expr expected))))) + (if-match (quote @(as sym @(or :error :warning))) expected + (set expected sym)) + (if *compile-test* + (with-compile-opts (nil unused) + (if (meq expected :error :warning) + (with-gensyms (code) + ^(let ((,code (catch + (compile-toplevel ',expr) + (error (exc) + (if (eq ,expected :warning) + (error "test case ~s produced error during compilation, expected ~s" + ',expr ,expected))) + (warning (exc) + (if (eq ,expected :error) + (error "test case ~s warned during compilation, expected ~s" + ',expr ,expected)))))) + (ifa (not (equal (error-to-sym (call ,code)) ,expected)) + (error "test case ~s failed: produced ~s; expected ~s" + ',expr it ,expected)))) + (with-gensyms (expval) + ^(let ((,expval ,expected)) + (ifa (not (equal (call (compile-toplevel ',expr)) ,expval)) + (error "test case ~s failed: produced ~s; expected ~s" + ',expr it ,expval)))))) + (if (meq expected :error :warning) + (catch + (let ((expr-expn (expand expr env))) + ^(ifa (not (equal (error-to-sym ,expr-expn) ,expected)) + (error "test case ~s failed: produced ~s; expected ~s" + ',expr it ,expected))) + (error (exc) + (if (eq expected :warning) + (error "test case ~s produced error during expansion, expected ~s" + expr expected))) + (warning (exc) + (if (eq expected :error) + (error "test case ~s warned during expansion, expected ~s" + expr expected)))) + (let ((expr-expn (expand expr env)) + (expval (gensym))) + ^(let ((,expval ,expected)) + (ifa (not (equal ,expr-expn ,expval)) + (error "test case ~s failed: produced ~s; expected ~s" + ',expr it ,expval))))))) (defmacro test (expr expected) ^(vtest ,expr ',expected)) @@ -20,20 +57,41 @@ (defmacro stest (expr expected) ^(vtest ,^(tostring ,expr) ,expected)) +(defmacro sstest (expr expected) + ^(vtest ,^(tostring ,expr) ,(tostring expected))) + (defmacro mtest (. pairs) ^(progn ,*(mapcar (op cons 'test) (tuples 2 pairs)))) +(defmacro mvtest (. pairs) + ^(progn ,*(mapcar (op cons 'vtest) (tuples 2 pairs)))) + +(defmacro mstest (. pairs) + ^(progn ,*(mapcar (op cons 'stest) (tuples 2 pairs)))) + (defun os-symbol () - (let ((u (uname))) - [(orf (iff (f^ #/Linux/) (ret :linux)) - (iff (f^ #/SunOS/) (ret :solaris)) - (iff (f^ #/CYGWIN/) (ret :cygwin)) - (iff (f^ #/CYGNAL/) (ret :cygnal)) - (iff (f^ #/Darwin/) (ret :macos)) - (ret :unknown)) - u.sysname])) + (if (ignerr (dlsym (dlopen "libandroid.so") "AAsset_close")) + :android + (let ((u (uname))) + [(orf (iff (f^ #/Linux/) (ret :linux)) + (iff (f^ #/SunOS/) (ret :solaris)) + (iff (f^ #/CYGWIN/) (ret :cygwin)) + (iff (f^ #/CYGNAL/) (ret :cygnal)) + (iff (f^ #/Darwin/) (ret :macos)) + (iff (f^ #/OpenBSD/) (ret :openbsd)) + (iff #/BSD/ (ret :bsd)) + (ret :unknown)) + u.sysname]))) (defun libc () (caseql (os-symbol) - ((:linux :solaris :macos) (dlopen nil)) - ((:cygwin) (dlopen "cygwin1.dll")))) + ((:cygwin :cygnal) (dlopen "cygwin1.dll")) + (t (dlopen nil)))) + +(defmacro with-temp-file ((name-var stream-var prefix) . body) + ^(let* ((,stream-var (mkstemp ,prefix)) + (,name-var (stream-get-prop ,stream-var :name))) + (unwind-protect + (progn ,*body) + (close-stream ,stream-var) + (remove-path ,name-var)))) diff --git a/tests/load-hook.tl b/tests/load-hook.tl new file mode 100644 index 00000000..508e50ad --- /dev/null +++ b/tests/load-hook.tl @@ -0,0 +1,4 @@ +(defparml counter 0) +(push (lambda () (inc counter)) *load-hooks*) +(push (lambda () (dec counter)) *load-hooks*) +(pop *load-hooks*) |