srfi-1.test 72 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657
  1. ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
  2. ;;;;
  3. ;;;; Copyright 2003-2006, 2008-2011, 2014, 2020 Free Software Foundation, Inc.
  4. ;;;;
  5. ;;;; This library is free software; you can redistribute it and/or
  6. ;;;; modify it under the terms of the GNU Lesser General Public
  7. ;;;; License as published by the Free Software Foundation; either
  8. ;;;; version 3 of the License, or (at your option) any later version.
  9. ;;;;
  10. ;;;; This library is distributed in the hope that it will be useful,
  11. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  13. ;;;; Lesser General Public License for more details.
  14. ;;;;
  15. ;;;; You should have received a copy of the GNU Lesser General Public
  16. ;;;; License along with this library; if not, write to the Free Software
  17. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18. (define-module (test-srfi-1)
  19. #:use-module (test-suite lib)
  20. #:use-module (ice-9 copy-tree)
  21. #:use-module (srfi srfi-1))
  22. (define (ref-delete x lst . proc)
  23. "Reference implemenation of srfi-1 `delete'."
  24. (set! proc (if (null? proc) equal? (car proc)))
  25. (do ((ret '())
  26. (lst lst (cdr lst)))
  27. ((null? lst)
  28. (reverse! ret))
  29. (if (not (proc x (car lst)))
  30. (set! ret (cons (car lst) ret)))))
  31. (define (ref-delete-duplicates lst . proc)
  32. "Reference implemenation of srfi-1 `delete-duplicates'."
  33. (set! proc (if (null? proc) equal? (car proc)))
  34. (if (null? lst)
  35. '()
  36. (do ((keep '()))
  37. ((null? lst)
  38. (reverse! keep))
  39. (let ((elem (car lst)))
  40. (set! keep (cons elem keep))
  41. (set! lst (ref-delete elem lst proc))))))
  42. ;;
  43. ;; alist-copy
  44. ;;
  45. (with-test-prefix "alist-copy"
  46. ;; return a list which is the pairs making up alist A, the spine and cells
  47. (define (alist-pairs a)
  48. (let more ((a a)
  49. (result a))
  50. (if (pair? a)
  51. (more (cdr a) (cons a result))
  52. result)))
  53. ;; return a list of the elements common to lists X and Y, compared with eq?
  54. (define (common-elements x y)
  55. (if (null? x)
  56. '()
  57. (if (memq (car x) y)
  58. (cons (car x) (common-elements (cdr x) y))
  59. (common-elements (cdr x) y))))
  60. ;; validate an alist-copy of OLD to NEW
  61. ;; lists must be equal, and must comprise new pairs
  62. (define (valid-alist-copy? old new)
  63. (and (equal? old new)
  64. (null? (common-elements old new))))
  65. (pass-if-exception "too few args" exception:wrong-num-args
  66. (alist-copy))
  67. (pass-if-exception "too many args" exception:wrong-num-args
  68. (alist-copy '() '()))
  69. (let ((old '()))
  70. (pass-if old (valid-alist-copy? old (alist-copy old))))
  71. (let ((old '((1 . 2))))
  72. (pass-if old (valid-alist-copy? old (alist-copy old))))
  73. (let ((old '((1 . 2) (3 . 4))))
  74. (pass-if old (valid-alist-copy? old (alist-copy old))))
  75. (let ((old '((1 . 2) (3 . 4) (5 . 6))))
  76. (pass-if old (valid-alist-copy? old (alist-copy old)))))
  77. ;;
  78. ;; alist-delete
  79. ;;
  80. (with-test-prefix "alist-delete"
  81. (pass-if "equality call arg order"
  82. (let ((good #f))
  83. (alist-delete 'k '((ak . 123))
  84. (lambda (k ak)
  85. (if (and (eq? k 'k) (eq? ak 'ak))
  86. (set! good #t))))
  87. good))
  88. (pass-if "delete keys greater than 5"
  89. (equal? '((4 . x) (5 . y))
  90. (alist-delete 5 '((4 . x) (5 . y) (6 . z)) <)))
  91. (pass-if "empty"
  92. (equal? '() (alist-delete 'x '())))
  93. (pass-if "(y)"
  94. (equal? '() (alist-delete 'y '((y . 1)))))
  95. (pass-if "(n)"
  96. (equal? '((n . 1)) (alist-delete 'y '((n . 1)))))
  97. (pass-if "(y y)"
  98. (equal? '() (alist-delete 'y '((y . 1) (y . 2)))))
  99. (pass-if "(n y)"
  100. (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2)))))
  101. (pass-if "(y n)"
  102. (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2)))))
  103. (pass-if "(n n)"
  104. (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2)))))
  105. (pass-if "(y y y)"
  106. (equal? '() (alist-delete 'y '((y . 1) (y . 2) (y . 3)))))
  107. (pass-if "(n y y)"
  108. (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2) (y . 3)))))
  109. (pass-if "(y n y)"
  110. (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2) (y . 3)))))
  111. (pass-if "(n n y)"
  112. (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2) (y . 3)))))
  113. (pass-if "(y y n)"
  114. (equal? '( (n . 3)) (alist-delete 'y '((y . 1) (y . 2) (n . 3)))))
  115. (pass-if "(n y n)"
  116. (equal? '((n . 1) (n . 3)) (alist-delete 'y '((n . 1) (y . 2) (n . 3)))))
  117. (pass-if "(y n n)"
  118. (equal? '((n . 2) (n . 3)) (alist-delete 'y '((y . 1) (n . 2) (n . 3)))))
  119. (pass-if "(n n n)"
  120. (equal? '((n . 1) (n . 2) (n . 3)) (alist-delete 'y '((n . 1) (n . 2) (n . 3))))))
  121. ;;
  122. ;; append-map
  123. ;;
  124. (with-test-prefix "append-map"
  125. (with-test-prefix "one list"
  126. (pass-if "()"
  127. (equal? '() (append-map noop '(()))))
  128. (pass-if "(1)"
  129. (equal? '(1) (append-map noop '((1)))))
  130. (pass-if "(1 2)"
  131. (equal? '(1 2) (append-map noop '((1 2)))))
  132. (pass-if "() ()"
  133. (equal? '() (append-map noop '(() ()))))
  134. (pass-if "() (1)"
  135. (equal? '(1) (append-map noop '(() (1)))))
  136. (pass-if "() (1 2)"
  137. (equal? '(1 2) (append-map noop '(() (1 2)))))
  138. (pass-if "(1) (2)"
  139. (equal? '(1 2) (append-map noop '((1) (2)))))
  140. (pass-if "(1 2) ()"
  141. (equal? '(1 2) (append-map noop '(() (1 2))))))
  142. (with-test-prefix "two lists"
  143. (pass-if "() / 9"
  144. (equal? '() (append-map noop '(()) '(9))))
  145. (pass-if "(1) / 9"
  146. (equal? '(1) (append-map noop '((1)) '(9))))
  147. (pass-if "() () / 9 9"
  148. (equal? '() (append-map noop '(() ()) '(9 9))))
  149. (pass-if "(1) (2) / 9"
  150. (equal? '(1) (append-map noop '((1) (2)) '(9))))
  151. (pass-if "(1) (2) / 9 9"
  152. (equal? '(1 2) (append-map noop '((1) (2)) '(9 9))))))
  153. ;;
  154. ;; append-reverse
  155. ;;
  156. (with-test-prefix "append-reverse"
  157. ;; return a list which is the cars and cdrs of LST
  158. (define (list-contents lst)
  159. (if (null? lst)
  160. '()
  161. (cons* (car lst) (cdr lst) (list-contents (cdr lst)))))
  162. (define (valid-append-reverse revhead tail want)
  163. (let ((revhead-contents (list-contents revhead))
  164. (got (append-reverse revhead tail)))
  165. (and (equal? got want)
  166. ;; revhead unchanged
  167. (equal? revhead-contents (list-contents revhead)))))
  168. (pass-if-exception "too few args (0)" exception:wrong-num-args
  169. (append-reverse))
  170. (pass-if-exception "too few args (1)" exception:wrong-num-args
  171. (append-reverse '(x)))
  172. (pass-if-exception "too many args (3)" exception:wrong-num-args
  173. (append-reverse '() '() #f))
  174. (pass-if (valid-append-reverse '() '() '()))
  175. (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3)))
  176. (pass-if (valid-append-reverse '(1) '() '(1)))
  177. (pass-if (valid-append-reverse '(1) '(2) '(1 2)))
  178. (pass-if (valid-append-reverse '(1) '(2 3) '(1 2 3)))
  179. (pass-if (valid-append-reverse '(1 2) '() '(2 1)))
  180. (pass-if (valid-append-reverse '(1 2) '(3) '(2 1 3)))
  181. (pass-if (valid-append-reverse '(1 2) '(3 4) '(2 1 3 4)))
  182. (pass-if (valid-append-reverse '(1 2 3) '() '(3 2 1)))
  183. (pass-if (valid-append-reverse '(1 2 3) '(4) '(3 2 1 4)))
  184. (pass-if (valid-append-reverse '(1 2 3) '(4 5) '(3 2 1 4 5))))
  185. ;;
  186. ;; append-reverse!
  187. ;;
  188. (with-test-prefix "append-reverse!"
  189. (pass-if-exception "too few args (0)" exception:wrong-num-args
  190. (append-reverse!))
  191. (pass-if-exception "too few args (1)" exception:wrong-num-args
  192. (append-reverse! '(x)))
  193. (pass-if-exception "too many args (3)" exception:wrong-num-args
  194. (append-reverse! '() '() #f))
  195. (pass-if (equal? '() (append-reverse! '() '())))
  196. (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3))))
  197. (pass-if (equal? '(1) (append-reverse! '(1) '())))
  198. (pass-if (equal? '(1 2) (append-reverse! '(1) '(2))))
  199. (pass-if (equal? '(1 2 3) (append-reverse! '(1) '(2 3))))
  200. (pass-if (equal? '(2 1) (append-reverse! '(1 2) '())))
  201. (pass-if (equal? '(2 1 3) (append-reverse! '(1 2) '(3))))
  202. (pass-if (equal? '(2 1 3 4) (append-reverse! '(1 2) '(3 4))))
  203. (pass-if (equal? '(3 2 1) (append-reverse! '(1 2 3) '())))
  204. (pass-if (equal? '(3 2 1 4) (append-reverse! '(1 2 3) '(4))))
  205. (pass-if (equal? '(3 2 1 4 5) (append-reverse! '(1 2 3) '(4 5)))))
  206. ;;
  207. ;; assoc
  208. ;;
  209. (with-test-prefix "assoc"
  210. (pass-if "not found"
  211. (let ((alist '((a . 1)
  212. (b . 2)
  213. (c . 3))))
  214. (eqv? #f (assoc 'z alist))))
  215. (pass-if "found"
  216. (let ((alist '((a . 1)
  217. (b . 2)
  218. (c . 3))))
  219. (eqv? (second alist) (assoc 'b alist))))
  220. ;; this was wrong in guile 1.8.0 (a gremlin newly introduced in the 1.8
  221. ;; series, 1.6.x and earlier was ok)
  222. (pass-if "= arg order"
  223. (let ((alist '((b . 1)))
  224. (good #f))
  225. (assoc 'a alist (lambda (x y)
  226. (set! good (and (eq? x 'a)
  227. (eq? y 'b)))))
  228. good))
  229. ;; likewise this one bad in guile 1.8.0
  230. (pass-if "srfi-1 example <"
  231. (let ((alist '((1 . a)
  232. (5 . b)
  233. (6 . c))))
  234. (eq? (third alist) (assoc 5 alist <)))))
  235. ;;
  236. ;; break
  237. ;;
  238. (with-test-prefix "break"
  239. (define (test-break lst want-v1 want-v2)
  240. (call-with-values
  241. (lambda ()
  242. (break negative? lst))
  243. (lambda (got-v1 got-v2)
  244. (and (equal? got-v1 want-v1)
  245. (equal? got-v2 want-v2)))))
  246. (pass-if "empty"
  247. (test-break '() '() '()))
  248. (pass-if "y"
  249. (test-break '(1) '(1) '()))
  250. (pass-if "n"
  251. (test-break '(-1) '() '(-1)))
  252. (pass-if "yy"
  253. (test-break '(1 2) '(1 2) '()))
  254. (pass-if "ny"
  255. (test-break '(-1 1) '() '(-1 1)))
  256. (pass-if "yn"
  257. (test-break '(1 -1) '(1) '(-1)))
  258. (pass-if "nn"
  259. (test-break '(-1 -2) '() '(-1 -2)))
  260. (pass-if "yyy"
  261. (test-break '(1 2 3) '(1 2 3) '()))
  262. (pass-if "nyy"
  263. (test-break '(-1 1 2) '() '(-1 1 2)))
  264. (pass-if "yny"
  265. (test-break '(1 -1 2) '(1) '(-1 2)))
  266. (pass-if "nny"
  267. (test-break '(-1 -2 1) '() '(-1 -2 1)))
  268. (pass-if "yyn"
  269. (test-break '(1 2 -1) '(1 2) '(-1)))
  270. (pass-if "nyn"
  271. (test-break '(-1 1 -2) '() '(-1 1 -2)))
  272. (pass-if "ynn"
  273. (test-break '(1 -1 -2) '(1) '(-1 -2)))
  274. (pass-if "nnn"
  275. (test-break '(-1 -2 -3) '() '(-1 -2 -3))))
  276. ;;
  277. ;; break!
  278. ;;
  279. (with-test-prefix "break!"
  280. (define (test-break! lst want-v1 want-v2)
  281. (call-with-values
  282. (lambda ()
  283. (break! negative? lst))
  284. (lambda (got-v1 got-v2)
  285. (and (equal? got-v1 want-v1)
  286. (equal? got-v2 want-v2)))))
  287. (pass-if "empty"
  288. (test-break! '() '() '()))
  289. (pass-if "y"
  290. (test-break! (list 1) '(1) '()))
  291. (pass-if "n"
  292. (test-break! (list -1) '() '(-1)))
  293. (pass-if "yy"
  294. (test-break! (list 1 2) '(1 2) '()))
  295. (pass-if "ny"
  296. (test-break! (list -1 1) '() '(-1 1)))
  297. (pass-if "yn"
  298. (test-break! (list 1 -1) '(1) '(-1)))
  299. (pass-if "nn"
  300. (test-break! (list -1 -2) '() '(-1 -2)))
  301. (pass-if "yyy"
  302. (test-break! (list 1 2 3) '(1 2 3) '()))
  303. (pass-if "nyy"
  304. (test-break! (list -1 1 2) '() '(-1 1 2)))
  305. (pass-if "yny"
  306. (test-break! (list 1 -1 2) '(1) '(-1 2)))
  307. (pass-if "nny"
  308. (test-break! (list -1 -2 1) '() '(-1 -2 1)))
  309. (pass-if "yyn"
  310. (test-break! (list 1 2 -1) '(1 2) '(-1)))
  311. (pass-if "nyn"
  312. (test-break! (list -1 1 -2) '() '(-1 1 -2)))
  313. (pass-if "ynn"
  314. (test-break! (list 1 -1 -2) '(1) '(-1 -2)))
  315. (pass-if "nnn"
  316. (test-break! (list -1 -2 -3) '() '(-1 -2 -3))))
  317. ;;
  318. ;; car+cdr
  319. ;;
  320. (with-test-prefix "car+cdr"
  321. (pass-if "(1 . 2)"
  322. (call-with-values
  323. (lambda ()
  324. (car+cdr '(1 . 2)))
  325. (lambda (x y)
  326. (and (eqv? x 1)
  327. (eqv? y 2))))))
  328. ;;
  329. ;; concatenate and concatenate!
  330. ;;
  331. (let ()
  332. (define (common-tests concatenate-proc unmodified?)
  333. (define (try lstlst want)
  334. (let ((lstlst-copy (copy-tree lstlst))
  335. (got (concatenate-proc lstlst)))
  336. (if unmodified?
  337. (if (not (equal? lstlst lstlst-copy))
  338. (error "input lists modified")))
  339. (equal? got want)))
  340. (pass-if-exception "too few args" exception:wrong-num-args
  341. (concatenate-proc))
  342. (pass-if-exception "too many args" exception:wrong-num-args
  343. (concatenate-proc '() '()))
  344. (pass-if-exception "number" exception:wrong-type-arg
  345. (concatenate-proc 123))
  346. (pass-if-exception "vector" exception:wrong-type-arg
  347. (concatenate-proc #(1 2 3)))
  348. (pass-if "no lists"
  349. (try '() '()))
  350. (pass-if (try '((1)) '(1)))
  351. (pass-if (try '((1 2)) '(1 2)))
  352. (pass-if (try '(() (1)) '(1)))
  353. (pass-if (try '(() () (1)) '(1)))
  354. (pass-if (try '((1) (2)) '(1 2)))
  355. (pass-if (try '(() (1 2)) '(1 2)))
  356. (pass-if (try '((1) 2) '(1 . 2)))
  357. (pass-if (try '((1) (2) 3) '(1 2 . 3)))
  358. (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4)))
  359. )
  360. (with-test-prefix "concatenate"
  361. (common-tests concatenate #t))
  362. (with-test-prefix "concatenate!"
  363. (common-tests concatenate! #f)))
  364. ;;
  365. ;; count
  366. ;;
  367. (with-test-prefix "count"
  368. (pass-if-exception "no args" exception:wrong-num-args
  369. (count))
  370. (pass-if-exception "one arg" exception:wrong-num-args
  371. (count noop))
  372. (with-test-prefix "one list"
  373. (define (or1 x)
  374. x)
  375. (pass-if "empty list" (= 0 (count or1 '())))
  376. (pass-if-exception "pred arg count 0" exception:wrong-num-args
  377. (count (lambda () x) '(1 2 3)))
  378. (pass-if-exception "pred arg count 2" exception:wrong-num-args
  379. (count (lambda (x y) x) '(1 2 3)))
  380. (pass-if-exception "improper 1" exception:wrong-type-arg
  381. (count or1 1))
  382. (pass-if-exception "improper 2" exception:wrong-type-arg
  383. (count or1 '(1 . 2)))
  384. (pass-if-exception "improper 3" exception:wrong-type-arg
  385. (count or1 '(1 2 . 3)))
  386. (pass-if (= 0 (count or1 '(#f))))
  387. (pass-if (= 1 (count or1 '(#t))))
  388. (pass-if (= 0 (count or1 '(#f #f))))
  389. (pass-if (= 1 (count or1 '(#f #t))))
  390. (pass-if (= 1 (count or1 '(#t #f))))
  391. (pass-if (= 2 (count or1 '(#t #t))))
  392. (pass-if (= 0 (count or1 '(#f #f #f))))
  393. (pass-if (= 1 (count or1 '(#f #f #t))))
  394. (pass-if (= 1 (count or1 '(#t #f #f))))
  395. (pass-if (= 2 (count or1 '(#t #f #t))))
  396. (pass-if (= 3 (count or1 '(#t #t #t)))))
  397. (with-test-prefix "two lists"
  398. (define (or2 x y)
  399. (or x y))
  400. (pass-if "arg order"
  401. (= 1 (count (lambda (x y)
  402. (and (= 1 x)
  403. (= 2 y)))
  404. '(1) '(2))))
  405. (pass-if "empty lists" (= 0 (count or2 '() '())))
  406. (pass-if-exception "pred arg count 0" exception:wrong-num-args
  407. (count (lambda () #t) '(1 2 3) '(1 2 3)))
  408. (pass-if-exception "pred arg count 1" exception:wrong-num-args
  409. (count (lambda (x) x) '(1 2 3) '(1 2 3)))
  410. (pass-if-exception "pred arg count 3" exception:wrong-num-args
  411. (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
  412. (pass-if-exception "improper first 1" exception:wrong-type-arg
  413. (count or2 1 '(1 2 3)))
  414. (pass-if-exception "improper first 2" exception:wrong-type-arg
  415. (count or2 '(1 . 2) '(1 2 3)))
  416. (pass-if-exception "improper first 3" exception:wrong-type-arg
  417. (count or2 '(1 2 . 3) '(1 2 3)))
  418. (pass-if-exception "improper second 1" exception:wrong-type-arg
  419. (count or2 '(1 2 3) 1))
  420. (pass-if-exception "improper second 2" exception:wrong-type-arg
  421. (count or2 '(1 2 3) '(1 . 2)))
  422. (pass-if-exception "improper second 3" exception:wrong-type-arg
  423. (count or2 '(1 2 3) '(1 2 . 3)))
  424. (pass-if (= 0 (count or2 '(#f) '(#f))))
  425. (pass-if (= 1 (count or2 '(#t) '(#f))))
  426. (pass-if (= 1 (count or2 '(#f) '(#t))))
  427. (pass-if (= 0 (count or2 '(#f #f) '(#f #f))))
  428. (pass-if (= 1 (count or2 '(#t #f) '(#t #f))))
  429. (pass-if (= 2 (count or2 '(#t #t) '(#f #f))))
  430. (pass-if (= 2 (count or2 '(#t #f) '(#f #t))))
  431. (with-test-prefix "stop shortest"
  432. (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t))))
  433. (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t))))
  434. (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t))))
  435. (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t))))))
  436. (with-test-prefix "three lists"
  437. (define (or3 x y z)
  438. (or x y z))
  439. (pass-if "arg order"
  440. (= 1 (count (lambda (x y z)
  441. (and (= 1 x)
  442. (= 2 y)
  443. (= 3 z)))
  444. '(1) '(2) '(3))))
  445. (pass-if "empty lists" (= 0 (count or3 '() '() '())))
  446. ;; currently bad pred argument gives wrong-num-args when 3 or more
  447. ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
  448. (pass-if-exception "pred arg count 0" exception:wrong-num-args
  449. (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
  450. (pass-if-exception "pred arg count 2" exception:wrong-num-args
  451. (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
  452. (pass-if-exception "pred arg count 4" exception:wrong-num-args
  453. (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
  454. (pass-if-exception "improper first 1" exception:wrong-type-arg
  455. (count or3 1 '(1 2 3) '(1 2 3)))
  456. (pass-if-exception "improper first 2" exception:wrong-type-arg
  457. (count or3 '(1 . 2) '(1 2 3) '(1 2 3)))
  458. (pass-if-exception "improper first 3" exception:wrong-type-arg
  459. (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
  460. (pass-if-exception "improper second 1" exception:wrong-type-arg
  461. (count or3 '(1 2 3) 1 '(1 2 3)))
  462. (pass-if-exception "improper second 2" exception:wrong-type-arg
  463. (count or3 '(1 2 3) '(1 . 2) '(1 2 3)))
  464. (pass-if-exception "improper second 3" exception:wrong-type-arg
  465. (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
  466. (pass-if-exception "improper third 1" exception:wrong-type-arg
  467. (count or3 '(1 2 3) '(1 2 3) 1))
  468. (pass-if-exception "improper third 2" exception:wrong-type-arg
  469. (count or3 '(1 2 3) '(1 2 3) '(1 . 2)))
  470. (pass-if-exception "improper third 3" exception:wrong-type-arg
  471. (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
  472. (pass-if (= 0 (count or3 '(#f) '(#f) '(#f))))
  473. (pass-if (= 1 (count or3 '(#t) '(#f) '(#f))))
  474. (pass-if (= 1 (count or3 '(#f) '(#t) '(#f))))
  475. (pass-if (= 1 (count or3 '(#f) '(#f) '(#t))))
  476. (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
  477. (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f))))
  478. (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f))))
  479. (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f))))
  480. (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f))))
  481. (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f))))
  482. (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t))))
  483. (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f))))
  484. (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f))))
  485. (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t))))
  486. (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t))))
  487. (with-test-prefix "stop shortest"
  488. (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t))))
  489. (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t))))
  490. (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '())))
  491. (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t))))
  492. (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t))))
  493. (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t)))))
  494. (pass-if "apply list unchanged"
  495. (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
  496. (and (equal? 2 (apply count or3 lst))
  497. ;; lst unmodified
  498. (equal? '((1 2) (3 4) (5 6)) lst))))))
  499. ;;
  500. ;; delete and delete!
  501. ;;
  502. (let ()
  503. ;; Call (PROC lst) for all lists of length up to 6, with all combinations
  504. ;; of elements to be retained or deleted. Elements to retain are numbers,
  505. ;; 0 upwards. Elements to be deleted are #f.
  506. (define (test-lists proc)
  507. (do ((n 0 (1+ n)))
  508. ((>= n 6))
  509. (do ((limit (ash 1 n))
  510. (i 0 (1+ i)))
  511. ((>= i limit))
  512. (let ((lst '()))
  513. (do ((bit 0 (1+ bit)))
  514. ((>= bit n))
  515. (set! lst (cons (if (logbit? bit i) bit #f) lst)))
  516. (proc lst)))))
  517. (define (common-tests delete-proc)
  518. (pass-if-exception "too few args" exception:wrong-num-args
  519. (delete-proc 0))
  520. (pass-if-exception "too many args" exception:wrong-num-args
  521. (delete-proc 0 '() equal? 99))
  522. (pass-if "empty"
  523. (eq? '() (delete-proc 0 '() equal?)))
  524. (pass-if "equal?"
  525. (equal? '((1) (3))
  526. (delete-proc '(2) '((1) (2) (3)) equal?)))
  527. (pass-if "eq?"
  528. (equal? '((1) (2) (3))
  529. (delete-proc '(2) '((1) (2) (3)) eq?)))
  530. (pass-if "called arg order"
  531. (equal? '(1 2 3)
  532. (delete-proc 3 '(1 2 3 4 5) <))))
  533. (with-test-prefix "delete"
  534. (common-tests delete)
  535. (test-lists
  536. (lambda (lst)
  537. (let ((lst-copy (list-copy lst)))
  538. (with-test-prefix lst-copy
  539. (pass-if "result"
  540. (equal? (delete #f lst equal?)
  541. (ref-delete #f lst equal?)))
  542. (pass-if "non-destructive"
  543. (equal? lst-copy lst)))))))
  544. (with-test-prefix "delete!"
  545. (common-tests delete!)
  546. (test-lists
  547. (lambda (lst)
  548. (pass-if lst
  549. (equal? (delete! #f lst)
  550. (ref-delete #f lst)))))))
  551. ;;
  552. ;; delete-duplicates and delete-duplicates!
  553. ;;
  554. (let ()
  555. ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
  556. ;; combinations of numbers 1 to n in the elements
  557. (define (test-lists proc)
  558. (do ((n 1 (1+ n)))
  559. ((> n 4))
  560. (do ((limit (integer-expt n n))
  561. (i 0 (1+ i)))
  562. ((>= i limit))
  563. (let ((lst '()))
  564. (do ((j 0 (1+ j))
  565. (rem i (quotient rem n)))
  566. ((>= j n))
  567. (set! lst (cons (remainder rem n) lst)))
  568. (proc lst)))))
  569. (define (common-tests delete-duplicates-proc)
  570. (pass-if-exception "too few args" exception:wrong-num-args
  571. (delete-duplicates-proc))
  572. (pass-if-exception "too many args" exception:wrong-num-args
  573. (delete-duplicates-proc '() equal? 99))
  574. (pass-if "empty"
  575. (eq? '() (delete-duplicates-proc '())))
  576. (pass-if "equal? (the default)"
  577. (equal? '((2))
  578. (delete-duplicates-proc '((2) (2) (2)))))
  579. (pass-if "eq?"
  580. (equal? '((2) (2) (2))
  581. (delete-duplicates-proc '((2) (2) (2)) eq?)))
  582. (pass-if "called arg order"
  583. (let ((ok #t))
  584. (delete-duplicates-proc '(1 2 3 4 5)
  585. (lambda (x y)
  586. (if (> x y)
  587. (set! ok #f))
  588. #f))
  589. ok)))
  590. (with-test-prefix "delete-duplicates"
  591. (common-tests delete-duplicates)
  592. (test-lists
  593. (lambda (lst)
  594. (let ((lst-copy (list-copy lst)))
  595. (with-test-prefix lst-copy
  596. (pass-if "result"
  597. (equal? (delete-duplicates lst)
  598. (ref-delete-duplicates lst)))
  599. (pass-if "non-destructive"
  600. (equal? lst-copy lst)))))))
  601. (with-test-prefix "delete-duplicates!"
  602. (common-tests delete-duplicates!)
  603. (test-lists
  604. (lambda (lst)
  605. (pass-if lst
  606. (equal? (delete-duplicates! lst)
  607. (ref-delete-duplicates lst)))))))
  608. ;;
  609. ;; drop
  610. ;;
  611. (with-test-prefix "drop"
  612. (pass-if "'() 0"
  613. (null? (drop '() 0)))
  614. (pass-if "'(a) 0"
  615. (let ((lst '(a)))
  616. (eq? lst
  617. (drop lst 0))))
  618. (pass-if "'(a b) 0"
  619. (let ((lst '(a b)))
  620. (eq? lst
  621. (drop lst 0))))
  622. (pass-if "'(a) 1"
  623. (let ((lst '(a)))
  624. (eq? (cdr lst)
  625. (drop lst 1))))
  626. (pass-if "'(a b) 1"
  627. (let ((lst '(a b)))
  628. (eq? (cdr lst)
  629. (drop lst 1))))
  630. (pass-if "'(a b) 2"
  631. (let ((lst '(a b)))
  632. (eq? (cddr lst)
  633. (drop lst 2))))
  634. (pass-if "'(a b c) 1"
  635. (let ((lst '(a b c)))
  636. (eq? (cddr lst)
  637. (drop lst 2))))
  638. (pass-if "circular '(a) 0"
  639. (let ((lst (circular-list 'a)))
  640. (eq? lst
  641. (drop lst 0))))
  642. (pass-if "circular '(a) 1"
  643. (let ((lst (circular-list 'a)))
  644. (eq? lst
  645. (drop lst 1))))
  646. (pass-if "circular '(a) 2"
  647. (let ((lst (circular-list 'a)))
  648. (eq? lst
  649. (drop lst 1))))
  650. (pass-if "circular '(a b) 1"
  651. (let ((lst (circular-list 'a)))
  652. (eq? (cdr lst)
  653. (drop lst 0))))
  654. (pass-if "circular '(a b) 2"
  655. (let ((lst (circular-list 'a)))
  656. (eq? lst
  657. (drop lst 1))))
  658. (pass-if "circular '(a b) 5"
  659. (let ((lst (circular-list 'a)))
  660. (eq? (cdr lst)
  661. (drop lst 5))))
  662. (pass-if "'(a . b) 1"
  663. (eq? 'b
  664. (drop '(a . b) 1)))
  665. (pass-if "'(a b . c) 1"
  666. (equal? 'c
  667. (drop '(a b . c) 2))))
  668. ;;
  669. ;; drop-right
  670. ;;
  671. (with-test-prefix "drop-right"
  672. (pass-if-exception "() -1" exception:out-of-range
  673. (drop-right '() -1))
  674. (pass-if (equal? '() (drop-right '() 0)))
  675. (pass-if-exception "() 1" exception:wrong-type-arg
  676. (drop-right '() 1))
  677. (pass-if-exception "(1) -1" exception:out-of-range
  678. (drop-right '(1) -1))
  679. (pass-if (equal? '(1) (drop-right '(1) 0)))
  680. (pass-if (equal? '() (drop-right '(1) 1)))
  681. (pass-if-exception "(1) 2" exception:wrong-type-arg
  682. (drop-right '(1) 2))
  683. (pass-if-exception "(4 5) -1" exception:out-of-range
  684. (drop-right '(4 5) -1))
  685. (pass-if (equal? '(4 5) (drop-right '(4 5) 0)))
  686. (pass-if (equal? '(4) (drop-right '(4 5) 1)))
  687. (pass-if (equal? '() (drop-right '(4 5) 2)))
  688. (pass-if-exception "(4 5) 3" exception:wrong-type-arg
  689. (drop-right '(4 5) 3))
  690. (pass-if-exception "(4 5 6) -1" exception:out-of-range
  691. (drop-right '(4 5 6) -1))
  692. (pass-if (equal? '(4 5 6) (drop-right '(4 5 6) 0)))
  693. (pass-if (equal? '(4 5) (drop-right '(4 5 6) 1)))
  694. (pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
  695. (pass-if (equal? '() (drop-right '(4 5 6) 3)))
  696. (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
  697. (drop-right '(4 5 6) 4))
  698. (pass-if "(a b . c) 0"
  699. (equal? (drop-right '(a b . c) 0) '(a b)))
  700. (pass-if "(a b . c) 1"
  701. (equal? (drop-right '(a b . c) 1) '(a))))
  702. ;;
  703. ;; drop-right!
  704. ;;
  705. (with-test-prefix "drop-right!"
  706. (pass-if-exception "() -1" exception:out-of-range
  707. (drop-right! '() -1))
  708. (pass-if (equal? '() (drop-right! '() 0)))
  709. (pass-if-exception "() 1" exception:wrong-type-arg
  710. (drop-right! '() 1))
  711. (pass-if-exception "(1) -1" exception:out-of-range
  712. (drop-right! (list 1) -1))
  713. (pass-if (equal? '(1) (drop-right! (list 1) 0)))
  714. (pass-if (equal? '() (drop-right! (list 1) 1)))
  715. (pass-if-exception "(1) 2" exception:wrong-type-arg
  716. (drop-right! (list 1) 2))
  717. (pass-if-exception "(4 5) -1" exception:out-of-range
  718. (drop-right! (list 4 5) -1))
  719. (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0)))
  720. (pass-if (equal? '(4) (drop-right! (list 4 5) 1)))
  721. (pass-if (equal? '() (drop-right! (list 4 5) 2)))
  722. (pass-if-exception "(4 5) 3" exception:wrong-type-arg
  723. (drop-right! (list 4 5) 3))
  724. (pass-if-exception "(4 5 6) -1" exception:out-of-range
  725. (drop-right! (list 4 5 6) -1))
  726. (pass-if (equal? '(4 5 6) (drop-right! (list 4 5 6) 0)))
  727. (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1)))
  728. (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2)))
  729. (pass-if (equal? '() (drop-right! (list 4 5 6) 3)))
  730. (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
  731. (drop-right! (list 4 5 6) 4)))
  732. ;;
  733. ;; drop-while
  734. ;;
  735. (with-test-prefix "drop-while"
  736. (pass-if (equal? '() (drop-while odd? '())))
  737. (pass-if (equal? '() (drop-while odd? '(1))))
  738. (pass-if (equal? '() (drop-while odd? '(1 3))))
  739. (pass-if (equal? '() (drop-while odd? '(1 3 5))))
  740. (pass-if (equal? '(2) (drop-while odd? '(2))))
  741. (pass-if (equal? '(2) (drop-while odd? '(1 2))))
  742. (pass-if (equal? '(4) (drop-while odd? '(1 3 4))))
  743. (pass-if (equal? '(2 1) (drop-while odd? '(2 1))))
  744. (pass-if (equal? '(4 3) (drop-while odd? '(1 4 3))))
  745. (pass-if (equal? '(4 1 3) (drop-while odd? '(4 1 3)))))
  746. ;;
  747. ;; eighth
  748. ;;
  749. (with-test-prefix "eighth"
  750. (pass-if-exception "() -1" exception:wrong-type-arg
  751. (eighth '(a b c d e f g)))
  752. (pass-if (eq? 'h (eighth '(a b c d e f g h))))
  753. (pass-if (eq? 'h (eighth '(a b c d e f g h i)))))
  754. ;;
  755. ;; fifth
  756. ;;
  757. (with-test-prefix "fifth"
  758. (pass-if-exception "() -1" exception:wrong-type-arg
  759. (fifth '(a b c d)))
  760. (pass-if (eq? 'e (fifth '(a b c d e))))
  761. (pass-if (eq? 'e (fifth '(a b c d e f)))))
  762. ;;
  763. ;; filter-map
  764. ;;
  765. (with-test-prefix "filter-map"
  766. (with-test-prefix "one list"
  767. (pass-if-exception "'x" exception:wrong-type-arg
  768. (filter-map noop 'x))
  769. (pass-if-exception "'(1 . x)" exception:wrong-type-arg
  770. (filter-map noop '(1 . x)))
  771. (pass-if "(1)"
  772. (equal? '(1) (filter-map noop '(1))))
  773. (pass-if "(#f)"
  774. (equal? '() (filter-map noop '(#f))))
  775. (pass-if "(1 2)"
  776. (equal? '(1 2) (filter-map noop '(1 2))))
  777. (pass-if "(#f 2)"
  778. (equal? '(2) (filter-map noop '(#f 2))))
  779. (pass-if "(#f #f)"
  780. (equal? '() (filter-map noop '(#f #f))))
  781. (pass-if "(1 2 3)"
  782. (equal? '(1 2 3) (filter-map noop '(1 2 3))))
  783. (pass-if "(#f 2 3)"
  784. (equal? '(2 3) (filter-map noop '(#f 2 3))))
  785. (pass-if "(1 #f 3)"
  786. (equal? '(1 3) (filter-map noop '(1 #f 3))))
  787. (pass-if "(1 2 #f)"
  788. (equal? '(1 2) (filter-map noop '(1 2 #f)))))
  789. (with-test-prefix "two lists"
  790. (pass-if-exception "'x '(1 2 3)" exception:wrong-type-arg
  791. (filter-map noop 'x '(1 2 3)))
  792. (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg
  793. (filter-map noop '(1 2 3) 'x))
  794. (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg
  795. (filter-map noop '(1 . x) '(1 2 3)))
  796. (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg
  797. (filter-map noop '(1 2 3) '(1 . x)))
  798. (pass-if "(1 2 3) (4 5 6)"
  799. (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6))))
  800. (pass-if "(#f 2 3) (4 5)"
  801. (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
  802. (pass-if "(4 #f) (1 2 3)"
  803. (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))
  804. (pass-if "() (1 2 3)"
  805. (equal? '() (filter-map noop '() '(1 2 3))))
  806. (pass-if "(1 2 3) ()"
  807. (equal? '() (filter-map noop '(1 2 3) '()))))
  808. (with-test-prefix "three lists"
  809. (pass-if-exception "'x '(1 2 3) '(1 2 3)" exception:wrong-type-arg
  810. (filter-map noop 'x '(1 2 3) '(1 2 3)))
  811. (pass-if-exception "'(1 2 3) 'x '(1 2 3)" exception:wrong-type-arg
  812. (filter-map noop '(1 2 3) 'x '(1 2 3)))
  813. (pass-if-exception "'(1 2 3) '(1 2 3) 'x" exception:wrong-type-arg
  814. (filter-map noop '(1 2 3) '(1 2 3) 'x))
  815. (pass-if-exception "'(1 . x) '(1 2 3) '(1 2 3)" exception:wrong-type-arg
  816. (filter-map noop '(1 . x) '(1 2 3) '(1 2 3)))
  817. (pass-if-exception "'(1 2 3) '(1 . x) '(1 2 3)" exception:wrong-type-arg
  818. (filter-map noop '(1 2 3) '(1 . x) '(1 2 3)))
  819. (pass-if-exception "'(1 2 3) '(1 2 3) '(1 . x)" exception:wrong-type-arg
  820. (filter-map noop '(1 2 3) '(1 2 3) '(1 . x)))
  821. (pass-if "(1 2 3) (4 5 6) (7 8 9)"
  822. (equal? '(12 15 18) (filter-map + '(1 2 3) '(4 5 6) '(7 8 9))))
  823. (pass-if "(#f 2 3) (4 5) (7 8 9)"
  824. (equal? '(2) (filter-map noop '(#f 2 3) '(4 5) '(7 8 9))))
  825. (pass-if "(#f 2 3) (7 8 9) (4 5)"
  826. (equal? '(2) (filter-map noop '(#f 2 3) '(7 8 9) '(4 5))))
  827. (pass-if "(4 #f) (1 2 3) (7 8 9)"
  828. (equal? '(4) (filter-map noop '(4 #f) '(1 2 3) '(7 8 9))))
  829. (pass-if "apply list unchanged"
  830. (let ((lst (list (list 1 #f 2) (list 3 4 5) (list 6 7 8))))
  831. (and (equal? '(1 2) (apply filter-map noop lst))
  832. ;; lst unmodified
  833. (equal? lst '((1 #f 2) (3 4 5) (6 7 8))))))))
  834. ;;
  835. ;; find
  836. ;;
  837. (with-test-prefix "find"
  838. (pass-if (eqv? #f (find odd? '())))
  839. (pass-if (eqv? #f (find odd? '(0))))
  840. (pass-if (eqv? #f (find odd? '(0 2))))
  841. (pass-if (eqv? 1 (find odd? '(1))))
  842. (pass-if (eqv? 1 (find odd? '(0 1))))
  843. (pass-if (eqv? 1 (find odd? '(0 1 2))))
  844. (pass-if (eqv? 1 (find odd? '(2 0 1))))
  845. (pass-if (eqv? 1 (find (lambda (x) (= 1 x)) '(2 0 1)))))
  846. ;;
  847. ;; find-tail
  848. ;;
  849. (with-test-prefix "find-tail"
  850. (pass-if (let ((lst '()))
  851. (eq? #f (find-tail odd? lst))))
  852. (pass-if (let ((lst '(0)))
  853. (eq? #f (find-tail odd? lst))))
  854. (pass-if (let ((lst '(0 2)))
  855. (eq? #f (find-tail odd? lst))))
  856. (pass-if (let ((lst '(1)))
  857. (eq? lst (find-tail odd? lst))))
  858. (pass-if (let ((lst '(1 2)))
  859. (eq? lst (find-tail odd? lst))))
  860. (pass-if (let ((lst '(2 1)))
  861. (eq? (cdr lst) (find-tail odd? lst))))
  862. (pass-if (let ((lst '(2 1 0)))
  863. (eq? (cdr lst) (find-tail odd? lst))))
  864. (pass-if (let ((lst '(2 0 1)))
  865. (eq? (cddr lst) (find-tail odd? lst))))
  866. (pass-if (let ((lst '(2 0 1)))
  867. (eq? (cddr lst) (find-tail (lambda (x) (= 1 x)) lst)))))
  868. ;;
  869. ;; fold
  870. ;;
  871. (with-test-prefix "fold"
  872. (pass-if-exception "no args" exception:wrong-num-args
  873. (fold))
  874. (pass-if-exception "one arg" exception:wrong-num-args
  875. (fold 123))
  876. (pass-if-exception "two args" exception:wrong-num-args
  877. (fold 123 noop))
  878. (with-test-prefix "one list"
  879. (pass-if "arg order"
  880. (eq? #t (fold (lambda (x prev)
  881. (and (= 1 x)
  882. (= 2 prev)))
  883. 2 '(1))))
  884. (pass-if "empty list" (= 123 (fold + 123 '())))
  885. (pass-if-exception "proc arg count 0" exception:wrong-num-args
  886. (fold (lambda () x) 123 '(1 2 3)))
  887. (pass-if-exception "proc arg count 1" exception:wrong-num-args
  888. (fold (lambda (x) x) 123 '(1 2 3)))
  889. (pass-if-exception "proc arg count 3" exception:wrong-num-args
  890. (fold (lambda (x y z) x) 123 '(1 2 3)))
  891. (pass-if-exception "improper 1" exception:wrong-type-arg
  892. (fold + 123 1))
  893. (pass-if-exception "improper 2" exception:wrong-type-arg
  894. (fold + 123 '(1 . 2)))
  895. (pass-if-exception "improper 3" exception:wrong-type-arg
  896. (fold + 123 '(1 2 . 3)))
  897. (pass-if (= 3 (fold + 1 '(2))))
  898. (pass-if (= 6 (fold + 1 '(2 3))))
  899. (pass-if (= 10 (fold + 1 '(2 3 4)))))
  900. (with-test-prefix "two lists"
  901. (pass-if "arg order"
  902. (eq? #t (fold (lambda (x y prev)
  903. (and (= 1 x)
  904. (= 2 y)
  905. (= 3 prev)))
  906. 3 '(1) '(2))))
  907. (pass-if "empty lists" (= 1 (fold + 1 '() '())))
  908. ;; currently bad proc argument gives wrong-num-args when 2 or more
  909. ;; lists, as opposed to wrong-type-arg for 1 list
  910. (pass-if-exception "proc arg count 2" exception:wrong-num-args
  911. (fold (lambda (x prev) x) 1 '(1 2 3) '(1 2 3)))
  912. (pass-if-exception "proc arg count 4" exception:wrong-num-args
  913. (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3)))
  914. (pass-if-exception "improper first 1" exception:wrong-type-arg
  915. (fold + 1 1 '(1 2 3)))
  916. (pass-if-exception "improper first 2" exception:wrong-type-arg
  917. (fold + 1 '(1 . 2) '(1 2 3)))
  918. (pass-if-exception "improper first 3" exception:wrong-type-arg
  919. (fold + 1 '(1 2 . 3) '(1 2 3)))
  920. (pass-if-exception "improper second 1" exception:wrong-type-arg
  921. (fold + 1 '(1 2 3) 1))
  922. (pass-if-exception "improper second 2" exception:wrong-type-arg
  923. (fold + 1 '(1 2 3) '(1 . 2)))
  924. (pass-if-exception "improper second 3" exception:wrong-type-arg
  925. (fold + 1 '(1 2 3) '(1 2 . 3)))
  926. (pass-if (= 6 (fold + 1 '(2) '(3))))
  927. (pass-if (= 15 (fold + 1 '(2 3) '(4 5))))
  928. (pass-if (= 28 (fold + 1 '(2 3 4) '(5 6 7))))
  929. (with-test-prefix "stop shortest"
  930. (pass-if (= 13 (fold + 1 '(1 2 3) '(4 5))))
  931. (pass-if (= 13 (fold + 1 '(4 5) '(1 2 3))))
  932. (pass-if (= 11 (fold + 1 '(3 4) '(1 2 9 9))))
  933. (pass-if (= 11 (fold + 1 '(1 2 9 9) '(3 4)))))
  934. (pass-if "apply list unchanged"
  935. (let ((lst (list (list 1 2) (list 3 4))))
  936. (and (equal? 11 (apply fold + 1 lst))
  937. ;; lst unmodified
  938. (equal? '((1 2) (3 4)) lst)))))
  939. (with-test-prefix "three lists"
  940. (pass-if "arg order"
  941. (eq? #t (fold (lambda (x y z prev)
  942. (and (= 1 x)
  943. (= 2 y)
  944. (= 3 z)
  945. (= 4 prev)))
  946. 4 '(1) '(2) '(3))))
  947. (pass-if "empty lists" (= 1 (fold + 1 '() '() '())))
  948. (pass-if-exception "proc arg count 3" exception:wrong-num-args
  949. (fold (lambda (x y prev) x) 1 '(1 2 3) '(1 2 3)'(1 2 3) ))
  950. (pass-if-exception "proc arg count 5" exception:wrong-num-args
  951. (fold (lambda (w x y z prev) x) 1 '(1 2 3) '(1 2 3) '(1 2 3)))
  952. (pass-if-exception "improper first 1" exception:wrong-type-arg
  953. (fold + 1 1 '(1 2 3) '(1 2 3)))
  954. (pass-if-exception "improper first 2" exception:wrong-type-arg
  955. (fold + 1 '(1 . 2) '(1 2 3) '(1 2 3)))
  956. (pass-if-exception "improper first 3" exception:wrong-type-arg
  957. (fold + 1 '(1 2 . 3) '(1 2 3) '(1 2 3)))
  958. (pass-if-exception "improper second 1" exception:wrong-type-arg
  959. (fold + 1 '(1 2 3) 1 '(1 2 3)))
  960. (pass-if-exception "improper second 2" exception:wrong-type-arg
  961. (fold + 1 '(1 2 3) '(1 . 2) '(1 2 3)))
  962. (pass-if-exception "improper second 3" exception:wrong-type-arg
  963. (fold + 1 '(1 2 3) '(1 2 . 3) '(1 2 3)))
  964. (pass-if-exception "improper third 1" exception:wrong-type-arg
  965. (fold + 1 '(1 2 3) '(1 2 3) 1))
  966. (pass-if-exception "improper third 2" exception:wrong-type-arg
  967. (fold + 1 '(1 2 3) '(1 2 3) '(1 . 2)))
  968. (pass-if-exception "improper third 3" exception:wrong-type-arg
  969. (fold + 1 '(1 2 3) '(1 2 3) '(1 2 . 3)))
  970. (pass-if (= 10 (fold + 1 '(2) '(3) '(4))))
  971. (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7))))
  972. (pass-if (= 55 (fold + 1 '(2 5 8) '(3 6 9) '(4 7 10))))
  973. (with-test-prefix "stop shortest"
  974. (pass-if (= 28 (fold + 1 '(2 5 9) '(3 6) '(4 7))))
  975. (pass-if (= 28 (fold + 1 '(2 5) '(3 6 9) '(4 7))))
  976. (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7 9)))))
  977. (pass-if "apply list unchanged"
  978. (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
  979. (and (equal? 22 (apply fold + 1 lst))
  980. ;; lst unmodified
  981. (equal? '((1 2) (3 4) (5 6)) lst))))))
  982. ;;
  983. ;; fold-right
  984. ;;
  985. (with-test-prefix "fold-right"
  986. (pass-if "one list"
  987. (equal? (iota 10)
  988. (fold-right cons '() (iota 10))))
  989. (pass-if "two lists"
  990. (equal? (zip (iota 10) (map integer->char (iota 10)))
  991. (fold-right (lambda (x y z)
  992. (cons (list x y) z))
  993. '()
  994. (iota 10)
  995. (map integer->char (iota 10)))))
  996. (pass-if "tail-recursive"
  997. (= 1e6 (fold-right (lambda (x y) (+ 1 y))
  998. 0
  999. (iota 1e6)))))
  1000. ;;
  1001. ;; unfold
  1002. ;;
  1003. (with-test-prefix "unfold"
  1004. (pass-if "basic"
  1005. (equal? (iota 10)
  1006. (unfold (lambda (x) (>= x 10))
  1007. identity
  1008. 1+
  1009. 0)))
  1010. (pass-if "tail-gen"
  1011. (equal? (append (iota 10) '(tail 10))
  1012. (unfold (lambda (x) (>= x 10))
  1013. identity
  1014. 1+
  1015. 0
  1016. (lambda (seed) (list 'tail seed)))))
  1017. (pass-if "tail-recursive"
  1018. ;; Bug #30071.
  1019. (pair? (unfold (lambda (x) (>= x 1e6))
  1020. identity
  1021. 1+
  1022. 0))))
  1023. ;;
  1024. ;; length+
  1025. ;;
  1026. (with-test-prefix "length+"
  1027. (pass-if-exception "too few args" exception:wrong-num-args
  1028. (length+))
  1029. (pass-if-exception "too many args" exception:wrong-num-args
  1030. (length+ 123 456))
  1031. (pass-if-exception "not a pair" exception:wrong-type-arg
  1032. (length+ 'x))
  1033. (pass-if-exception "improper list" exception:wrong-type-arg
  1034. (length+ '(x y . z)))
  1035. (pass-if (= 0 (length+ '())))
  1036. (pass-if (= 1 (length+ '(x))))
  1037. (pass-if (= 2 (length+ '(x y))))
  1038. (pass-if (= 3 (length+ '(x y z))))
  1039. (pass-if (not (length+ (circular-list 1))))
  1040. (pass-if (not (length+ (circular-list 1 2))))
  1041. (pass-if (not (length+ (circular-list 1 2 3)))))
  1042. ;;
  1043. ;; last
  1044. ;;
  1045. (with-test-prefix "last"
  1046. (pass-if-exception "empty" exception:wrong-type-arg
  1047. (last '()))
  1048. (pass-if "one elem"
  1049. (eqv? 1 (last '(1))))
  1050. (pass-if "two elems"
  1051. (eqv? 2 (last '(1 2))))
  1052. (pass-if "three elems"
  1053. (eqv? 3 (last '(1 2 3))))
  1054. (pass-if "four elems"
  1055. (eqv? 4 (last '(1 2 3 4)))))
  1056. ;;
  1057. ;; list=
  1058. ;;
  1059. (with-test-prefix "list="
  1060. (pass-if "no lists"
  1061. (eq? #t (list= eqv?)))
  1062. (with-test-prefix "one list"
  1063. (pass-if "empty"
  1064. (eq? #t (list= eqv? '())))
  1065. (pass-if "one elem"
  1066. (eq? #t (list= eqv? '(1))))
  1067. (pass-if "two elems"
  1068. (eq? #t (list= eqv? '(2)))))
  1069. (with-test-prefix "two lists"
  1070. (pass-if "empty / empty"
  1071. (eq? #t (list= eqv? '() '())))
  1072. (pass-if "one / empty"
  1073. (eq? #f (list= eqv? '(1) '())))
  1074. (pass-if "empty / one"
  1075. (eq? #f (list= eqv? '() '(1))))
  1076. (pass-if "one / one same"
  1077. (eq? #t (list= eqv? '(1) '(1))))
  1078. (pass-if "one / one diff"
  1079. (eq? #f (list= eqv? '(1) '(2))))
  1080. (pass-if "called arg order"
  1081. (let ((good #t))
  1082. (list= (lambda (x y)
  1083. (set! good (and good (= (1+ x) y)))
  1084. #t)
  1085. '(1 3) '(2 4))
  1086. good)))
  1087. (with-test-prefix "three lists"
  1088. (pass-if "empty / empty / empty"
  1089. (eq? #t (list= eqv? '() '() '())))
  1090. (pass-if "one / empty / empty"
  1091. (eq? #f (list= eqv? '(1) '() '())))
  1092. (pass-if "one / one / empty"
  1093. (eq? #f (list= eqv? '(1) '(1) '())))
  1094. (pass-if "one / diff / empty"
  1095. (eq? #f (list= eqv? '(1) '(2) '())))
  1096. (pass-if "one / one / one"
  1097. (eq? #t (list= eqv? '(1) '(1) '(1))))
  1098. (pass-if "two / two / diff"
  1099. (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99))))
  1100. (pass-if "two / two / two"
  1101. (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2))))
  1102. (pass-if "called arg order"
  1103. (let ((good #t))
  1104. (list= (lambda (x y)
  1105. (set! good (and good (= (1+ x) y)))
  1106. #t)
  1107. '(1 4) '(2 5) '(3 6))
  1108. good))))
  1109. ;;
  1110. ;; list-copy
  1111. ;;
  1112. (with-test-prefix "list-copy"
  1113. (pass-if (equal? '() (list-copy '())))
  1114. (pass-if (equal? '(1 2) (list-copy '(1 2))))
  1115. (pass-if (equal? '(1 2 3) (list-copy '(1 2 3))))
  1116. (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4))))
  1117. (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
  1118. ;; improper lists can be copied
  1119. (pass-if (equal? 1 (list-copy 1)))
  1120. (pass-if (equal? '(1 . 2) (list-copy '(1 . 2))))
  1121. (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3))))
  1122. (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4))))
  1123. (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
  1124. ;;
  1125. ;; list-index
  1126. ;;
  1127. (with-test-prefix "list-index"
  1128. (pass-if-exception "no args" exception:wrong-num-args
  1129. (list-index))
  1130. (pass-if-exception "one arg" exception:wrong-num-args
  1131. (list-index noop))
  1132. (with-test-prefix "one list"
  1133. (pass-if "empty list" (eq? #f (list-index symbol? '())))
  1134. (pass-if-exception "pred arg count 0" exception:wrong-num-args
  1135. (list-index (lambda () x) '(1 2 3)))
  1136. (pass-if-exception "pred arg count 2" exception:wrong-num-args
  1137. (list-index (lambda (x y) x) '(1 2 3)))
  1138. (pass-if-exception "improper 1" exception:wrong-type-arg
  1139. (list-index symbol? 1))
  1140. (pass-if-exception "improper 2" exception:wrong-type-arg
  1141. (list-index symbol? '(1 . 2)))
  1142. (pass-if-exception "improper 3" exception:wrong-type-arg
  1143. (list-index symbol? '(1 2 . 3)))
  1144. (pass-if (eqv? #f (list-index symbol? '(1))))
  1145. (pass-if (eqv? 0 (list-index symbol? '(x))))
  1146. (pass-if (eqv? #f (list-index symbol? '(1 2))))
  1147. (pass-if (eqv? 0 (list-index symbol? '(x 1))))
  1148. (pass-if (eqv? 1 (list-index symbol? '(1 x))))
  1149. (pass-if (eqv? #f (list-index symbol? '(1 2 3))))
  1150. (pass-if (eqv? 0 (list-index symbol? '(x 1 2))))
  1151. (pass-if (eqv? 1 (list-index symbol? '(1 x 2))))
  1152. (pass-if (eqv? 2 (list-index symbol? '(1 2 x)))))
  1153. (with-test-prefix "two lists"
  1154. (define (sym1 x y)
  1155. (symbol? x))
  1156. (define (sym2 x y)
  1157. (symbol? y))
  1158. (pass-if "arg order"
  1159. (eqv? 0 (list-index (lambda (x y)
  1160. (and (= 1 x)
  1161. (= 2 y)))
  1162. '(1) '(2))))
  1163. (pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
  1164. (pass-if-exception "pred arg count 0" exception:wrong-num-args
  1165. (list-index (lambda () #t) '(1 2 3) '(1 2 3)))
  1166. (pass-if-exception "pred arg count 1" exception:wrong-num-args
  1167. (list-index (lambda (x) x) '(1 2 3) '(1 2 3)))
  1168. (pass-if-exception "pred arg count 3" exception:wrong-num-args
  1169. (list-index (lambda (x y z) x) '(1 2 3) '(1 2 3)))
  1170. (pass-if-exception "improper first 1" exception:wrong-type-arg
  1171. (list-index sym2 1 '(1 2 3)))
  1172. (pass-if-exception "improper first 2" exception:wrong-type-arg
  1173. (list-index sym2 '(1 . 2) '(1 2 3)))
  1174. (pass-if-exception "improper first 3" exception:wrong-type-arg
  1175. (list-index sym2 '(1 2 . 3) '(1 2 3)))
  1176. (pass-if-exception "improper second 1" exception:wrong-type-arg
  1177. (list-index sym2 '(1 2 3) 1))
  1178. (pass-if-exception "improper second 2" exception:wrong-type-arg
  1179. (list-index sym2 '(1 2 3) '(1 . 2)))
  1180. (pass-if-exception "improper second 3" exception:wrong-type-arg
  1181. (list-index sym2 '(1 2 3) '(1 2 . 3)))
  1182. (pass-if (eqv? #f (list-index sym2 '(1) '(2))))
  1183. (pass-if (eqv? 0 (list-index sym2 '(1) '(x))))
  1184. (pass-if (eqv? #f (list-index sym2 '(1 2) '(3 4))))
  1185. (pass-if (eqv? 0 (list-index sym2 '(1 2) '(x 3))))
  1186. (pass-if (eqv? 1 (list-index sym2 '(1 2) '(3 x))))
  1187. (pass-if (eqv? #f (list-index sym2 '(1 2 3) '(3 4 5))))
  1188. (pass-if (eqv? 0 (list-index sym2 '(1 2 3) '(x 3 4))))
  1189. (pass-if (eqv? 1 (list-index sym2 '(1 2 3) '(3 x 4))))
  1190. (pass-if (eqv? 2 (list-index sym2 '(1 2 3) '(3 4 x))))
  1191. (with-test-prefix "stop shortest"
  1192. (pass-if (eqv? #f (list-index sym1 '(1 2 x) '(4 5))))
  1193. (pass-if (eqv? #f (list-index sym2 '(4 5) '(1 2 x))))
  1194. (pass-if (eqv? #f (list-index sym1 '(3 4) '(1 2 x y))))
  1195. (pass-if (eqv? #f (list-index sym2 '(1 2 x y) '(3 4))))))
  1196. (with-test-prefix "three lists"
  1197. (define (sym1 x y z)
  1198. (symbol? x))
  1199. (define (sym2 x y z)
  1200. (symbol? y))
  1201. (define (sym3 x y z)
  1202. (symbol? z))
  1203. (pass-if "arg order"
  1204. (eqv? 0 (list-index (lambda (x y z)
  1205. (and (= 1 x)
  1206. (= 2 y)
  1207. (= 3 z)))
  1208. '(1) '(2) '(3))))
  1209. (pass-if "empty lists" (eqv? #f (list-index sym3 '() '() '())))
  1210. ;; currently bad pred argument gives wrong-num-args when 3 or more
  1211. ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
  1212. (pass-if-exception "pred arg count 0" exception:wrong-num-args
  1213. (list-index (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
  1214. (pass-if-exception "pred arg count 2" exception:wrong-num-args
  1215. (list-index (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
  1216. (pass-if-exception "pred arg count 4" exception:wrong-num-args
  1217. (list-index (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
  1218. (pass-if-exception "improper first 1" exception:wrong-type-arg
  1219. (list-index sym3 1 '(1 2 3) '(1 2 3)))
  1220. (pass-if-exception "improper first 2" exception:wrong-type-arg
  1221. (list-index sym3 '(1 . 2) '(1 2 3) '(1 2 3)))
  1222. (pass-if-exception "improper first 3" exception:wrong-type-arg
  1223. (list-index sym3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
  1224. (pass-if-exception "improper second 1" exception:wrong-type-arg
  1225. (list-index sym3 '(1 2 3) 1 '(1 2 3)))
  1226. (pass-if-exception "improper second 2" exception:wrong-type-arg
  1227. (list-index sym3 '(1 2 3) '(1 . 2) '(1 2 3)))
  1228. (pass-if-exception "improper second 3" exception:wrong-type-arg
  1229. (list-index sym3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
  1230. (pass-if-exception "improper third 1" exception:wrong-type-arg
  1231. (list-index sym3 '(1 2 3) '(1 2 3) 1))
  1232. (pass-if-exception "improper third 2" exception:wrong-type-arg
  1233. (list-index sym3 '(1 2 3) '(1 2 3) '(1 . 2)))
  1234. (pass-if-exception "improper third 3" exception:wrong-type-arg
  1235. (list-index sym3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
  1236. (pass-if (eqv? #f (list-index sym3 '(#f) '(#f) '(#f))))
  1237. (pass-if (eqv? 0 (list-index sym3 '(#f) '(#f) '(x))))
  1238. (pass-if (eqv? #f (list-index sym3 '(#f #f) '(#f #f) '(#f #f))))
  1239. (pass-if (eqv? 0 (list-index sym3 '(#f #f) '(#f #f) '(x #f))))
  1240. (pass-if (eqv? 1 (list-index sym3 '(#f #f) '(#f #f) '(#f x))))
  1241. (pass-if (eqv? #f (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f #f))))
  1242. (pass-if (eqv? 0 (list-index sym3 '(#f #f #f) '(#f #f #f) '(x #f #f))))
  1243. (pass-if (eqv? 1 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f x #f))))
  1244. (pass-if (eqv? 2 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f x))))
  1245. (with-test-prefix "stop shortest"
  1246. (pass-if (eqv? #f (list-index sym2 '() '(x x x) '(x x))))
  1247. (pass-if (eqv? #f (list-index sym1 '(x x x) '() '(x x))))
  1248. (pass-if (eqv? #f (list-index sym2 '(x x x) '(x x) '())))
  1249. (pass-if (eqv? #f (list-index sym2 '(#t) '(#t x x) '(#t x))))
  1250. (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t) '(#t x))))
  1251. (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t x) '(#t)))))
  1252. (pass-if "apply list unchanged"
  1253. (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
  1254. (and (equal? #f (apply list-index sym3 lst))
  1255. ;; lst unmodified
  1256. (equal? '((1 2) (3 4) (5 6)) lst))))))
  1257. ;;
  1258. ;; list-tabulate
  1259. ;;
  1260. (with-test-prefix "list-tabulate"
  1261. (pass-if-exception "-1" exception:wrong-type-arg
  1262. (list-tabulate -1 identity))
  1263. (pass-if "0"
  1264. (equal? '() (list-tabulate 0 identity)))
  1265. (pass-if "1"
  1266. (equal? '(0) (list-tabulate 1 identity)))
  1267. (pass-if "2"
  1268. (equal? '(0 1) (list-tabulate 2 identity)))
  1269. (pass-if "3"
  1270. (equal? '(0 1 2) (list-tabulate 3 identity)))
  1271. (pass-if "4"
  1272. (equal? '(0 1 2 3) (list-tabulate 4 identity)))
  1273. (pass-if "string ref proc"
  1274. (equal? '(#\a #\b #\c #\d) (list-tabulate 4
  1275. (lambda (i)
  1276. (string-ref "abcd" i))))))
  1277. ;;
  1278. ;; lset=
  1279. ;;
  1280. (with-test-prefix "lset="
  1281. ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
  1282. ;; list arg
  1283. (pass-if "no args"
  1284. (eq? #t (lset= eq?)))
  1285. (with-test-prefix "one arg"
  1286. (pass-if "()"
  1287. (eq? #t (lset= eqv? '())))
  1288. (pass-if "(1)"
  1289. (eq? #t (lset= eqv? '(1))))
  1290. (pass-if "(1 2)"
  1291. (eq? #t (lset= eqv? '(1 2)))))
  1292. (with-test-prefix "two args"
  1293. (pass-if "() ()"
  1294. (eq? #t (lset= eqv? '() '())))
  1295. (pass-if "(1) (1)"
  1296. (eq? #t (lset= eqv? '(1) '(1))))
  1297. (pass-if "(1) (2)"
  1298. (eq? #f (lset= eqv? '(1) '(2))))
  1299. (pass-if "(1) (1 2)"
  1300. (eq? #f (lset= eqv? '(1) '(1 2))))
  1301. (pass-if "(1 2) (2 1)"
  1302. (eq? #t (lset= eqv? '(1 2) '(2 1))))
  1303. (pass-if "called arg order"
  1304. (let ((good #t))
  1305. (lset= (lambda (x y)
  1306. (if (not (= x (1- y)))
  1307. (set! good #f))
  1308. #t)
  1309. '(1 1) '(2 2))
  1310. good)))
  1311. (with-test-prefix "three args"
  1312. (pass-if "() () ()"
  1313. (eq? #t (lset= eqv? '() '() '())))
  1314. (pass-if "(1) (1) (1)"
  1315. (eq? #t (lset= eqv? '(1) '(1) '(1))))
  1316. (pass-if "(1) (1) (2)"
  1317. (eq? #f (lset= eqv? '(1) '(1) '(2))))
  1318. (pass-if "(1) (1) (1 2)"
  1319. (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
  1320. (pass-if "(1 2 3) (3 2 1) (1 3 2)"
  1321. (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2))))
  1322. (pass-if "called arg order"
  1323. (let ((good #t))
  1324. (lset= (lambda (x y)
  1325. (if (not (= x (1- y)))
  1326. (set! good #f))
  1327. #t)
  1328. '(1 1) '(2 2) '(3 3))
  1329. good))))
  1330. ;;
  1331. ;; lset-adjoin
  1332. ;;
  1333. (with-test-prefix "lset-adjoin"
  1334. ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
  1335. ;; `=' procedure, all comparisons were just with `equal?
  1336. ;;
  1337. (with-test-prefix "case-insensitive ="
  1338. (pass-if "(\"x\") \"X\""
  1339. (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
  1340. (pass-if "called arg order"
  1341. (let ((good #f))
  1342. (lset-adjoin (lambda (x y)
  1343. (set! good (and (= x 1) (= y 2)))
  1344. (= x y))
  1345. '(1) 2)
  1346. good))
  1347. (pass-if (equal? '() (lset-adjoin = '())))
  1348. (pass-if (equal? '(1) (lset-adjoin = '() 1)))
  1349. (pass-if (equal? '(1) (lset-adjoin = '() 1 1)))
  1350. (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2)))
  1351. (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1)))
  1352. (pass-if "apply list unchanged"
  1353. (let ((lst (list 1 2)))
  1354. (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst))
  1355. ;; lst unmodified
  1356. (equal? '(1 2) lst))))
  1357. (pass-if "(1 1) 1 1"
  1358. (equal? '(1 1) (lset-adjoin = '(1 1) 1 1)))
  1359. ;; duplicates among args are cast out
  1360. (pass-if "(2) 1 1"
  1361. (equal? '(1 2) (lset-adjoin = '(2) 1 1))))
  1362. ;;
  1363. ;; lset-difference
  1364. ;;
  1365. (with-test-prefix "lset-difference"
  1366. (pass-if "called arg order"
  1367. (let ((good #f))
  1368. (lset-difference (lambda (x y)
  1369. (set! good (and (= x 1) (= y 2)))
  1370. (= x y))
  1371. '(1) '(2))
  1372. good)))
  1373. ;;
  1374. ;; lset-difference!
  1375. ;;
  1376. (with-test-prefix "lset-difference!"
  1377. (pass-if-exception "proc - num" exception:wrong-type-arg
  1378. (lset-difference! 123 '(4)))
  1379. (pass-if-exception "proc - list" exception:wrong-type-arg
  1380. (lset-difference! (list 1 2 3) '(4)))
  1381. (pass-if "called arg order"
  1382. (let ((good #f))
  1383. (lset-difference! (lambda (x y)
  1384. (set! good (and (= x 1) (= y 2)))
  1385. (= x y))
  1386. (list 1) (list 2))
  1387. good))
  1388. (pass-if (equal? '() (lset-difference! = '())))
  1389. (pass-if (equal? '(1) (lset-difference! = (list 1))))
  1390. (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
  1391. (pass-if (equal? '() (lset-difference! = (list ) '(3))))
  1392. (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
  1393. (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
  1394. (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
  1395. (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
  1396. (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
  1397. (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
  1398. (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
  1399. (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
  1400. (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
  1401. (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
  1402. (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
  1403. (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
  1404. (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
  1405. (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
  1406. (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
  1407. (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
  1408. (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
  1409. (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
  1410. (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
  1411. (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
  1412. (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
  1413. (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
  1414. (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
  1415. (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
  1416. (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
  1417. ;;
  1418. ;; lset-diff+intersection
  1419. ;;
  1420. (with-test-prefix "lset-diff+intersection"
  1421. (pass-if "called arg order"
  1422. (let ((good #f))
  1423. (lset-diff+intersection (lambda (x y)
  1424. (set! good (and (= x 1) (= y 2)))
  1425. (= x y))
  1426. '(1) '(2))
  1427. good)))
  1428. ;;
  1429. ;; lset-diff+intersection!
  1430. ;;
  1431. (with-test-prefix "lset-diff+intersection"
  1432. (pass-if "called arg order"
  1433. (let ((good #f))
  1434. (lset-diff+intersection (lambda (x y)
  1435. (set! good (and (= x 1) (= y 2)))
  1436. (= x y))
  1437. (list 1) (list 2))
  1438. good)))
  1439. ;;
  1440. ;; lset-intersection
  1441. ;;
  1442. (with-test-prefix "lset-intersection"
  1443. (pass-if "called arg order"
  1444. (let ((good #f))
  1445. (lset-intersection (lambda (x y)
  1446. (set! good (and (= x 1) (= y 2)))
  1447. (= x y))
  1448. '(1) '(2))
  1449. good)))
  1450. ;;
  1451. ;; lset-intersection!
  1452. ;;
  1453. (with-test-prefix "lset-intersection"
  1454. (pass-if "called arg order"
  1455. (let ((good #f))
  1456. (lset-intersection (lambda (x y)
  1457. (set! good (and (= x 1) (= y 2)))
  1458. (= x y))
  1459. (list 1) (list 2))
  1460. good)))
  1461. ;;
  1462. ;; lset-union
  1463. ;;
  1464. (with-test-prefix "lset-union"
  1465. (pass-if "no args"
  1466. (eq? '() (lset-union eq?)))
  1467. (pass-if "one arg"
  1468. (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
  1469. (pass-if "'() '()"
  1470. (equal? '() (lset-union eq? '() '())))
  1471. (pass-if "'() '(1 2 3)"
  1472. (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
  1473. (pass-if "'(1 2 3) '()"
  1474. (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
  1475. (pass-if "'(1 2 3) '(4 3 5)"
  1476. (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5))))
  1477. (pass-if "'(1 2 3) '(4) '(3 5))"
  1478. (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5))))
  1479. ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
  1480. ;; way around
  1481. (pass-if "called arg order"
  1482. (let ((good #f))
  1483. (lset-union (lambda (x y)
  1484. (set! good (and (= x 1) (= y 2)))
  1485. (= x y))
  1486. '(1) '(2))
  1487. good)))
  1488. ;;
  1489. ;; member
  1490. ;;
  1491. (with-test-prefix "member"
  1492. (pass-if-exception "no args" exception:wrong-num-args
  1493. (member))
  1494. (pass-if-exception "one arg" exception:wrong-num-args
  1495. (member 1))
  1496. (pass-if "1 (1 2 3)"
  1497. (let ((lst '(1 2 3)))
  1498. (eq? lst (member 1 lst))))
  1499. (pass-if "2 (1 2 3)"
  1500. (let ((lst '(1 2 3)))
  1501. (eq? (cdr lst) (member 2 lst))))
  1502. (pass-if "3 (1 2 3)"
  1503. (let ((lst '(1 2 3)))
  1504. (eq? (cddr lst) (member 3 lst))))
  1505. (pass-if "4 (1 2 3)"
  1506. (let ((lst '(1 2 3)))
  1507. (eq? #f (member 4 lst))))
  1508. (pass-if "called arg order"
  1509. (let ((good #f))
  1510. (member 1 '(2) (lambda (x y)
  1511. (set! good (and (eqv? 1 x)
  1512. (eqv? 2 y)))))
  1513. good)))
  1514. ;;
  1515. ;; ninth
  1516. ;;
  1517. (with-test-prefix "ninth"
  1518. (pass-if-exception "() -1" exception:wrong-type-arg
  1519. (ninth '(a b c d e f g h)))
  1520. (pass-if (eq? 'i (ninth '(a b c d e f g h i))))
  1521. (pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
  1522. ;;
  1523. ;; not-pair?
  1524. ;;
  1525. (with-test-prefix "not-pair?"
  1526. (pass-if "inum"
  1527. (eq? #t (not-pair? 123)))
  1528. (pass-if "pair"
  1529. (eq? #f (not-pair? '(x . y))))
  1530. (pass-if "symbol"
  1531. (eq? #t (not-pair? 'x))))
  1532. ;;
  1533. ;; take
  1534. ;;
  1535. (with-test-prefix "take"
  1536. (pass-if "'() 0"
  1537. (null? (take '() 0)))
  1538. (pass-if "'(a) 0"
  1539. (null? (take '(a) 0)))
  1540. (pass-if "'(a b) 0"
  1541. (null? (take '() 0)))
  1542. (pass-if "'(a b c) 0"
  1543. (null? (take '() 0)))
  1544. (pass-if "'(a) 1"
  1545. (let* ((lst '(a))
  1546. (got (take lst 1)))
  1547. (and (equal? '(a) got)
  1548. (not (eq? lst got)))))
  1549. (pass-if "'(a b) 1"
  1550. (equal? '(a)
  1551. (take '(a b) 1)))
  1552. (pass-if "'(a b c) 1"
  1553. (equal? '(a)
  1554. (take '(a b c) 1)))
  1555. (pass-if "'(a b) 2"
  1556. (let* ((lst '(a b))
  1557. (got (take lst 2)))
  1558. (and (equal? '(a b) got)
  1559. (not (eq? lst got)))))
  1560. (pass-if "'(a b c) 2"
  1561. (equal? '(a b)
  1562. (take '(a b c) 2)))
  1563. (pass-if "circular '(a) 0"
  1564. (equal? '()
  1565. (take (circular-list 'a) 0)))
  1566. (pass-if "circular '(a) 1"
  1567. (equal? '(a)
  1568. (take (circular-list 'a) 1)))
  1569. (pass-if "circular '(a) 2"
  1570. (equal? '(a a)
  1571. (take (circular-list 'a) 2)))
  1572. (pass-if "circular '(a b) 5"
  1573. (equal? '(a b a b a)
  1574. (take (circular-list 'a 'b) 5)))
  1575. (pass-if "'(a . b) 1"
  1576. (equal? '(a)
  1577. (take '(a . b) 1)))
  1578. (pass-if "'(a b . c) 1"
  1579. (equal? '(a)
  1580. (take '(a b . c) 1)))
  1581. (pass-if "'(a b . c) 2"
  1582. (equal? '(a b)
  1583. (take '(a b . c) 2))))
  1584. ;;
  1585. ;; take-while
  1586. ;;
  1587. (with-test-prefix "take-while"
  1588. (pass-if (equal? '() (take-while odd? '())))
  1589. (pass-if (equal? '(1) (take-while odd? '(1))))
  1590. (pass-if (equal? '(1 3) (take-while odd? '(1 3))))
  1591. (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5))))
  1592. (pass-if (equal? '() (take-while odd? '(2))))
  1593. (pass-if (equal? '(1) (take-while odd? '(1 2))))
  1594. (pass-if (equal? '(1 3) (take-while odd? '(1 3 4))))
  1595. (pass-if (equal? '() (take-while odd? '(2 1))))
  1596. (pass-if (equal? '(1) (take-while odd? '(1 4 3))))
  1597. (pass-if (equal? '() (take-while odd? '(4 1 3)))))
  1598. ;;
  1599. ;; take-while!
  1600. ;;
  1601. (with-test-prefix "take-while!"
  1602. (pass-if (equal? '() (take-while! odd? '())))
  1603. (pass-if (equal? '(1) (take-while! odd? (list 1))))
  1604. (pass-if (equal? '(1 3) (take-while! odd? (list 1 3))))
  1605. (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5))))
  1606. (pass-if (equal? '() (take-while! odd? (list 2))))
  1607. (pass-if (equal? '(1) (take-while! odd? (list 1 2))))
  1608. (pass-if (equal? '(1 3) (take-while! odd? (list 1 3 4))))
  1609. (pass-if (equal? '() (take-while! odd? (list 2 1))))
  1610. (pass-if (equal? '(1) (take-while! odd? (list 1 4 3))))
  1611. (pass-if (equal? '() (take-while! odd? (list 4 1 3)))))
  1612. ;;
  1613. ;; partition
  1614. ;;
  1615. (define (test-partition pred list kept-good dropped-good)
  1616. (call-with-values (lambda ()
  1617. (partition pred list))
  1618. (lambda (kept dropped)
  1619. (and (equal? kept kept-good)
  1620. (equal? dropped dropped-good)))))
  1621. (with-test-prefix "partition"
  1622. (pass-if "with dropped tail"
  1623. (test-partition even? '(1 2 3 4 5 6 7)
  1624. '(2 4 6) '(1 3 5 7)))
  1625. (pass-if "with kept tail"
  1626. (test-partition even? '(1 2 3 4 5 6)
  1627. '(2 4 6) '(1 3 5)))
  1628. (pass-if "with everything dropped"
  1629. (test-partition even? '(1 3 5 7)
  1630. '() '(1 3 5 7)))
  1631. (pass-if "with everything kept"
  1632. (test-partition even? '(2 4 6)
  1633. '(2 4 6) '()))
  1634. (pass-if "with empty list"
  1635. (test-partition even? '()
  1636. '() '()))
  1637. (pass-if "with reasonably long list"
  1638. ;; the old implementation from SRFI-1 reference implementation
  1639. ;; would signal a stack-overflow for a list of only 500 elements!
  1640. (call-with-values (lambda ()
  1641. (partition even?
  1642. (make-list 10000 1)))
  1643. (lambda (even odd)
  1644. (and (= (length odd) 10000)
  1645. (= (length even) 0)))))
  1646. (pass-if-exception "with improper list"
  1647. exception:wrong-type-arg
  1648. (partition symbol? '(a b . c))))
  1649. ;;
  1650. ;; partition!
  1651. ;;
  1652. (define (test-partition! pred list kept-good dropped-good)
  1653. (call-with-values (lambda ()
  1654. (partition! pred list))
  1655. (lambda (kept dropped)
  1656. (and (equal? kept kept-good)
  1657. (equal? dropped dropped-good)))))
  1658. (with-test-prefix "partition!"
  1659. (pass-if "with dropped tail"
  1660. (test-partition! even? (list 1 2 3 4 5 6 7)
  1661. '(2 4 6) '(1 3 5 7)))
  1662. (pass-if "with kept tail"
  1663. (test-partition! even? (list 1 2 3 4 5 6)
  1664. '(2 4 6) '(1 3 5)))
  1665. (pass-if "with everything dropped"
  1666. (test-partition! even? (list 1 3 5 7)
  1667. '() '(1 3 5 7)))
  1668. (pass-if "with everything kept"
  1669. (test-partition! even? (list 2 4 6)
  1670. '(2 4 6) '()))
  1671. (pass-if "with empty list"
  1672. (test-partition! even? '()
  1673. '() '()))
  1674. (pass-if "with reasonably long list"
  1675. ;; the old implementation from SRFI-1 reference implementation
  1676. ;; would signal a stack-overflow for a list of only 500 elements!
  1677. (call-with-values (lambda ()
  1678. (partition! even?
  1679. (make-list 10000 1)))
  1680. (lambda (even odd)
  1681. (and (= (length odd) 10000)
  1682. (= (length even) 0)))))
  1683. (pass-if-exception "with improper list"
  1684. exception:wrong-type-arg
  1685. (partition! symbol? (cons* 'a 'b 'c))))
  1686. ;;
  1687. ;; reduce
  1688. ;;
  1689. (with-test-prefix "reduce"
  1690. (pass-if "empty"
  1691. (let* ((calls '())
  1692. (ret (reduce (lambda (x prev)
  1693. (set! calls (cons (list x prev) calls))
  1694. x)
  1695. 1 '())))
  1696. (and (equal? calls '())
  1697. (equal? ret 1))))
  1698. (pass-if "one elem"
  1699. (let* ((calls '())
  1700. (ret (reduce (lambda (x prev)
  1701. (set! calls (cons (list x prev) calls))
  1702. x)
  1703. 1 '(2))))
  1704. (and (equal? calls '())
  1705. (equal? ret 2))))
  1706. (pass-if "two elems"
  1707. (let* ((calls '())
  1708. (ret (reduce (lambda (x prev)
  1709. (set! calls (cons (list x prev) calls))
  1710. x)
  1711. 1 '(2 3))))
  1712. (and (equal? calls '((3 2)))
  1713. (equal? ret 3))))
  1714. (pass-if "three elems"
  1715. (let* ((calls '())
  1716. (ret (reduce (lambda (x prev)
  1717. (set! calls (cons (list x prev) calls))
  1718. x)
  1719. 1 '(2 3 4))))
  1720. (and (equal? calls '((4 3)
  1721. (3 2)))
  1722. (equal? ret 4))))
  1723. (pass-if "four elems"
  1724. (let* ((calls '())
  1725. (ret (reduce (lambda (x prev)
  1726. (set! calls (cons (list x prev) calls))
  1727. x)
  1728. 1 '(2 3 4 5))))
  1729. (and (equal? calls '((5 4)
  1730. (4 3)
  1731. (3 2)))
  1732. (equal? ret 5)))))
  1733. ;;
  1734. ;; reduce-right
  1735. ;;
  1736. (with-test-prefix "reduce-right"
  1737. (pass-if "empty"
  1738. (let* ((calls '())
  1739. (ret (reduce-right (lambda (x prev)
  1740. (set! calls (cons (list x prev) calls))
  1741. x)
  1742. 1 '())))
  1743. (and (equal? calls '())
  1744. (equal? ret 1))))
  1745. (pass-if "one elem"
  1746. (let* ((calls '())
  1747. (ret (reduce-right (lambda (x prev)
  1748. (set! calls (cons (list x prev) calls))
  1749. x)
  1750. 1 '(2))))
  1751. (and (equal? calls '())
  1752. (equal? ret 2))))
  1753. (pass-if "two elems"
  1754. (let* ((calls '())
  1755. (ret (reduce-right (lambda (x prev)
  1756. (set! calls (cons (list x prev) calls))
  1757. x)
  1758. 1 '(2 3))))
  1759. (and (equal? calls '((2 3)))
  1760. (equal? ret 2))))
  1761. (pass-if "three elems"
  1762. (let* ((calls '())
  1763. (ret (reduce-right (lambda (x prev)
  1764. (set! calls (cons (list x prev) calls))
  1765. x)
  1766. 1 '(2 3 4))))
  1767. (and (equal? calls '((2 3)
  1768. (3 4)))
  1769. (equal? ret 2))))
  1770. (pass-if "four elems"
  1771. (let* ((calls '())
  1772. (ret (reduce-right (lambda (x prev)
  1773. (set! calls (cons (list x prev) calls))
  1774. x)
  1775. 1 '(2 3 4 5))))
  1776. (and (equal? calls '((2 3)
  1777. (3 4)
  1778. (4 5)))
  1779. (equal? ret 2)))))
  1780. ;;
  1781. ;; remove
  1782. ;;
  1783. (with-test-prefix "remove"
  1784. (pass-if (equal? '() (remove odd? '())))
  1785. (pass-if (equal? '() (remove odd? '(1))))
  1786. (pass-if (equal? '(2) (remove odd? '(2))))
  1787. (pass-if (equal? '() (remove odd? '(1 3))))
  1788. (pass-if (equal? '(2) (remove odd? '(2 3))))
  1789. (pass-if (equal? '(2) (remove odd? '(1 2))))
  1790. (pass-if (equal? '(2 4) (remove odd? '(2 4))))
  1791. (pass-if (equal? '() (remove odd? '(1 3 5))))
  1792. (pass-if (equal? '(2) (remove odd? '(2 3 5))))
  1793. (pass-if (equal? '(2) (remove odd? '(1 2 5))))
  1794. (pass-if (equal? '(2 4) (remove odd? '(2 4 5))))
  1795. (pass-if (equal? '(6) (remove odd? '(1 3 6))))
  1796. (pass-if (equal? '(2 6) (remove odd? '(2 3 6))))
  1797. (pass-if (equal? '(2 6) (remove odd? '(1 2 6))))
  1798. (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6)))))
  1799. ;;
  1800. ;; remove!
  1801. ;;
  1802. (with-test-prefix "remove!"
  1803. (pass-if (equal? '() (remove! odd? '())))
  1804. (pass-if (equal? '() (remove! odd? (list 1))))
  1805. (pass-if (equal? '(2) (remove! odd? (list 2))))
  1806. (pass-if (equal? '() (remove! odd? (list 1 3))))
  1807. (pass-if (equal? '(2) (remove! odd? (list 2 3))))
  1808. (pass-if (equal? '(2) (remove! odd? (list 1 2))))
  1809. (pass-if (equal? '(2 4) (remove! odd? (list 2 4))))
  1810. (pass-if (equal? '() (remove! odd? (list 1 3 5))))
  1811. (pass-if (equal? '(2) (remove! odd? (list 2 3 5))))
  1812. (pass-if (equal? '(2) (remove! odd? (list 1 2 5))))
  1813. (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5))))
  1814. (pass-if (equal? '(6) (remove! odd? (list 1 3 6))))
  1815. (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6))))
  1816. (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6))))
  1817. (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6)))))
  1818. ;;
  1819. ;; seventh
  1820. ;;
  1821. (with-test-prefix "seventh"
  1822. (pass-if-exception "() -1" exception:wrong-type-arg
  1823. (seventh '(a b c d e f)))
  1824. (pass-if (eq? 'g (seventh '(a b c d e f g))))
  1825. (pass-if (eq? 'g (seventh '(a b c d e f g h)))))
  1826. ;;
  1827. ;; sixth
  1828. ;;
  1829. (with-test-prefix "sixth"
  1830. (pass-if-exception "() -1" exception:wrong-type-arg
  1831. (sixth '(a b c d e)))
  1832. (pass-if (eq? 'f (sixth '(a b c d e f))))
  1833. (pass-if (eq? 'f (sixth '(a b c d e f g)))))
  1834. ;;
  1835. ;; split-at
  1836. ;;
  1837. (with-test-prefix "split-at"
  1838. (define (equal-values? lst thunk)
  1839. (call-with-values thunk
  1840. (lambda got
  1841. (equal? lst got))))
  1842. (pass-if-exception "() -1" exception:out-of-range
  1843. (split-at '() -1))
  1844. (pass-if (equal-values? '(() ())
  1845. (lambda () (split-at '() 0))))
  1846. (pass-if-exception "() 1" exception:wrong-type-arg
  1847. (split-at '() 1))
  1848. (pass-if-exception "(1) -1" exception:out-of-range
  1849. (split-at '(1) -1))
  1850. (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0))))
  1851. (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1))))
  1852. (pass-if-exception "(1) 2" exception:wrong-type-arg
  1853. (split-at '(1) 2))
  1854. (pass-if-exception "(4 5) -1" exception:out-of-range
  1855. (split-at '(4 5) -1))
  1856. (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0))))
  1857. (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1))))
  1858. (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2))))
  1859. (pass-if-exception "(4 5) 3" exception:wrong-type-arg
  1860. (split-at '(4 5) 3))
  1861. (pass-if-exception "(4 5 6) -1" exception:out-of-range
  1862. (split-at '(4 5 6) -1))
  1863. (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0))))
  1864. (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1))))
  1865. (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2))))
  1866. (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3))))
  1867. (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
  1868. (split-at '(4 5 6) 4)))
  1869. ;;
  1870. ;; split-at!
  1871. ;;
  1872. (with-test-prefix "split-at!"
  1873. (define (equal-values? lst thunk)
  1874. (call-with-values thunk
  1875. (lambda got
  1876. (equal? lst got))))
  1877. (pass-if-exception "() -1" exception:out-of-range
  1878. (split-at! '() -1))
  1879. (pass-if (equal-values? '(() ())
  1880. (lambda () (split-at! '() 0))))
  1881. (pass-if-exception "() 1" exception:wrong-type-arg
  1882. (split-at! '() 1))
  1883. (pass-if-exception "(1) -1" exception:out-of-range
  1884. (split-at! (list 1) -1))
  1885. (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0))))
  1886. (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1))))
  1887. (pass-if-exception "(1) 2" exception:wrong-type-arg
  1888. (split-at! (list 1) 2))
  1889. (pass-if-exception "(4 5) -1" exception:out-of-range
  1890. (split-at! (list 4 5) -1))
  1891. (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0))))
  1892. (pass-if (equal-values? '((4) (5)) (lambda () (split-at! (list 4 5) 1))))
  1893. (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2))))
  1894. (pass-if-exception "(4 5) 3" exception:wrong-type-arg
  1895. (split-at! (list 4 5) 3))
  1896. (pass-if-exception "(4 5 6) -1" exception:out-of-range
  1897. (split-at! (list 4 5 6) -1))
  1898. (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0))))
  1899. (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at! (list 4 5 6) 1))))
  1900. (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at! (list 4 5 6) 2))))
  1901. (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3))))
  1902. (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
  1903. (split-at! (list 4 5 6) 4)))
  1904. ;;
  1905. ;; span
  1906. ;;
  1907. (with-test-prefix "span"
  1908. (define (test-span lst want-v1 want-v2)
  1909. (call-with-values
  1910. (lambda ()
  1911. (span positive? lst))
  1912. (lambda (got-v1 got-v2)
  1913. (and (equal? got-v1 want-v1)
  1914. (equal? got-v2 want-v2)))))
  1915. (pass-if "empty"
  1916. (test-span '() '() '()))
  1917. (pass-if "y"
  1918. (test-span '(1) '(1) '()))
  1919. (pass-if "n"
  1920. (test-span '(-1) '() '(-1)))
  1921. (pass-if "yy"
  1922. (test-span '(1 2) '(1 2) '()))
  1923. (pass-if "ny"
  1924. (test-span '(-1 1) '() '(-1 1)))
  1925. (pass-if "yn"
  1926. (test-span '(1 -1) '(1) '(-1)))
  1927. (pass-if "nn"
  1928. (test-span '(-1 -2) '() '(-1 -2)))
  1929. (pass-if "yyy"
  1930. (test-span '(1 2 3) '(1 2 3) '()))
  1931. (pass-if "nyy"
  1932. (test-span '(-1 1 2) '() '(-1 1 2)))
  1933. (pass-if "yny"
  1934. (test-span '(1 -1 2) '(1) '(-1 2)))
  1935. (pass-if "nny"
  1936. (test-span '(-1 -2 1) '() '(-1 -2 1)))
  1937. (pass-if "yyn"
  1938. (test-span '(1 2 -1) '(1 2) '(-1)))
  1939. (pass-if "nyn"
  1940. (test-span '(-1 1 -2) '() '(-1 1 -2)))
  1941. (pass-if "ynn"
  1942. (test-span '(1 -1 -2) '(1) '(-1 -2)))
  1943. (pass-if "nnn"
  1944. (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
  1945. ;;
  1946. ;; span!
  1947. ;;
  1948. (with-test-prefix "span!"
  1949. (define (test-span! lst want-v1 want-v2)
  1950. (call-with-values
  1951. (lambda ()
  1952. (span! positive? lst))
  1953. (lambda (got-v1 got-v2)
  1954. (and (equal? got-v1 want-v1)
  1955. (equal? got-v2 want-v2)))))
  1956. (pass-if "empty"
  1957. (test-span! '() '() '()))
  1958. (pass-if "y"
  1959. (test-span! (list 1) '(1) '()))
  1960. (pass-if "n"
  1961. (test-span! (list -1) '() '(-1)))
  1962. (pass-if "yy"
  1963. (test-span! (list 1 2) '(1 2) '()))
  1964. (pass-if "ny"
  1965. (test-span! (list -1 1) '() '(-1 1)))
  1966. (pass-if "yn"
  1967. (test-span! (list 1 -1) '(1) '(-1)))
  1968. (pass-if "nn"
  1969. (test-span! (list -1 -2) '() '(-1 -2)))
  1970. (pass-if "yyy"
  1971. (test-span! (list 1 2 3) '(1 2 3) '()))
  1972. (pass-if "nyy"
  1973. (test-span! (list -1 1 2) '() '(-1 1 2)))
  1974. (pass-if "yny"
  1975. (test-span! (list 1 -1 2) '(1) '(-1 2)))
  1976. (pass-if "nny"
  1977. (test-span! (list -1 -2 1) '() '(-1 -2 1)))
  1978. (pass-if "yyn"
  1979. (test-span! (list 1 2 -1) '(1 2) '(-1)))
  1980. (pass-if "nyn"
  1981. (test-span! (list -1 1 -2) '() '(-1 1 -2)))
  1982. (pass-if "ynn"
  1983. (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
  1984. (pass-if "nnn"
  1985. (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
  1986. ;;
  1987. ;; take!
  1988. ;;
  1989. (with-test-prefix "take!"
  1990. (pass-if-exception "() -1" exception:out-of-range
  1991. (take! '() -1))
  1992. (pass-if (equal? '() (take! '() 0)))
  1993. (pass-if-exception "() 1" exception:wrong-type-arg
  1994. (take! '() 1))
  1995. (pass-if-exception "(1) -1" exception:out-of-range
  1996. (take! '(1) -1))
  1997. (pass-if (equal? '() (take! '(1) 0)))
  1998. (pass-if (equal? '(1) (take! '(1) 1)))
  1999. (pass-if-exception "(1) 2" exception:wrong-type-arg
  2000. (take! '(1) 2))
  2001. (pass-if-exception "(4 5) -1" exception:out-of-range
  2002. (take! '(4 5) -1))
  2003. (pass-if (equal? '() (take! '(4 5) 0)))
  2004. (pass-if (equal? '(4) (take! '(4 5) 1)))
  2005. (pass-if (equal? '(4 5) (take! '(4 5) 2)))
  2006. (pass-if-exception "(4 5) 3" exception:wrong-type-arg
  2007. (take! '(4 5) 3))
  2008. (pass-if-exception "(4 5 6) -1" exception:out-of-range
  2009. (take! '(4 5 6) -1))
  2010. (pass-if (equal? '() (take! '(4 5 6) 0)))
  2011. (pass-if (equal? '(4) (take! '(4 5 6) 1)))
  2012. (pass-if (equal? '(4 5) (take! '(4 5 6) 2)))
  2013. (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3)))
  2014. (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
  2015. (take! '(4 5 6) 4)))
  2016. ;;
  2017. ;; take-right
  2018. ;;
  2019. (with-test-prefix "take-right"
  2020. (pass-if-exception "() -1" exception:out-of-range
  2021. (take-right '() -1))
  2022. (pass-if (equal? '() (take-right '() 0)))
  2023. (pass-if-exception "() 1" exception:wrong-type-arg
  2024. (take-right '() 1))
  2025. (pass-if-exception "(1) -1" exception:out-of-range
  2026. (take-right '(1) -1))
  2027. (pass-if (equal? '() (take-right '(1) 0)))
  2028. (pass-if (equal? '(1) (take-right '(1) 1)))
  2029. (pass-if-exception "(1) 2" exception:wrong-type-arg
  2030. (take-right '(1) 2))
  2031. (pass-if-exception "(4 5) -1" exception:out-of-range
  2032. (take-right '(4 5) -1))
  2033. (pass-if (equal? '() (take-right '(4 5) 0)))
  2034. (pass-if (equal? '(5) (take-right '(4 5) 1)))
  2035. (pass-if (equal? '(4 5) (take-right '(4 5) 2)))
  2036. (pass-if-exception "(4 5) 3" exception:wrong-type-arg
  2037. (take-right '(4 5) 3))
  2038. (pass-if-exception "(4 5 6) -1" exception:out-of-range
  2039. (take-right '(4 5 6) -1))
  2040. (pass-if (equal? '() (take-right '(4 5 6) 0)))
  2041. (pass-if (equal? '(6) (take-right '(4 5 6) 1)))
  2042. (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
  2043. (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
  2044. (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
  2045. (take-right '(4 5 6) 4))
  2046. (pass-if "(a b . c) 0"
  2047. (equal? (take-right '(a b . c) 0) 'c))
  2048. (pass-if "(a b . c) 1"
  2049. (equal? (take-right '(a b . c) 1) '(b . c))))
  2050. ;;
  2051. ;; tenth
  2052. ;;
  2053. (with-test-prefix "tenth"
  2054. (pass-if-exception "() -1" exception:wrong-type-arg
  2055. (tenth '(a b c d e f g h i)))
  2056. (pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
  2057. (pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))
  2058. ;;
  2059. ;; xcons
  2060. ;;
  2061. (with-test-prefix "xcons"
  2062. (pass-if (equal? '(y . x) (xcons 'x 'y))))