12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657 |
- ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
- ;;;;
- ;;;; Copyright 2003-2006, 2008-2011, 2014, 2020 Free Software Foundation, Inc.
- ;;;;
- ;;;; This library is free software; you can redistribute it and/or
- ;;;; modify it under the terms of the GNU Lesser General Public
- ;;;; License as published by the Free Software Foundation; either
- ;;;; version 3 of the License, or (at your option) any later version.
- ;;;;
- ;;;; This library is distributed in the hope that it will be useful,
- ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ;;;; Lesser General Public License for more details.
- ;;;;
- ;;;; You should have received a copy of the GNU Lesser General Public
- ;;;; License along with this library; if not, write to the Free Software
- ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- (define-module (test-srfi-1)
- #:use-module (test-suite lib)
- #:use-module (ice-9 copy-tree)
- #:use-module (srfi srfi-1))
- (define (ref-delete x lst . proc)
- "Reference implemenation of srfi-1 `delete'."
- (set! proc (if (null? proc) equal? (car proc)))
- (do ((ret '())
- (lst lst (cdr lst)))
- ((null? lst)
- (reverse! ret))
- (if (not (proc x (car lst)))
- (set! ret (cons (car lst) ret)))))
- (define (ref-delete-duplicates lst . proc)
- "Reference implemenation of srfi-1 `delete-duplicates'."
- (set! proc (if (null? proc) equal? (car proc)))
- (if (null? lst)
- '()
- (do ((keep '()))
- ((null? lst)
- (reverse! keep))
- (let ((elem (car lst)))
- (set! keep (cons elem keep))
- (set! lst (ref-delete elem lst proc))))))
- ;;
- ;; alist-copy
- ;;
- (with-test-prefix "alist-copy"
- ;; return a list which is the pairs making up alist A, the spine and cells
- (define (alist-pairs a)
- (let more ((a a)
- (result a))
- (if (pair? a)
- (more (cdr a) (cons a result))
- result)))
- ;; return a list of the elements common to lists X and Y, compared with eq?
- (define (common-elements x y)
- (if (null? x)
- '()
- (if (memq (car x) y)
- (cons (car x) (common-elements (cdr x) y))
- (common-elements (cdr x) y))))
- ;; validate an alist-copy of OLD to NEW
- ;; lists must be equal, and must comprise new pairs
- (define (valid-alist-copy? old new)
- (and (equal? old new)
- (null? (common-elements old new))))
- (pass-if-exception "too few args" exception:wrong-num-args
- (alist-copy))
-
- (pass-if-exception "too many args" exception:wrong-num-args
- (alist-copy '() '()))
-
- (let ((old '()))
- (pass-if old (valid-alist-copy? old (alist-copy old))))
- (let ((old '((1 . 2))))
- (pass-if old (valid-alist-copy? old (alist-copy old))))
- (let ((old '((1 . 2) (3 . 4))))
- (pass-if old (valid-alist-copy? old (alist-copy old))))
- (let ((old '((1 . 2) (3 . 4) (5 . 6))))
- (pass-if old (valid-alist-copy? old (alist-copy old)))))
- ;;
- ;; alist-delete
- ;;
- (with-test-prefix "alist-delete"
- (pass-if "equality call arg order"
- (let ((good #f))
- (alist-delete 'k '((ak . 123))
- (lambda (k ak)
- (if (and (eq? k 'k) (eq? ak 'ak))
- (set! good #t))))
- good))
- (pass-if "delete keys greater than 5"
- (equal? '((4 . x) (5 . y))
- (alist-delete 5 '((4 . x) (5 . y) (6 . z)) <)))
- (pass-if "empty"
- (equal? '() (alist-delete 'x '())))
- (pass-if "(y)"
- (equal? '() (alist-delete 'y '((y . 1)))))
- (pass-if "(n)"
- (equal? '((n . 1)) (alist-delete 'y '((n . 1)))))
- (pass-if "(y y)"
- (equal? '() (alist-delete 'y '((y . 1) (y . 2)))))
- (pass-if "(n y)"
- (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2)))))
- (pass-if "(y n)"
- (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2)))))
- (pass-if "(n n)"
- (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2)))))
- (pass-if "(y y y)"
- (equal? '() (alist-delete 'y '((y . 1) (y . 2) (y . 3)))))
- (pass-if "(n y y)"
- (equal? '((n . 1)) (alist-delete 'y '((n . 1) (y . 2) (y . 3)))))
- (pass-if "(y n y)"
- (equal? '((n . 2)) (alist-delete 'y '((y . 1) (n . 2) (y . 3)))))
- (pass-if "(n n y)"
- (equal? '((n . 1) (n . 2)) (alist-delete 'y '((n . 1) (n . 2) (y . 3)))))
- (pass-if "(y y n)"
- (equal? '( (n . 3)) (alist-delete 'y '((y . 1) (y . 2) (n . 3)))))
- (pass-if "(n y n)"
- (equal? '((n . 1) (n . 3)) (alist-delete 'y '((n . 1) (y . 2) (n . 3)))))
- (pass-if "(y n n)"
- (equal? '((n . 2) (n . 3)) (alist-delete 'y '((y . 1) (n . 2) (n . 3)))))
- (pass-if "(n n n)"
- (equal? '((n . 1) (n . 2) (n . 3)) (alist-delete 'y '((n . 1) (n . 2) (n . 3))))))
- ;;
- ;; append-map
- ;;
- (with-test-prefix "append-map"
- (with-test-prefix "one list"
- (pass-if "()"
- (equal? '() (append-map noop '(()))))
- (pass-if "(1)"
- (equal? '(1) (append-map noop '((1)))))
- (pass-if "(1 2)"
- (equal? '(1 2) (append-map noop '((1 2)))))
- (pass-if "() ()"
- (equal? '() (append-map noop '(() ()))))
- (pass-if "() (1)"
- (equal? '(1) (append-map noop '(() (1)))))
- (pass-if "() (1 2)"
- (equal? '(1 2) (append-map noop '(() (1 2)))))
- (pass-if "(1) (2)"
- (equal? '(1 2) (append-map noop '((1) (2)))))
- (pass-if "(1 2) ()"
- (equal? '(1 2) (append-map noop '(() (1 2))))))
- (with-test-prefix "two lists"
- (pass-if "() / 9"
- (equal? '() (append-map noop '(()) '(9))))
- (pass-if "(1) / 9"
- (equal? '(1) (append-map noop '((1)) '(9))))
- (pass-if "() () / 9 9"
- (equal? '() (append-map noop '(() ()) '(9 9))))
- (pass-if "(1) (2) / 9"
- (equal? '(1) (append-map noop '((1) (2)) '(9))))
- (pass-if "(1) (2) / 9 9"
- (equal? '(1 2) (append-map noop '((1) (2)) '(9 9))))))
- ;;
- ;; append-reverse
- ;;
- (with-test-prefix "append-reverse"
- ;; return a list which is the cars and cdrs of LST
- (define (list-contents lst)
- (if (null? lst)
- '()
- (cons* (car lst) (cdr lst) (list-contents (cdr lst)))))
- (define (valid-append-reverse revhead tail want)
- (let ((revhead-contents (list-contents revhead))
- (got (append-reverse revhead tail)))
- (and (equal? got want)
- ;; revhead unchanged
- (equal? revhead-contents (list-contents revhead)))))
- (pass-if-exception "too few args (0)" exception:wrong-num-args
- (append-reverse))
- (pass-if-exception "too few args (1)" exception:wrong-num-args
- (append-reverse '(x)))
- (pass-if-exception "too many args (3)" exception:wrong-num-args
- (append-reverse '() '() #f))
- (pass-if (valid-append-reverse '() '() '()))
- (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3)))
- (pass-if (valid-append-reverse '(1) '() '(1)))
- (pass-if (valid-append-reverse '(1) '(2) '(1 2)))
- (pass-if (valid-append-reverse '(1) '(2 3) '(1 2 3)))
- (pass-if (valid-append-reverse '(1 2) '() '(2 1)))
- (pass-if (valid-append-reverse '(1 2) '(3) '(2 1 3)))
- (pass-if (valid-append-reverse '(1 2) '(3 4) '(2 1 3 4)))
- (pass-if (valid-append-reverse '(1 2 3) '() '(3 2 1)))
- (pass-if (valid-append-reverse '(1 2 3) '(4) '(3 2 1 4)))
- (pass-if (valid-append-reverse '(1 2 3) '(4 5) '(3 2 1 4 5))))
- ;;
- ;; append-reverse!
- ;;
- (with-test-prefix "append-reverse!"
- (pass-if-exception "too few args (0)" exception:wrong-num-args
- (append-reverse!))
- (pass-if-exception "too few args (1)" exception:wrong-num-args
- (append-reverse! '(x)))
- (pass-if-exception "too many args (3)" exception:wrong-num-args
- (append-reverse! '() '() #f))
- (pass-if (equal? '() (append-reverse! '() '())))
- (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3))))
- (pass-if (equal? '(1) (append-reverse! '(1) '())))
- (pass-if (equal? '(1 2) (append-reverse! '(1) '(2))))
- (pass-if (equal? '(1 2 3) (append-reverse! '(1) '(2 3))))
- (pass-if (equal? '(2 1) (append-reverse! '(1 2) '())))
- (pass-if (equal? '(2 1 3) (append-reverse! '(1 2) '(3))))
- (pass-if (equal? '(2 1 3 4) (append-reverse! '(1 2) '(3 4))))
- (pass-if (equal? '(3 2 1) (append-reverse! '(1 2 3) '())))
- (pass-if (equal? '(3 2 1 4) (append-reverse! '(1 2 3) '(4))))
- (pass-if (equal? '(3 2 1 4 5) (append-reverse! '(1 2 3) '(4 5)))))
- ;;
- ;; assoc
- ;;
- (with-test-prefix "assoc"
- (pass-if "not found"
- (let ((alist '((a . 1)
- (b . 2)
- (c . 3))))
- (eqv? #f (assoc 'z alist))))
- (pass-if "found"
- (let ((alist '((a . 1)
- (b . 2)
- (c . 3))))
- (eqv? (second alist) (assoc 'b alist))))
- ;; this was wrong in guile 1.8.0 (a gremlin newly introduced in the 1.8
- ;; series, 1.6.x and earlier was ok)
- (pass-if "= arg order"
- (let ((alist '((b . 1)))
- (good #f))
- (assoc 'a alist (lambda (x y)
- (set! good (and (eq? x 'a)
- (eq? y 'b)))))
- good))
- ;; likewise this one bad in guile 1.8.0
- (pass-if "srfi-1 example <"
- (let ((alist '((1 . a)
- (5 . b)
- (6 . c))))
- (eq? (third alist) (assoc 5 alist <)))))
- ;;
- ;; break
- ;;
- (with-test-prefix "break"
- (define (test-break lst want-v1 want-v2)
- (call-with-values
- (lambda ()
- (break negative? lst))
- (lambda (got-v1 got-v2)
- (and (equal? got-v1 want-v1)
- (equal? got-v2 want-v2)))))
- (pass-if "empty"
- (test-break '() '() '()))
- (pass-if "y"
- (test-break '(1) '(1) '()))
- (pass-if "n"
- (test-break '(-1) '() '(-1)))
- (pass-if "yy"
- (test-break '(1 2) '(1 2) '()))
- (pass-if "ny"
- (test-break '(-1 1) '() '(-1 1)))
- (pass-if "yn"
- (test-break '(1 -1) '(1) '(-1)))
- (pass-if "nn"
- (test-break '(-1 -2) '() '(-1 -2)))
- (pass-if "yyy"
- (test-break '(1 2 3) '(1 2 3) '()))
- (pass-if "nyy"
- (test-break '(-1 1 2) '() '(-1 1 2)))
- (pass-if "yny"
- (test-break '(1 -1 2) '(1) '(-1 2)))
- (pass-if "nny"
- (test-break '(-1 -2 1) '() '(-1 -2 1)))
- (pass-if "yyn"
- (test-break '(1 2 -1) '(1 2) '(-1)))
- (pass-if "nyn"
- (test-break '(-1 1 -2) '() '(-1 1 -2)))
- (pass-if "ynn"
- (test-break '(1 -1 -2) '(1) '(-1 -2)))
- (pass-if "nnn"
- (test-break '(-1 -2 -3) '() '(-1 -2 -3))))
- ;;
- ;; break!
- ;;
- (with-test-prefix "break!"
- (define (test-break! lst want-v1 want-v2)
- (call-with-values
- (lambda ()
- (break! negative? lst))
- (lambda (got-v1 got-v2)
- (and (equal? got-v1 want-v1)
- (equal? got-v2 want-v2)))))
- (pass-if "empty"
- (test-break! '() '() '()))
- (pass-if "y"
- (test-break! (list 1) '(1) '()))
- (pass-if "n"
- (test-break! (list -1) '() '(-1)))
- (pass-if "yy"
- (test-break! (list 1 2) '(1 2) '()))
- (pass-if "ny"
- (test-break! (list -1 1) '() '(-1 1)))
- (pass-if "yn"
- (test-break! (list 1 -1) '(1) '(-1)))
- (pass-if "nn"
- (test-break! (list -1 -2) '() '(-1 -2)))
- (pass-if "yyy"
- (test-break! (list 1 2 3) '(1 2 3) '()))
- (pass-if "nyy"
- (test-break! (list -1 1 2) '() '(-1 1 2)))
- (pass-if "yny"
- (test-break! (list 1 -1 2) '(1) '(-1 2)))
- (pass-if "nny"
- (test-break! (list -1 -2 1) '() '(-1 -2 1)))
- (pass-if "yyn"
- (test-break! (list 1 2 -1) '(1 2) '(-1)))
- (pass-if "nyn"
- (test-break! (list -1 1 -2) '() '(-1 1 -2)))
- (pass-if "ynn"
- (test-break! (list 1 -1 -2) '(1) '(-1 -2)))
- (pass-if "nnn"
- (test-break! (list -1 -2 -3) '() '(-1 -2 -3))))
- ;;
- ;; car+cdr
- ;;
- (with-test-prefix "car+cdr"
- (pass-if "(1 . 2)"
- (call-with-values
- (lambda ()
- (car+cdr '(1 . 2)))
- (lambda (x y)
- (and (eqv? x 1)
- (eqv? y 2))))))
- ;;
- ;; concatenate and concatenate!
- ;;
- (let ()
- (define (common-tests concatenate-proc unmodified?)
- (define (try lstlst want)
- (let ((lstlst-copy (copy-tree lstlst))
- (got (concatenate-proc lstlst)))
- (if unmodified?
- (if (not (equal? lstlst lstlst-copy))
- (error "input lists modified")))
- (equal? got want)))
-
- (pass-if-exception "too few args" exception:wrong-num-args
- (concatenate-proc))
-
- (pass-if-exception "too many args" exception:wrong-num-args
- (concatenate-proc '() '()))
- (pass-if-exception "number" exception:wrong-type-arg
- (concatenate-proc 123))
- (pass-if-exception "vector" exception:wrong-type-arg
- (concatenate-proc #(1 2 3)))
-
- (pass-if "no lists"
- (try '() '()))
-
- (pass-if (try '((1)) '(1)))
- (pass-if (try '((1 2)) '(1 2)))
- (pass-if (try '(() (1)) '(1)))
- (pass-if (try '(() () (1)) '(1)))
-
- (pass-if (try '((1) (2)) '(1 2)))
- (pass-if (try '(() (1 2)) '(1 2)))
-
- (pass-if (try '((1) 2) '(1 . 2)))
- (pass-if (try '((1) (2) 3) '(1 2 . 3)))
- (pass-if (try '((1) (2) (3 . 4)) '(1 2 3 . 4)))
- )
-
- (with-test-prefix "concatenate"
- (common-tests concatenate #t))
-
- (with-test-prefix "concatenate!"
- (common-tests concatenate! #f)))
- ;;
- ;; count
- ;;
- (with-test-prefix "count"
- (pass-if-exception "no args" exception:wrong-num-args
- (count))
- (pass-if-exception "one arg" exception:wrong-num-args
- (count noop))
- (with-test-prefix "one list"
- (define (or1 x)
- x)
- (pass-if "empty list" (= 0 (count or1 '())))
- (pass-if-exception "pred arg count 0" exception:wrong-num-args
- (count (lambda () x) '(1 2 3)))
- (pass-if-exception "pred arg count 2" exception:wrong-num-args
- (count (lambda (x y) x) '(1 2 3)))
- (pass-if-exception "improper 1" exception:wrong-type-arg
- (count or1 1))
- (pass-if-exception "improper 2" exception:wrong-type-arg
- (count or1 '(1 . 2)))
- (pass-if-exception "improper 3" exception:wrong-type-arg
- (count or1 '(1 2 . 3)))
- (pass-if (= 0 (count or1 '(#f))))
- (pass-if (= 1 (count or1 '(#t))))
- (pass-if (= 0 (count or1 '(#f #f))))
- (pass-if (= 1 (count or1 '(#f #t))))
- (pass-if (= 1 (count or1 '(#t #f))))
- (pass-if (= 2 (count or1 '(#t #t))))
- (pass-if (= 0 (count or1 '(#f #f #f))))
- (pass-if (= 1 (count or1 '(#f #f #t))))
- (pass-if (= 1 (count or1 '(#t #f #f))))
- (pass-if (= 2 (count or1 '(#t #f #t))))
- (pass-if (= 3 (count or1 '(#t #t #t)))))
- (with-test-prefix "two lists"
- (define (or2 x y)
- (or x y))
- (pass-if "arg order"
- (= 1 (count (lambda (x y)
- (and (= 1 x)
- (= 2 y)))
- '(1) '(2))))
- (pass-if "empty lists" (= 0 (count or2 '() '())))
- (pass-if-exception "pred arg count 0" exception:wrong-num-args
- (count (lambda () #t) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 1" exception:wrong-num-args
- (count (lambda (x) x) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 3" exception:wrong-num-args
- (count (lambda (x y z) x) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 1" exception:wrong-type-arg
- (count or2 1 '(1 2 3)))
- (pass-if-exception "improper first 2" exception:wrong-type-arg
- (count or2 '(1 . 2) '(1 2 3)))
- (pass-if-exception "improper first 3" exception:wrong-type-arg
- (count or2 '(1 2 . 3) '(1 2 3)))
- (pass-if-exception "improper second 1" exception:wrong-type-arg
- (count or2 '(1 2 3) 1))
- (pass-if-exception "improper second 2" exception:wrong-type-arg
- (count or2 '(1 2 3) '(1 . 2)))
- (pass-if-exception "improper second 3" exception:wrong-type-arg
- (count or2 '(1 2 3) '(1 2 . 3)))
- (pass-if (= 0 (count or2 '(#f) '(#f))))
- (pass-if (= 1 (count or2 '(#t) '(#f))))
- (pass-if (= 1 (count or2 '(#f) '(#t))))
- (pass-if (= 0 (count or2 '(#f #f) '(#f #f))))
- (pass-if (= 1 (count or2 '(#t #f) '(#t #f))))
- (pass-if (= 2 (count or2 '(#t #t) '(#f #f))))
- (pass-if (= 2 (count or2 '(#t #f) '(#f #t))))
- (with-test-prefix "stop shortest"
- (pass-if (= 2 (count or2 '(#t #f #t) '(#f #t))))
- (pass-if (= 2 (count or2 '(#t #f #t #t) '(#f #t))))
- (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t))))
- (pass-if (= 2 (count or2 '(#t #f) '(#f #t #t #t))))))
- (with-test-prefix "three lists"
- (define (or3 x y z)
- (or x y z))
- (pass-if "arg order"
- (= 1 (count (lambda (x y z)
- (and (= 1 x)
- (= 2 y)
- (= 3 z)))
- '(1) '(2) '(3))))
- (pass-if "empty lists" (= 0 (count or3 '() '() '())))
- ;; currently bad pred argument gives wrong-num-args when 3 or more
- ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
- (pass-if-exception "pred arg count 0" exception:wrong-num-args
- (count (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 2" exception:wrong-num-args
- (count (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
- (pass-if-exception "pred arg count 4" exception:wrong-num-args
- (count (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 1" exception:wrong-type-arg
- (count or3 1 '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 2" exception:wrong-type-arg
- (count or3 '(1 . 2) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 3" exception:wrong-type-arg
- (count or3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper second 1" exception:wrong-type-arg
- (count or3 '(1 2 3) 1 '(1 2 3)))
- (pass-if-exception "improper second 2" exception:wrong-type-arg
- (count or3 '(1 2 3) '(1 . 2) '(1 2 3)))
- (pass-if-exception "improper second 3" exception:wrong-type-arg
- (count or3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
- (pass-if-exception "improper third 1" exception:wrong-type-arg
- (count or3 '(1 2 3) '(1 2 3) 1))
- (pass-if-exception "improper third 2" exception:wrong-type-arg
- (count or3 '(1 2 3) '(1 2 3) '(1 . 2)))
- (pass-if-exception "improper third 3" exception:wrong-type-arg
- (count or3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
- (pass-if (= 0 (count or3 '(#f) '(#f) '(#f))))
- (pass-if (= 1 (count or3 '(#t) '(#f) '(#f))))
- (pass-if (= 1 (count or3 '(#f) '(#t) '(#f))))
- (pass-if (= 1 (count or3 '(#f) '(#f) '(#t))))
- (pass-if (= 0 (count or3 '(#f #f) '(#f #f) '(#f #f))))
- (pass-if (= 1 (count or3 '(#t #f) '(#f #f) '(#f #f))))
- (pass-if (= 1 (count or3 '(#f #t) '(#f #f) '(#f #f))))
- (pass-if (= 1 (count or3 '(#f #f) '(#t #f) '(#f #f))))
- (pass-if (= 1 (count or3 '(#f #f) '(#f #t) '(#f #f))))
- (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#t #f))))
- (pass-if (= 1 (count or3 '(#f #f) '(#f #f) '(#f #t))))
- (pass-if (= 2 (count or3 '(#t #t) '(#f #f) '(#f #f))))
- (pass-if (= 2 (count or3 '(#f #f) '(#t #t) '(#f #f))))
- (pass-if (= 2 (count or3 '(#f #f) '(#f #f) '(#t #t))))
- (pass-if (= 2 (count or3 '(#f #f) '(#t #f) '(#f #t))))
- (with-test-prefix "stop shortest"
- (pass-if (= 0 (count or3 '() '(#t #t #t) '(#t #t))))
- (pass-if (= 0 (count or3 '(#t #t #t) '() '(#t #t))))
- (pass-if (= 0 (count or3 '(#t #t #t) '(#t #t) '())))
- (pass-if (= 1 (count or3 '(#t) '(#t #t #t) '(#t #t))))
- (pass-if (= 1 (count or3 '(#t #t #t) '(#t) '(#t #t))))
- (pass-if (= 1 (count or3 '(#t #t #t) '(#t #t) '(#t)))))
- (pass-if "apply list unchanged"
- (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
- (and (equal? 2 (apply count or3 lst))
- ;; lst unmodified
- (equal? '((1 2) (3 4) (5 6)) lst))))))
- ;;
- ;; delete and delete!
- ;;
- (let ()
- ;; Call (PROC lst) for all lists of length up to 6, with all combinations
- ;; of elements to be retained or deleted. Elements to retain are numbers,
- ;; 0 upwards. Elements to be deleted are #f.
- (define (test-lists proc)
- (do ((n 0 (1+ n)))
- ((>= n 6))
- (do ((limit (ash 1 n))
- (i 0 (1+ i)))
- ((>= i limit))
- (let ((lst '()))
- (do ((bit 0 (1+ bit)))
- ((>= bit n))
- (set! lst (cons (if (logbit? bit i) bit #f) lst)))
- (proc lst)))))
-
- (define (common-tests delete-proc)
- (pass-if-exception "too few args" exception:wrong-num-args
- (delete-proc 0))
-
- (pass-if-exception "too many args" exception:wrong-num-args
- (delete-proc 0 '() equal? 99))
-
- (pass-if "empty"
- (eq? '() (delete-proc 0 '() equal?)))
-
- (pass-if "equal?"
- (equal? '((1) (3))
- (delete-proc '(2) '((1) (2) (3)) equal?)))
-
- (pass-if "eq?"
- (equal? '((1) (2) (3))
- (delete-proc '(2) '((1) (2) (3)) eq?)))
-
- (pass-if "called arg order"
- (equal? '(1 2 3)
- (delete-proc 3 '(1 2 3 4 5) <))))
-
- (with-test-prefix "delete"
- (common-tests delete)
-
- (test-lists
- (lambda (lst)
- (let ((lst-copy (list-copy lst)))
- (with-test-prefix lst-copy
- (pass-if "result"
- (equal? (delete #f lst equal?)
- (ref-delete #f lst equal?)))
- (pass-if "non-destructive"
- (equal? lst-copy lst)))))))
-
- (with-test-prefix "delete!"
- (common-tests delete!)
-
- (test-lists
- (lambda (lst)
- (pass-if lst
- (equal? (delete! #f lst)
- (ref-delete #f lst)))))))
- ;;
- ;; delete-duplicates and delete-duplicates!
- ;;
- (let ()
- ;; Call (PROC lst) for all lists of length 1 <= n <= 4, with all
- ;; combinations of numbers 1 to n in the elements
- (define (test-lists proc)
- (do ((n 1 (1+ n)))
- ((> n 4))
- (do ((limit (integer-expt n n))
- (i 0 (1+ i)))
- ((>= i limit))
- (let ((lst '()))
- (do ((j 0 (1+ j))
- (rem i (quotient rem n)))
- ((>= j n))
- (set! lst (cons (remainder rem n) lst)))
- (proc lst)))))
- (define (common-tests delete-duplicates-proc)
- (pass-if-exception "too few args" exception:wrong-num-args
- (delete-duplicates-proc))
-
- (pass-if-exception "too many args" exception:wrong-num-args
- (delete-duplicates-proc '() equal? 99))
-
- (pass-if "empty"
- (eq? '() (delete-duplicates-proc '())))
-
- (pass-if "equal? (the default)"
- (equal? '((2))
- (delete-duplicates-proc '((2) (2) (2)))))
-
- (pass-if "eq?"
- (equal? '((2) (2) (2))
- (delete-duplicates-proc '((2) (2) (2)) eq?)))
- (pass-if "called arg order"
- (let ((ok #t))
- (delete-duplicates-proc '(1 2 3 4 5)
- (lambda (x y)
- (if (> x y)
- (set! ok #f))
- #f))
- ok)))
-
- (with-test-prefix "delete-duplicates"
- (common-tests delete-duplicates)
-
- (test-lists
- (lambda (lst)
- (let ((lst-copy (list-copy lst)))
- (with-test-prefix lst-copy
- (pass-if "result"
- (equal? (delete-duplicates lst)
- (ref-delete-duplicates lst)))
- (pass-if "non-destructive"
- (equal? lst-copy lst)))))))
-
- (with-test-prefix "delete-duplicates!"
- (common-tests delete-duplicates!)
-
- (test-lists
- (lambda (lst)
- (pass-if lst
- (equal? (delete-duplicates! lst)
- (ref-delete-duplicates lst)))))))
- ;;
- ;; drop
- ;;
- (with-test-prefix "drop"
-
- (pass-if "'() 0"
- (null? (drop '() 0)))
-
- (pass-if "'(a) 0"
- (let ((lst '(a)))
- (eq? lst
- (drop lst 0))))
-
- (pass-if "'(a b) 0"
- (let ((lst '(a b)))
- (eq? lst
- (drop lst 0))))
-
- (pass-if "'(a) 1"
- (let ((lst '(a)))
- (eq? (cdr lst)
- (drop lst 1))))
-
- (pass-if "'(a b) 1"
- (let ((lst '(a b)))
- (eq? (cdr lst)
- (drop lst 1))))
-
- (pass-if "'(a b) 2"
- (let ((lst '(a b)))
- (eq? (cddr lst)
- (drop lst 2))))
-
- (pass-if "'(a b c) 1"
- (let ((lst '(a b c)))
- (eq? (cddr lst)
- (drop lst 2))))
-
- (pass-if "circular '(a) 0"
- (let ((lst (circular-list 'a)))
- (eq? lst
- (drop lst 0))))
-
- (pass-if "circular '(a) 1"
- (let ((lst (circular-list 'a)))
- (eq? lst
- (drop lst 1))))
-
- (pass-if "circular '(a) 2"
- (let ((lst (circular-list 'a)))
- (eq? lst
- (drop lst 1))))
-
- (pass-if "circular '(a b) 1"
- (let ((lst (circular-list 'a)))
- (eq? (cdr lst)
- (drop lst 0))))
-
- (pass-if "circular '(a b) 2"
- (let ((lst (circular-list 'a)))
- (eq? lst
- (drop lst 1))))
-
- (pass-if "circular '(a b) 5"
- (let ((lst (circular-list 'a)))
- (eq? (cdr lst)
- (drop lst 5))))
-
- (pass-if "'(a . b) 1"
- (eq? 'b
- (drop '(a . b) 1)))
-
- (pass-if "'(a b . c) 1"
- (equal? 'c
- (drop '(a b . c) 2))))
- ;;
- ;; drop-right
- ;;
- (with-test-prefix "drop-right"
- (pass-if-exception "() -1" exception:out-of-range
- (drop-right '() -1))
- (pass-if (equal? '() (drop-right '() 0)))
- (pass-if-exception "() 1" exception:wrong-type-arg
- (drop-right '() 1))
- (pass-if-exception "(1) -1" exception:out-of-range
- (drop-right '(1) -1))
- (pass-if (equal? '(1) (drop-right '(1) 0)))
- (pass-if (equal? '() (drop-right '(1) 1)))
- (pass-if-exception "(1) 2" exception:wrong-type-arg
- (drop-right '(1) 2))
- (pass-if-exception "(4 5) -1" exception:out-of-range
- (drop-right '(4 5) -1))
- (pass-if (equal? '(4 5) (drop-right '(4 5) 0)))
- (pass-if (equal? '(4) (drop-right '(4 5) 1)))
- (pass-if (equal? '() (drop-right '(4 5) 2)))
- (pass-if-exception "(4 5) 3" exception:wrong-type-arg
- (drop-right '(4 5) 3))
- (pass-if-exception "(4 5 6) -1" exception:out-of-range
- (drop-right '(4 5 6) -1))
- (pass-if (equal? '(4 5 6) (drop-right '(4 5 6) 0)))
- (pass-if (equal? '(4 5) (drop-right '(4 5 6) 1)))
- (pass-if (equal? '(4) (drop-right '(4 5 6) 2)))
- (pass-if (equal? '() (drop-right '(4 5 6) 3)))
- (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
- (drop-right '(4 5 6) 4))
- (pass-if "(a b . c) 0"
- (equal? (drop-right '(a b . c) 0) '(a b)))
- (pass-if "(a b . c) 1"
- (equal? (drop-right '(a b . c) 1) '(a))))
- ;;
- ;; drop-right!
- ;;
- (with-test-prefix "drop-right!"
- (pass-if-exception "() -1" exception:out-of-range
- (drop-right! '() -1))
- (pass-if (equal? '() (drop-right! '() 0)))
- (pass-if-exception "() 1" exception:wrong-type-arg
- (drop-right! '() 1))
- (pass-if-exception "(1) -1" exception:out-of-range
- (drop-right! (list 1) -1))
- (pass-if (equal? '(1) (drop-right! (list 1) 0)))
- (pass-if (equal? '() (drop-right! (list 1) 1)))
- (pass-if-exception "(1) 2" exception:wrong-type-arg
- (drop-right! (list 1) 2))
- (pass-if-exception "(4 5) -1" exception:out-of-range
- (drop-right! (list 4 5) -1))
- (pass-if (equal? '(4 5) (drop-right! (list 4 5) 0)))
- (pass-if (equal? '(4) (drop-right! (list 4 5) 1)))
- (pass-if (equal? '() (drop-right! (list 4 5) 2)))
- (pass-if-exception "(4 5) 3" exception:wrong-type-arg
- (drop-right! (list 4 5) 3))
- (pass-if-exception "(4 5 6) -1" exception:out-of-range
- (drop-right! (list 4 5 6) -1))
- (pass-if (equal? '(4 5 6) (drop-right! (list 4 5 6) 0)))
- (pass-if (equal? '(4 5) (drop-right! (list 4 5 6) 1)))
- (pass-if (equal? '(4) (drop-right! (list 4 5 6) 2)))
- (pass-if (equal? '() (drop-right! (list 4 5 6) 3)))
- (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
- (drop-right! (list 4 5 6) 4)))
- ;;
- ;; drop-while
- ;;
- (with-test-prefix "drop-while"
-
- (pass-if (equal? '() (drop-while odd? '())))
- (pass-if (equal? '() (drop-while odd? '(1))))
- (pass-if (equal? '() (drop-while odd? '(1 3))))
- (pass-if (equal? '() (drop-while odd? '(1 3 5))))
- (pass-if (equal? '(2) (drop-while odd? '(2))))
- (pass-if (equal? '(2) (drop-while odd? '(1 2))))
- (pass-if (equal? '(4) (drop-while odd? '(1 3 4))))
- (pass-if (equal? '(2 1) (drop-while odd? '(2 1))))
- (pass-if (equal? '(4 3) (drop-while odd? '(1 4 3))))
- (pass-if (equal? '(4 1 3) (drop-while odd? '(4 1 3)))))
- ;;
- ;; eighth
- ;;
- (with-test-prefix "eighth"
- (pass-if-exception "() -1" exception:wrong-type-arg
- (eighth '(a b c d e f g)))
- (pass-if (eq? 'h (eighth '(a b c d e f g h))))
- (pass-if (eq? 'h (eighth '(a b c d e f g h i)))))
- ;;
- ;; fifth
- ;;
- (with-test-prefix "fifth"
- (pass-if-exception "() -1" exception:wrong-type-arg
- (fifth '(a b c d)))
- (pass-if (eq? 'e (fifth '(a b c d e))))
- (pass-if (eq? 'e (fifth '(a b c d e f)))))
- ;;
- ;; filter-map
- ;;
- (with-test-prefix "filter-map"
- (with-test-prefix "one list"
- (pass-if-exception "'x" exception:wrong-type-arg
- (filter-map noop 'x))
- (pass-if-exception "'(1 . x)" exception:wrong-type-arg
- (filter-map noop '(1 . x)))
- (pass-if "(1)"
- (equal? '(1) (filter-map noop '(1))))
- (pass-if "(#f)"
- (equal? '() (filter-map noop '(#f))))
- (pass-if "(1 2)"
- (equal? '(1 2) (filter-map noop '(1 2))))
- (pass-if "(#f 2)"
- (equal? '(2) (filter-map noop '(#f 2))))
- (pass-if "(#f #f)"
- (equal? '() (filter-map noop '(#f #f))))
- (pass-if "(1 2 3)"
- (equal? '(1 2 3) (filter-map noop '(1 2 3))))
- (pass-if "(#f 2 3)"
- (equal? '(2 3) (filter-map noop '(#f 2 3))))
- (pass-if "(1 #f 3)"
- (equal? '(1 3) (filter-map noop '(1 #f 3))))
- (pass-if "(1 2 #f)"
- (equal? '(1 2) (filter-map noop '(1 2 #f)))))
- (with-test-prefix "two lists"
- (pass-if-exception "'x '(1 2 3)" exception:wrong-type-arg
- (filter-map noop 'x '(1 2 3)))
- (pass-if-exception "'(1 2 3) 'x" exception:wrong-type-arg
- (filter-map noop '(1 2 3) 'x))
- (pass-if-exception "'(1 . x) '(1 2 3)" exception:wrong-type-arg
- (filter-map noop '(1 . x) '(1 2 3)))
- (pass-if-exception "'(1 2 3) '(1 . x)" exception:wrong-type-arg
- (filter-map noop '(1 2 3) '(1 . x)))
- (pass-if "(1 2 3) (4 5 6)"
- (equal? '(5 7 9) (filter-map + '(1 2 3) '(4 5 6))))
- (pass-if "(#f 2 3) (4 5)"
- (equal? '(2) (filter-map noop '(#f 2 3) '(4 5))))
- (pass-if "(4 #f) (1 2 3)"
- (equal? '(4) (filter-map noop '(4 #f) '(1 2 3))))
- (pass-if "() (1 2 3)"
- (equal? '() (filter-map noop '() '(1 2 3))))
- (pass-if "(1 2 3) ()"
- (equal? '() (filter-map noop '(1 2 3) '()))))
- (with-test-prefix "three lists"
- (pass-if-exception "'x '(1 2 3) '(1 2 3)" exception:wrong-type-arg
- (filter-map noop 'x '(1 2 3) '(1 2 3)))
- (pass-if-exception "'(1 2 3) 'x '(1 2 3)" exception:wrong-type-arg
- (filter-map noop '(1 2 3) 'x '(1 2 3)))
- (pass-if-exception "'(1 2 3) '(1 2 3) 'x" exception:wrong-type-arg
- (filter-map noop '(1 2 3) '(1 2 3) 'x))
- (pass-if-exception "'(1 . x) '(1 2 3) '(1 2 3)" exception:wrong-type-arg
- (filter-map noop '(1 . x) '(1 2 3) '(1 2 3)))
- (pass-if-exception "'(1 2 3) '(1 . x) '(1 2 3)" exception:wrong-type-arg
- (filter-map noop '(1 2 3) '(1 . x) '(1 2 3)))
- (pass-if-exception "'(1 2 3) '(1 2 3) '(1 . x)" exception:wrong-type-arg
- (filter-map noop '(1 2 3) '(1 2 3) '(1 . x)))
- (pass-if "(1 2 3) (4 5 6) (7 8 9)"
- (equal? '(12 15 18) (filter-map + '(1 2 3) '(4 5 6) '(7 8 9))))
- (pass-if "(#f 2 3) (4 5) (7 8 9)"
- (equal? '(2) (filter-map noop '(#f 2 3) '(4 5) '(7 8 9))))
- (pass-if "(#f 2 3) (7 8 9) (4 5)"
- (equal? '(2) (filter-map noop '(#f 2 3) '(7 8 9) '(4 5))))
- (pass-if "(4 #f) (1 2 3) (7 8 9)"
- (equal? '(4) (filter-map noop '(4 #f) '(1 2 3) '(7 8 9))))
- (pass-if "apply list unchanged"
- (let ((lst (list (list 1 #f 2) (list 3 4 5) (list 6 7 8))))
- (and (equal? '(1 2) (apply filter-map noop lst))
- ;; lst unmodified
- (equal? lst '((1 #f 2) (3 4 5) (6 7 8))))))))
-
- ;;
- ;; find
- ;;
- (with-test-prefix "find"
- (pass-if (eqv? #f (find odd? '())))
- (pass-if (eqv? #f (find odd? '(0))))
- (pass-if (eqv? #f (find odd? '(0 2))))
- (pass-if (eqv? 1 (find odd? '(1))))
- (pass-if (eqv? 1 (find odd? '(0 1))))
- (pass-if (eqv? 1 (find odd? '(0 1 2))))
- (pass-if (eqv? 1 (find odd? '(2 0 1))))
- (pass-if (eqv? 1 (find (lambda (x) (= 1 x)) '(2 0 1)))))
- ;;
- ;; find-tail
- ;;
- (with-test-prefix "find-tail"
- (pass-if (let ((lst '()))
- (eq? #f (find-tail odd? lst))))
- (pass-if (let ((lst '(0)))
- (eq? #f (find-tail odd? lst))))
- (pass-if (let ((lst '(0 2)))
- (eq? #f (find-tail odd? lst))))
- (pass-if (let ((lst '(1)))
- (eq? lst (find-tail odd? lst))))
- (pass-if (let ((lst '(1 2)))
- (eq? lst (find-tail odd? lst))))
- (pass-if (let ((lst '(2 1)))
- (eq? (cdr lst) (find-tail odd? lst))))
- (pass-if (let ((lst '(2 1 0)))
- (eq? (cdr lst) (find-tail odd? lst))))
- (pass-if (let ((lst '(2 0 1)))
- (eq? (cddr lst) (find-tail odd? lst))))
- (pass-if (let ((lst '(2 0 1)))
- (eq? (cddr lst) (find-tail (lambda (x) (= 1 x)) lst)))))
- ;;
- ;; fold
- ;;
- (with-test-prefix "fold"
- (pass-if-exception "no args" exception:wrong-num-args
- (fold))
- (pass-if-exception "one arg" exception:wrong-num-args
- (fold 123))
- (pass-if-exception "two args" exception:wrong-num-args
- (fold 123 noop))
- (with-test-prefix "one list"
- (pass-if "arg order"
- (eq? #t (fold (lambda (x prev)
- (and (= 1 x)
- (= 2 prev)))
- 2 '(1))))
- (pass-if "empty list" (= 123 (fold + 123 '())))
- (pass-if-exception "proc arg count 0" exception:wrong-num-args
- (fold (lambda () x) 123 '(1 2 3)))
- (pass-if-exception "proc arg count 1" exception:wrong-num-args
- (fold (lambda (x) x) 123 '(1 2 3)))
- (pass-if-exception "proc arg count 3" exception:wrong-num-args
- (fold (lambda (x y z) x) 123 '(1 2 3)))
- (pass-if-exception "improper 1" exception:wrong-type-arg
- (fold + 123 1))
- (pass-if-exception "improper 2" exception:wrong-type-arg
- (fold + 123 '(1 . 2)))
- (pass-if-exception "improper 3" exception:wrong-type-arg
- (fold + 123 '(1 2 . 3)))
- (pass-if (= 3 (fold + 1 '(2))))
- (pass-if (= 6 (fold + 1 '(2 3))))
- (pass-if (= 10 (fold + 1 '(2 3 4)))))
- (with-test-prefix "two lists"
- (pass-if "arg order"
- (eq? #t (fold (lambda (x y prev)
- (and (= 1 x)
- (= 2 y)
- (= 3 prev)))
- 3 '(1) '(2))))
- (pass-if "empty lists" (= 1 (fold + 1 '() '())))
- ;; currently bad proc argument gives wrong-num-args when 2 or more
- ;; lists, as opposed to wrong-type-arg for 1 list
- (pass-if-exception "proc arg count 2" exception:wrong-num-args
- (fold (lambda (x prev) x) 1 '(1 2 3) '(1 2 3)))
- (pass-if-exception "proc arg count 4" exception:wrong-num-args
- (fold (lambda (x y z prev) x) 1 '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 1" exception:wrong-type-arg
- (fold + 1 1 '(1 2 3)))
- (pass-if-exception "improper first 2" exception:wrong-type-arg
- (fold + 1 '(1 . 2) '(1 2 3)))
- (pass-if-exception "improper first 3" exception:wrong-type-arg
- (fold + 1 '(1 2 . 3) '(1 2 3)))
- (pass-if-exception "improper second 1" exception:wrong-type-arg
- (fold + 1 '(1 2 3) 1))
- (pass-if-exception "improper second 2" exception:wrong-type-arg
- (fold + 1 '(1 2 3) '(1 . 2)))
- (pass-if-exception "improper second 3" exception:wrong-type-arg
- (fold + 1 '(1 2 3) '(1 2 . 3)))
- (pass-if (= 6 (fold + 1 '(2) '(3))))
- (pass-if (= 15 (fold + 1 '(2 3) '(4 5))))
- (pass-if (= 28 (fold + 1 '(2 3 4) '(5 6 7))))
- (with-test-prefix "stop shortest"
- (pass-if (= 13 (fold + 1 '(1 2 3) '(4 5))))
- (pass-if (= 13 (fold + 1 '(4 5) '(1 2 3))))
- (pass-if (= 11 (fold + 1 '(3 4) '(1 2 9 9))))
- (pass-if (= 11 (fold + 1 '(1 2 9 9) '(3 4)))))
- (pass-if "apply list unchanged"
- (let ((lst (list (list 1 2) (list 3 4))))
- (and (equal? 11 (apply fold + 1 lst))
- ;; lst unmodified
- (equal? '((1 2) (3 4)) lst)))))
- (with-test-prefix "three lists"
- (pass-if "arg order"
- (eq? #t (fold (lambda (x y z prev)
- (and (= 1 x)
- (= 2 y)
- (= 3 z)
- (= 4 prev)))
- 4 '(1) '(2) '(3))))
- (pass-if "empty lists" (= 1 (fold + 1 '() '() '())))
- (pass-if-exception "proc arg count 3" exception:wrong-num-args
- (fold (lambda (x y prev) x) 1 '(1 2 3) '(1 2 3)'(1 2 3) ))
- (pass-if-exception "proc arg count 5" exception:wrong-num-args
- (fold (lambda (w x y z prev) x) 1 '(1 2 3) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 1" exception:wrong-type-arg
- (fold + 1 1 '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 2" exception:wrong-type-arg
- (fold + 1 '(1 . 2) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 3" exception:wrong-type-arg
- (fold + 1 '(1 2 . 3) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper second 1" exception:wrong-type-arg
- (fold + 1 '(1 2 3) 1 '(1 2 3)))
- (pass-if-exception "improper second 2" exception:wrong-type-arg
- (fold + 1 '(1 2 3) '(1 . 2) '(1 2 3)))
- (pass-if-exception "improper second 3" exception:wrong-type-arg
- (fold + 1 '(1 2 3) '(1 2 . 3) '(1 2 3)))
- (pass-if-exception "improper third 1" exception:wrong-type-arg
- (fold + 1 '(1 2 3) '(1 2 3) 1))
- (pass-if-exception "improper third 2" exception:wrong-type-arg
- (fold + 1 '(1 2 3) '(1 2 3) '(1 . 2)))
- (pass-if-exception "improper third 3" exception:wrong-type-arg
- (fold + 1 '(1 2 3) '(1 2 3) '(1 2 . 3)))
- (pass-if (= 10 (fold + 1 '(2) '(3) '(4))))
- (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7))))
- (pass-if (= 55 (fold + 1 '(2 5 8) '(3 6 9) '(4 7 10))))
- (with-test-prefix "stop shortest"
- (pass-if (= 28 (fold + 1 '(2 5 9) '(3 6) '(4 7))))
- (pass-if (= 28 (fold + 1 '(2 5) '(3 6 9) '(4 7))))
- (pass-if (= 28 (fold + 1 '(2 5) '(3 6) '(4 7 9)))))
- (pass-if "apply list unchanged"
- (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
- (and (equal? 22 (apply fold + 1 lst))
- ;; lst unmodified
- (equal? '((1 2) (3 4) (5 6)) lst))))))
- ;;
- ;; fold-right
- ;;
- (with-test-prefix "fold-right"
- (pass-if "one list"
- (equal? (iota 10)
- (fold-right cons '() (iota 10))))
- (pass-if "two lists"
- (equal? (zip (iota 10) (map integer->char (iota 10)))
- (fold-right (lambda (x y z)
- (cons (list x y) z))
- '()
- (iota 10)
- (map integer->char (iota 10)))))
- (pass-if "tail-recursive"
- (= 1e6 (fold-right (lambda (x y) (+ 1 y))
- 0
- (iota 1e6)))))
- ;;
- ;; unfold
- ;;
- (with-test-prefix "unfold"
- (pass-if "basic"
- (equal? (iota 10)
- (unfold (lambda (x) (>= x 10))
- identity
- 1+
- 0)))
- (pass-if "tail-gen"
- (equal? (append (iota 10) '(tail 10))
- (unfold (lambda (x) (>= x 10))
- identity
- 1+
- 0
- (lambda (seed) (list 'tail seed)))))
- (pass-if "tail-recursive"
- ;; Bug #30071.
- (pair? (unfold (lambda (x) (>= x 1e6))
- identity
- 1+
- 0))))
- ;;
- ;; length+
- ;;
- (with-test-prefix "length+"
- (pass-if-exception "too few args" exception:wrong-num-args
- (length+))
- (pass-if-exception "too many args" exception:wrong-num-args
- (length+ 123 456))
- (pass-if-exception "not a pair" exception:wrong-type-arg
- (length+ 'x))
- (pass-if-exception "improper list" exception:wrong-type-arg
- (length+ '(x y . z)))
- (pass-if (= 0 (length+ '())))
- (pass-if (= 1 (length+ '(x))))
- (pass-if (= 2 (length+ '(x y))))
- (pass-if (= 3 (length+ '(x y z))))
- (pass-if (not (length+ (circular-list 1))))
- (pass-if (not (length+ (circular-list 1 2))))
- (pass-if (not (length+ (circular-list 1 2 3)))))
- ;;
- ;; last
- ;;
- (with-test-prefix "last"
- (pass-if-exception "empty" exception:wrong-type-arg
- (last '()))
- (pass-if "one elem"
- (eqv? 1 (last '(1))))
- (pass-if "two elems"
- (eqv? 2 (last '(1 2))))
- (pass-if "three elems"
- (eqv? 3 (last '(1 2 3))))
- (pass-if "four elems"
- (eqv? 4 (last '(1 2 3 4)))))
- ;;
- ;; list=
- ;;
- (with-test-prefix "list="
- (pass-if "no lists"
- (eq? #t (list= eqv?)))
- (with-test-prefix "one list"
- (pass-if "empty"
- (eq? #t (list= eqv? '())))
- (pass-if "one elem"
- (eq? #t (list= eqv? '(1))))
- (pass-if "two elems"
- (eq? #t (list= eqv? '(2)))))
- (with-test-prefix "two lists"
- (pass-if "empty / empty"
- (eq? #t (list= eqv? '() '())))
- (pass-if "one / empty"
- (eq? #f (list= eqv? '(1) '())))
- (pass-if "empty / one"
- (eq? #f (list= eqv? '() '(1))))
- (pass-if "one / one same"
- (eq? #t (list= eqv? '(1) '(1))))
- (pass-if "one / one diff"
- (eq? #f (list= eqv? '(1) '(2))))
- (pass-if "called arg order"
- (let ((good #t))
- (list= (lambda (x y)
- (set! good (and good (= (1+ x) y)))
- #t)
- '(1 3) '(2 4))
- good)))
- (with-test-prefix "three lists"
- (pass-if "empty / empty / empty"
- (eq? #t (list= eqv? '() '() '())))
- (pass-if "one / empty / empty"
- (eq? #f (list= eqv? '(1) '() '())))
- (pass-if "one / one / empty"
- (eq? #f (list= eqv? '(1) '(1) '())))
- (pass-if "one / diff / empty"
- (eq? #f (list= eqv? '(1) '(2) '())))
- (pass-if "one / one / one"
- (eq? #t (list= eqv? '(1) '(1) '(1))))
- (pass-if "two / two / diff"
- (eq? #f (list= eqv? '(1 2) '(1 2) '(1 99))))
- (pass-if "two / two / two"
- (eq? #t (list= eqv? '(1 2) '(1 2) '(1 2))))
- (pass-if "called arg order"
- (let ((good #t))
- (list= (lambda (x y)
- (set! good (and good (= (1+ x) y)))
- #t)
- '(1 4) '(2 5) '(3 6))
- good))))
- ;;
- ;; list-copy
- ;;
- (with-test-prefix "list-copy"
- (pass-if (equal? '() (list-copy '())))
- (pass-if (equal? '(1 2) (list-copy '(1 2))))
- (pass-if (equal? '(1 2 3) (list-copy '(1 2 3))))
- (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4))))
- (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5))))
-
- ;; improper lists can be copied
- (pass-if (equal? 1 (list-copy 1)))
- (pass-if (equal? '(1 . 2) (list-copy '(1 . 2))))
- (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3))))
- (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4))))
- (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5)))))
- ;;
- ;; list-index
- ;;
- (with-test-prefix "list-index"
- (pass-if-exception "no args" exception:wrong-num-args
- (list-index))
- (pass-if-exception "one arg" exception:wrong-num-args
- (list-index noop))
- (with-test-prefix "one list"
- (pass-if "empty list" (eq? #f (list-index symbol? '())))
- (pass-if-exception "pred arg count 0" exception:wrong-num-args
- (list-index (lambda () x) '(1 2 3)))
- (pass-if-exception "pred arg count 2" exception:wrong-num-args
- (list-index (lambda (x y) x) '(1 2 3)))
- (pass-if-exception "improper 1" exception:wrong-type-arg
- (list-index symbol? 1))
- (pass-if-exception "improper 2" exception:wrong-type-arg
- (list-index symbol? '(1 . 2)))
- (pass-if-exception "improper 3" exception:wrong-type-arg
- (list-index symbol? '(1 2 . 3)))
- (pass-if (eqv? #f (list-index symbol? '(1))))
- (pass-if (eqv? 0 (list-index symbol? '(x))))
- (pass-if (eqv? #f (list-index symbol? '(1 2))))
- (pass-if (eqv? 0 (list-index symbol? '(x 1))))
- (pass-if (eqv? 1 (list-index symbol? '(1 x))))
- (pass-if (eqv? #f (list-index symbol? '(1 2 3))))
- (pass-if (eqv? 0 (list-index symbol? '(x 1 2))))
- (pass-if (eqv? 1 (list-index symbol? '(1 x 2))))
- (pass-if (eqv? 2 (list-index symbol? '(1 2 x)))))
- (with-test-prefix "two lists"
- (define (sym1 x y)
- (symbol? x))
- (define (sym2 x y)
- (symbol? y))
- (pass-if "arg order"
- (eqv? 0 (list-index (lambda (x y)
- (and (= 1 x)
- (= 2 y)))
- '(1) '(2))))
- (pass-if "empty lists" (eqv? #f (list-index sym2 '() '())))
- (pass-if-exception "pred arg count 0" exception:wrong-num-args
- (list-index (lambda () #t) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 1" exception:wrong-num-args
- (list-index (lambda (x) x) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 3" exception:wrong-num-args
- (list-index (lambda (x y z) x) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 1" exception:wrong-type-arg
- (list-index sym2 1 '(1 2 3)))
- (pass-if-exception "improper first 2" exception:wrong-type-arg
- (list-index sym2 '(1 . 2) '(1 2 3)))
- (pass-if-exception "improper first 3" exception:wrong-type-arg
- (list-index sym2 '(1 2 . 3) '(1 2 3)))
- (pass-if-exception "improper second 1" exception:wrong-type-arg
- (list-index sym2 '(1 2 3) 1))
- (pass-if-exception "improper second 2" exception:wrong-type-arg
- (list-index sym2 '(1 2 3) '(1 . 2)))
- (pass-if-exception "improper second 3" exception:wrong-type-arg
- (list-index sym2 '(1 2 3) '(1 2 . 3)))
- (pass-if (eqv? #f (list-index sym2 '(1) '(2))))
- (pass-if (eqv? 0 (list-index sym2 '(1) '(x))))
- (pass-if (eqv? #f (list-index sym2 '(1 2) '(3 4))))
- (pass-if (eqv? 0 (list-index sym2 '(1 2) '(x 3))))
- (pass-if (eqv? 1 (list-index sym2 '(1 2) '(3 x))))
- (pass-if (eqv? #f (list-index sym2 '(1 2 3) '(3 4 5))))
- (pass-if (eqv? 0 (list-index sym2 '(1 2 3) '(x 3 4))))
- (pass-if (eqv? 1 (list-index sym2 '(1 2 3) '(3 x 4))))
- (pass-if (eqv? 2 (list-index sym2 '(1 2 3) '(3 4 x))))
- (with-test-prefix "stop shortest"
- (pass-if (eqv? #f (list-index sym1 '(1 2 x) '(4 5))))
- (pass-if (eqv? #f (list-index sym2 '(4 5) '(1 2 x))))
- (pass-if (eqv? #f (list-index sym1 '(3 4) '(1 2 x y))))
- (pass-if (eqv? #f (list-index sym2 '(1 2 x y) '(3 4))))))
- (with-test-prefix "three lists"
- (define (sym1 x y z)
- (symbol? x))
- (define (sym2 x y z)
- (symbol? y))
- (define (sym3 x y z)
- (symbol? z))
- (pass-if "arg order"
- (eqv? 0 (list-index (lambda (x y z)
- (and (= 1 x)
- (= 2 y)
- (= 3 z)))
- '(1) '(2) '(3))))
- (pass-if "empty lists" (eqv? #f (list-index sym3 '() '() '())))
- ;; currently bad pred argument gives wrong-num-args when 3 or more
- ;; lists, as opposed to wrong-type-arg for 1 or 2 lists
- (pass-if-exception "pred arg count 0" exception:wrong-num-args
- (list-index (lambda () #t) '(1 2 3) '(1 2 3) '(1 2 3)))
- (pass-if-exception "pred arg count 2" exception:wrong-num-args
- (list-index (lambda (x y) x) '(1 2 3) '(1 2 3)'(1 2 3) ))
- (pass-if-exception "pred arg count 4" exception:wrong-num-args
- (list-index (lambda (w x y z) x) '(1 2 3) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 1" exception:wrong-type-arg
- (list-index sym3 1 '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 2" exception:wrong-type-arg
- (list-index sym3 '(1 . 2) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper first 3" exception:wrong-type-arg
- (list-index sym3 '(1 2 . 3) '(1 2 3) '(1 2 3)))
- (pass-if-exception "improper second 1" exception:wrong-type-arg
- (list-index sym3 '(1 2 3) 1 '(1 2 3)))
- (pass-if-exception "improper second 2" exception:wrong-type-arg
- (list-index sym3 '(1 2 3) '(1 . 2) '(1 2 3)))
- (pass-if-exception "improper second 3" exception:wrong-type-arg
- (list-index sym3 '(1 2 3) '(1 2 . 3) '(1 2 3)))
- (pass-if-exception "improper third 1" exception:wrong-type-arg
- (list-index sym3 '(1 2 3) '(1 2 3) 1))
- (pass-if-exception "improper third 2" exception:wrong-type-arg
- (list-index sym3 '(1 2 3) '(1 2 3) '(1 . 2)))
- (pass-if-exception "improper third 3" exception:wrong-type-arg
- (list-index sym3 '(1 2 3) '(1 2 3) '(1 2 . 3)))
- (pass-if (eqv? #f (list-index sym3 '(#f) '(#f) '(#f))))
- (pass-if (eqv? 0 (list-index sym3 '(#f) '(#f) '(x))))
- (pass-if (eqv? #f (list-index sym3 '(#f #f) '(#f #f) '(#f #f))))
- (pass-if (eqv? 0 (list-index sym3 '(#f #f) '(#f #f) '(x #f))))
- (pass-if (eqv? 1 (list-index sym3 '(#f #f) '(#f #f) '(#f x))))
- (pass-if (eqv? #f (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f #f))))
- (pass-if (eqv? 0 (list-index sym3 '(#f #f #f) '(#f #f #f) '(x #f #f))))
- (pass-if (eqv? 1 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f x #f))))
- (pass-if (eqv? 2 (list-index sym3 '(#f #f #f) '(#f #f #f) '(#f #f x))))
- (with-test-prefix "stop shortest"
- (pass-if (eqv? #f (list-index sym2 '() '(x x x) '(x x))))
- (pass-if (eqv? #f (list-index sym1 '(x x x) '() '(x x))))
- (pass-if (eqv? #f (list-index sym2 '(x x x) '(x x) '())))
- (pass-if (eqv? #f (list-index sym2 '(#t) '(#t x x) '(#t x))))
- (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t) '(#t x))))
- (pass-if (eqv? #f (list-index sym1 '(#t x x) '(#t x) '(#t)))))
- (pass-if "apply list unchanged"
- (let ((lst (list (list 1 2) (list 3 4) (list 5 6))))
- (and (equal? #f (apply list-index sym3 lst))
- ;; lst unmodified
- (equal? '((1 2) (3 4) (5 6)) lst))))))
- ;;
- ;; list-tabulate
- ;;
- (with-test-prefix "list-tabulate"
- (pass-if-exception "-1" exception:wrong-type-arg
- (list-tabulate -1 identity))
- (pass-if "0"
- (equal? '() (list-tabulate 0 identity)))
- (pass-if "1"
- (equal? '(0) (list-tabulate 1 identity)))
- (pass-if "2"
- (equal? '(0 1) (list-tabulate 2 identity)))
- (pass-if "3"
- (equal? '(0 1 2) (list-tabulate 3 identity)))
- (pass-if "4"
- (equal? '(0 1 2 3) (list-tabulate 4 identity)))
- (pass-if "string ref proc"
- (equal? '(#\a #\b #\c #\d) (list-tabulate 4
- (lambda (i)
- (string-ref "abcd" i))))))
- ;;
- ;; lset=
- ;;
- (with-test-prefix "lset="
- ;; in guile 1.6.7 and earlier, lset= incorrectly demanded at least one
- ;; list arg
- (pass-if "no args"
- (eq? #t (lset= eq?)))
- (with-test-prefix "one arg"
- (pass-if "()"
- (eq? #t (lset= eqv? '())))
- (pass-if "(1)"
- (eq? #t (lset= eqv? '(1))))
- (pass-if "(1 2)"
- (eq? #t (lset= eqv? '(1 2)))))
- (with-test-prefix "two args"
- (pass-if "() ()"
- (eq? #t (lset= eqv? '() '())))
- (pass-if "(1) (1)"
- (eq? #t (lset= eqv? '(1) '(1))))
- (pass-if "(1) (2)"
- (eq? #f (lset= eqv? '(1) '(2))))
- (pass-if "(1) (1 2)"
- (eq? #f (lset= eqv? '(1) '(1 2))))
- (pass-if "(1 2) (2 1)"
- (eq? #t (lset= eqv? '(1 2) '(2 1))))
- (pass-if "called arg order"
- (let ((good #t))
- (lset= (lambda (x y)
- (if (not (= x (1- y)))
- (set! good #f))
- #t)
- '(1 1) '(2 2))
- good)))
- (with-test-prefix "three args"
- (pass-if "() () ()"
- (eq? #t (lset= eqv? '() '() '())))
- (pass-if "(1) (1) (1)"
- (eq? #t (lset= eqv? '(1) '(1) '(1))))
- (pass-if "(1) (1) (2)"
- (eq? #f (lset= eqv? '(1) '(1) '(2))))
- (pass-if "(1) (1) (1 2)"
- (eq? #f (lset= eqv? '(1) '(1) '(1 2))))
- (pass-if "(1 2 3) (3 2 1) (1 3 2)"
- (eq? #t (lset= eqv? '(1 2 3) '(3 2 1) '(1 3 2))))
- (pass-if "called arg order"
- (let ((good #t))
- (lset= (lambda (x y)
- (if (not (= x (1- y)))
- (set! good #f))
- #t)
- '(1 1) '(2 2) '(3 3))
- good))))
- ;;
- ;; lset-adjoin
- ;;
- (with-test-prefix "lset-adjoin"
- ;; in guile 1.6.7 and earlier, lset-adjoin didn't actually use the given
- ;; `=' procedure, all comparisons were just with `equal?
- ;;
- (with-test-prefix "case-insensitive ="
- (pass-if "(\"x\") \"X\""
- (equal? '("x") (lset-adjoin string-ci=? '("x") "X"))))
- (pass-if "called arg order"
- (let ((good #f))
- (lset-adjoin (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- '(1) 2)
- good))
- (pass-if (equal? '() (lset-adjoin = '())))
- (pass-if (equal? '(1) (lset-adjoin = '() 1)))
- (pass-if (equal? '(1) (lset-adjoin = '() 1 1)))
- (pass-if (equal? '(2 1) (lset-adjoin = '() 1 2)))
- (pass-if (equal? '(3 1 2) (lset-adjoin = '(1 2) 1 2 3 2 1)))
- (pass-if "apply list unchanged"
- (let ((lst (list 1 2)))
- (and (equal? '(2 1 3) (apply lset-adjoin = '(3) lst))
- ;; lst unmodified
- (equal? '(1 2) lst))))
- (pass-if "(1 1) 1 1"
- (equal? '(1 1) (lset-adjoin = '(1 1) 1 1)))
- ;; duplicates among args are cast out
- (pass-if "(2) 1 1"
- (equal? '(1 2) (lset-adjoin = '(2) 1 1))))
- ;;
- ;; lset-difference
- ;;
- (with-test-prefix "lset-difference"
- (pass-if "called arg order"
- (let ((good #f))
- (lset-difference (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- '(1) '(2))
- good)))
- ;;
- ;; lset-difference!
- ;;
- (with-test-prefix "lset-difference!"
- (pass-if-exception "proc - num" exception:wrong-type-arg
- (lset-difference! 123 '(4)))
- (pass-if-exception "proc - list" exception:wrong-type-arg
- (lset-difference! (list 1 2 3) '(4)))
- (pass-if "called arg order"
- (let ((good #f))
- (lset-difference! (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- (list 1) (list 2))
- good))
- (pass-if (equal? '() (lset-difference! = '())))
- (pass-if (equal? '(1) (lset-difference! = (list 1))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
- (pass-if (equal? '() (lset-difference! = (list ) '(3))))
- (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
- (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
- (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
- (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
- (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
- (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
- (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
- ;;
- ;; lset-diff+intersection
- ;;
- (with-test-prefix "lset-diff+intersection"
- (pass-if "called arg order"
- (let ((good #f))
- (lset-diff+intersection (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- '(1) '(2))
- good)))
- ;;
- ;; lset-diff+intersection!
- ;;
- (with-test-prefix "lset-diff+intersection"
- (pass-if "called arg order"
- (let ((good #f))
- (lset-diff+intersection (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- (list 1) (list 2))
- good)))
- ;;
- ;; lset-intersection
- ;;
- (with-test-prefix "lset-intersection"
- (pass-if "called arg order"
- (let ((good #f))
- (lset-intersection (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- '(1) '(2))
- good)))
- ;;
- ;; lset-intersection!
- ;;
- (with-test-prefix "lset-intersection"
- (pass-if "called arg order"
- (let ((good #f))
- (lset-intersection (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- (list 1) (list 2))
- good)))
- ;;
- ;; lset-union
- ;;
- (with-test-prefix "lset-union"
- (pass-if "no args"
- (eq? '() (lset-union eq?)))
- (pass-if "one arg"
- (equal? '(1 2 3) (lset-union eq? '(1 2 3))))
- (pass-if "'() '()"
- (equal? '() (lset-union eq? '() '())))
- (pass-if "'() '(1 2 3)"
- (equal? '(1 2 3) (lset-union eq? '() '(1 2 3))))
- (pass-if "'(1 2 3) '()"
- (equal? '(1 2 3) (lset-union eq? '(1 2 3) '())))
- (pass-if "'(1 2 3) '(4 3 5)"
- (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4 3 5))))
- (pass-if "'(1 2 3) '(4) '(3 5))"
- (equal? '(5 4 1 2 3) (lset-union eq? '(1 2 3) '(4) '(3 5))))
- ;; in guile 1.6.7 and earlier, `=' was called with the arguments the wrong
- ;; way around
- (pass-if "called arg order"
- (let ((good #f))
- (lset-union (lambda (x y)
- (set! good (and (= x 1) (= y 2)))
- (= x y))
- '(1) '(2))
- good)))
- ;;
- ;; member
- ;;
- (with-test-prefix "member"
- (pass-if-exception "no args" exception:wrong-num-args
- (member))
- (pass-if-exception "one arg" exception:wrong-num-args
- (member 1))
- (pass-if "1 (1 2 3)"
- (let ((lst '(1 2 3)))
- (eq? lst (member 1 lst))))
- (pass-if "2 (1 2 3)"
- (let ((lst '(1 2 3)))
- (eq? (cdr lst) (member 2 lst))))
- (pass-if "3 (1 2 3)"
- (let ((lst '(1 2 3)))
- (eq? (cddr lst) (member 3 lst))))
- (pass-if "4 (1 2 3)"
- (let ((lst '(1 2 3)))
- (eq? #f (member 4 lst))))
- (pass-if "called arg order"
- (let ((good #f))
- (member 1 '(2) (lambda (x y)
- (set! good (and (eqv? 1 x)
- (eqv? 2 y)))))
- good)))
- ;;
- ;; ninth
- ;;
- (with-test-prefix "ninth"
- (pass-if-exception "() -1" exception:wrong-type-arg
- (ninth '(a b c d e f g h)))
- (pass-if (eq? 'i (ninth '(a b c d e f g h i))))
- (pass-if (eq? 'i (ninth '(a b c d e f g h i j)))))
- ;;
- ;; not-pair?
- ;;
- (with-test-prefix "not-pair?"
- (pass-if "inum"
- (eq? #t (not-pair? 123)))
- (pass-if "pair"
- (eq? #f (not-pair? '(x . y))))
- (pass-if "symbol"
- (eq? #t (not-pair? 'x))))
- ;;
- ;; take
- ;;
- (with-test-prefix "take"
-
- (pass-if "'() 0"
- (null? (take '() 0)))
-
- (pass-if "'(a) 0"
- (null? (take '(a) 0)))
-
- (pass-if "'(a b) 0"
- (null? (take '() 0)))
-
- (pass-if "'(a b c) 0"
- (null? (take '() 0)))
-
- (pass-if "'(a) 1"
- (let* ((lst '(a))
- (got (take lst 1)))
- (and (equal? '(a) got)
- (not (eq? lst got)))))
-
- (pass-if "'(a b) 1"
- (equal? '(a)
- (take '(a b) 1)))
-
- (pass-if "'(a b c) 1"
- (equal? '(a)
- (take '(a b c) 1)))
-
- (pass-if "'(a b) 2"
- (let* ((lst '(a b))
- (got (take lst 2)))
- (and (equal? '(a b) got)
- (not (eq? lst got)))))
-
- (pass-if "'(a b c) 2"
- (equal? '(a b)
- (take '(a b c) 2)))
-
- (pass-if "circular '(a) 0"
- (equal? '()
- (take (circular-list 'a) 0)))
-
- (pass-if "circular '(a) 1"
- (equal? '(a)
- (take (circular-list 'a) 1)))
-
- (pass-if "circular '(a) 2"
- (equal? '(a a)
- (take (circular-list 'a) 2)))
-
- (pass-if "circular '(a b) 5"
- (equal? '(a b a b a)
- (take (circular-list 'a 'b) 5)))
-
- (pass-if "'(a . b) 1"
- (equal? '(a)
- (take '(a . b) 1)))
-
- (pass-if "'(a b . c) 1"
- (equal? '(a)
- (take '(a b . c) 1)))
-
- (pass-if "'(a b . c) 2"
- (equal? '(a b)
- (take '(a b . c) 2))))
- ;;
- ;; take-while
- ;;
- (with-test-prefix "take-while"
-
- (pass-if (equal? '() (take-while odd? '())))
- (pass-if (equal? '(1) (take-while odd? '(1))))
- (pass-if (equal? '(1 3) (take-while odd? '(1 3))))
- (pass-if (equal? '(1 3 5) (take-while odd? '(1 3 5))))
- (pass-if (equal? '() (take-while odd? '(2))))
- (pass-if (equal? '(1) (take-while odd? '(1 2))))
- (pass-if (equal? '(1 3) (take-while odd? '(1 3 4))))
- (pass-if (equal? '() (take-while odd? '(2 1))))
- (pass-if (equal? '(1) (take-while odd? '(1 4 3))))
- (pass-if (equal? '() (take-while odd? '(4 1 3)))))
- ;;
- ;; take-while!
- ;;
- (with-test-prefix "take-while!"
-
- (pass-if (equal? '() (take-while! odd? '())))
- (pass-if (equal? '(1) (take-while! odd? (list 1))))
- (pass-if (equal? '(1 3) (take-while! odd? (list 1 3))))
- (pass-if (equal? '(1 3 5) (take-while! odd? (list 1 3 5))))
- (pass-if (equal? '() (take-while! odd? (list 2))))
- (pass-if (equal? '(1) (take-while! odd? (list 1 2))))
- (pass-if (equal? '(1 3) (take-while! odd? (list 1 3 4))))
- (pass-if (equal? '() (take-while! odd? (list 2 1))))
- (pass-if (equal? '(1) (take-while! odd? (list 1 4 3))))
- (pass-if (equal? '() (take-while! odd? (list 4 1 3)))))
- ;;
- ;; partition
- ;;
- (define (test-partition pred list kept-good dropped-good)
- (call-with-values (lambda ()
- (partition pred list))
- (lambda (kept dropped)
- (and (equal? kept kept-good)
- (equal? dropped dropped-good)))))
- (with-test-prefix "partition"
-
- (pass-if "with dropped tail"
- (test-partition even? '(1 2 3 4 5 6 7)
- '(2 4 6) '(1 3 5 7)))
- (pass-if "with kept tail"
- (test-partition even? '(1 2 3 4 5 6)
- '(2 4 6) '(1 3 5)))
- (pass-if "with everything dropped"
- (test-partition even? '(1 3 5 7)
- '() '(1 3 5 7)))
- (pass-if "with everything kept"
- (test-partition even? '(2 4 6)
- '(2 4 6) '()))
- (pass-if "with empty list"
- (test-partition even? '()
- '() '()))
- (pass-if "with reasonably long list"
- ;; the old implementation from SRFI-1 reference implementation
- ;; would signal a stack-overflow for a list of only 500 elements!
- (call-with-values (lambda ()
- (partition even?
- (make-list 10000 1)))
- (lambda (even odd)
- (and (= (length odd) 10000)
- (= (length even) 0)))))
- (pass-if-exception "with improper list"
- exception:wrong-type-arg
- (partition symbol? '(a b . c))))
- ;;
- ;; partition!
- ;;
- (define (test-partition! pred list kept-good dropped-good)
- (call-with-values (lambda ()
- (partition! pred list))
- (lambda (kept dropped)
- (and (equal? kept kept-good)
- (equal? dropped dropped-good)))))
- (with-test-prefix "partition!"
- (pass-if "with dropped tail"
- (test-partition! even? (list 1 2 3 4 5 6 7)
- '(2 4 6) '(1 3 5 7)))
- (pass-if "with kept tail"
- (test-partition! even? (list 1 2 3 4 5 6)
- '(2 4 6) '(1 3 5)))
- (pass-if "with everything dropped"
- (test-partition! even? (list 1 3 5 7)
- '() '(1 3 5 7)))
- (pass-if "with everything kept"
- (test-partition! even? (list 2 4 6)
- '(2 4 6) '()))
- (pass-if "with empty list"
- (test-partition! even? '()
- '() '()))
- (pass-if "with reasonably long list"
- ;; the old implementation from SRFI-1 reference implementation
- ;; would signal a stack-overflow for a list of only 500 elements!
- (call-with-values (lambda ()
- (partition! even?
- (make-list 10000 1)))
- (lambda (even odd)
- (and (= (length odd) 10000)
- (= (length even) 0)))))
- (pass-if-exception "with improper list"
- exception:wrong-type-arg
- (partition! symbol? (cons* 'a 'b 'c))))
- ;;
- ;; reduce
- ;;
- (with-test-prefix "reduce"
- (pass-if "empty"
- (let* ((calls '())
- (ret (reduce (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '())))
- (and (equal? calls '())
- (equal? ret 1))))
- (pass-if "one elem"
- (let* ((calls '())
- (ret (reduce (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '(2))))
- (and (equal? calls '())
- (equal? ret 2))))
- (pass-if "two elems"
- (let* ((calls '())
- (ret (reduce (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '(2 3))))
- (and (equal? calls '((3 2)))
- (equal? ret 3))))
- (pass-if "three elems"
- (let* ((calls '())
- (ret (reduce (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '(2 3 4))))
- (and (equal? calls '((4 3)
- (3 2)))
- (equal? ret 4))))
- (pass-if "four elems"
- (let* ((calls '())
- (ret (reduce (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '(2 3 4 5))))
- (and (equal? calls '((5 4)
- (4 3)
- (3 2)))
- (equal? ret 5)))))
- ;;
- ;; reduce-right
- ;;
- (with-test-prefix "reduce-right"
- (pass-if "empty"
- (let* ((calls '())
- (ret (reduce-right (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '())))
- (and (equal? calls '())
- (equal? ret 1))))
- (pass-if "one elem"
- (let* ((calls '())
- (ret (reduce-right (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '(2))))
- (and (equal? calls '())
- (equal? ret 2))))
- (pass-if "two elems"
- (let* ((calls '())
- (ret (reduce-right (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '(2 3))))
- (and (equal? calls '((2 3)))
- (equal? ret 2))))
- (pass-if "three elems"
- (let* ((calls '())
- (ret (reduce-right (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '(2 3 4))))
- (and (equal? calls '((2 3)
- (3 4)))
- (equal? ret 2))))
- (pass-if "four elems"
- (let* ((calls '())
- (ret (reduce-right (lambda (x prev)
- (set! calls (cons (list x prev) calls))
- x)
- 1 '(2 3 4 5))))
- (and (equal? calls '((2 3)
- (3 4)
- (4 5)))
- (equal? ret 2)))))
-
- ;;
- ;; remove
- ;;
- (with-test-prefix "remove"
- (pass-if (equal? '() (remove odd? '())))
- (pass-if (equal? '() (remove odd? '(1))))
- (pass-if (equal? '(2) (remove odd? '(2))))
- (pass-if (equal? '() (remove odd? '(1 3))))
- (pass-if (equal? '(2) (remove odd? '(2 3))))
- (pass-if (equal? '(2) (remove odd? '(1 2))))
- (pass-if (equal? '(2 4) (remove odd? '(2 4))))
- (pass-if (equal? '() (remove odd? '(1 3 5))))
- (pass-if (equal? '(2) (remove odd? '(2 3 5))))
- (pass-if (equal? '(2) (remove odd? '(1 2 5))))
- (pass-if (equal? '(2 4) (remove odd? '(2 4 5))))
- (pass-if (equal? '(6) (remove odd? '(1 3 6))))
- (pass-if (equal? '(2 6) (remove odd? '(2 3 6))))
- (pass-if (equal? '(2 6) (remove odd? '(1 2 6))))
- (pass-if (equal? '(2 4 6) (remove odd? '(2 4 6)))))
- ;;
- ;; remove!
- ;;
- (with-test-prefix "remove!"
- (pass-if (equal? '() (remove! odd? '())))
- (pass-if (equal? '() (remove! odd? (list 1))))
- (pass-if (equal? '(2) (remove! odd? (list 2))))
- (pass-if (equal? '() (remove! odd? (list 1 3))))
- (pass-if (equal? '(2) (remove! odd? (list 2 3))))
- (pass-if (equal? '(2) (remove! odd? (list 1 2))))
- (pass-if (equal? '(2 4) (remove! odd? (list 2 4))))
- (pass-if (equal? '() (remove! odd? (list 1 3 5))))
- (pass-if (equal? '(2) (remove! odd? (list 2 3 5))))
- (pass-if (equal? '(2) (remove! odd? (list 1 2 5))))
- (pass-if (equal? '(2 4) (remove! odd? (list 2 4 5))))
- (pass-if (equal? '(6) (remove! odd? (list 1 3 6))))
- (pass-if (equal? '(2 6) (remove! odd? (list 2 3 6))))
- (pass-if (equal? '(2 6) (remove! odd? (list 1 2 6))))
- (pass-if (equal? '(2 4 6) (remove! odd? (list 2 4 6)))))
- ;;
- ;; seventh
- ;;
- (with-test-prefix "seventh"
- (pass-if-exception "() -1" exception:wrong-type-arg
- (seventh '(a b c d e f)))
- (pass-if (eq? 'g (seventh '(a b c d e f g))))
- (pass-if (eq? 'g (seventh '(a b c d e f g h)))))
- ;;
- ;; sixth
- ;;
- (with-test-prefix "sixth"
- (pass-if-exception "() -1" exception:wrong-type-arg
- (sixth '(a b c d e)))
- (pass-if (eq? 'f (sixth '(a b c d e f))))
- (pass-if (eq? 'f (sixth '(a b c d e f g)))))
- ;;
- ;; split-at
- ;;
- (with-test-prefix "split-at"
- (define (equal-values? lst thunk)
- (call-with-values thunk
- (lambda got
- (equal? lst got))))
- (pass-if-exception "() -1" exception:out-of-range
- (split-at '() -1))
- (pass-if (equal-values? '(() ())
- (lambda () (split-at '() 0))))
- (pass-if-exception "() 1" exception:wrong-type-arg
- (split-at '() 1))
- (pass-if-exception "(1) -1" exception:out-of-range
- (split-at '(1) -1))
- (pass-if (equal-values? '(() (1)) (lambda () (split-at '(1) 0))))
- (pass-if (equal-values? '((1) ()) (lambda () (split-at '(1) 1))))
- (pass-if-exception "(1) 2" exception:wrong-type-arg
- (split-at '(1) 2))
- (pass-if-exception "(4 5) -1" exception:out-of-range
- (split-at '(4 5) -1))
- (pass-if (equal-values? '(() (4 5)) (lambda () (split-at '(4 5) 0))))
- (pass-if (equal-values? '((4) (5)) (lambda () (split-at '(4 5) 1))))
- (pass-if (equal-values? '((4 5) ()) (lambda () (split-at '(4 5) 2))))
- (pass-if-exception "(4 5) 3" exception:wrong-type-arg
- (split-at '(4 5) 3))
- (pass-if-exception "(4 5 6) -1" exception:out-of-range
- (split-at '(4 5 6) -1))
- (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at '(4 5 6) 0))))
- (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at '(4 5 6) 1))))
- (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at '(4 5 6) 2))))
- (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at '(4 5 6) 3))))
- (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
- (split-at '(4 5 6) 4)))
- ;;
- ;; split-at!
- ;;
- (with-test-prefix "split-at!"
- (define (equal-values? lst thunk)
- (call-with-values thunk
- (lambda got
- (equal? lst got))))
- (pass-if-exception "() -1" exception:out-of-range
- (split-at! '() -1))
- (pass-if (equal-values? '(() ())
- (lambda () (split-at! '() 0))))
- (pass-if-exception "() 1" exception:wrong-type-arg
- (split-at! '() 1))
- (pass-if-exception "(1) -1" exception:out-of-range
- (split-at! (list 1) -1))
- (pass-if (equal-values? '(() (1)) (lambda () (split-at! (list 1) 0))))
- (pass-if (equal-values? '((1) ()) (lambda () (split-at! (list 1) 1))))
- (pass-if-exception "(1) 2" exception:wrong-type-arg
- (split-at! (list 1) 2))
- (pass-if-exception "(4 5) -1" exception:out-of-range
- (split-at! (list 4 5) -1))
- (pass-if (equal-values? '(() (4 5)) (lambda () (split-at! (list 4 5) 0))))
- (pass-if (equal-values? '((4) (5)) (lambda () (split-at! (list 4 5) 1))))
- (pass-if (equal-values? '((4 5) ()) (lambda () (split-at! (list 4 5) 2))))
- (pass-if-exception "(4 5) 3" exception:wrong-type-arg
- (split-at! (list 4 5) 3))
- (pass-if-exception "(4 5 6) -1" exception:out-of-range
- (split-at! (list 4 5 6) -1))
- (pass-if (equal-values? '(() (4 5 6)) (lambda () (split-at! (list 4 5 6) 0))))
- (pass-if (equal-values? '((4) (5 6)) (lambda () (split-at! (list 4 5 6) 1))))
- (pass-if (equal-values? '((4 5) (6)) (lambda () (split-at! (list 4 5 6) 2))))
- (pass-if (equal-values? '((4 5 6) ()) (lambda () (split-at! (list 4 5 6) 3))))
- (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
- (split-at! (list 4 5 6) 4)))
- ;;
- ;; span
- ;;
- (with-test-prefix "span"
- (define (test-span lst want-v1 want-v2)
- (call-with-values
- (lambda ()
- (span positive? lst))
- (lambda (got-v1 got-v2)
- (and (equal? got-v1 want-v1)
- (equal? got-v2 want-v2)))))
- (pass-if "empty"
- (test-span '() '() '()))
- (pass-if "y"
- (test-span '(1) '(1) '()))
- (pass-if "n"
- (test-span '(-1) '() '(-1)))
- (pass-if "yy"
- (test-span '(1 2) '(1 2) '()))
- (pass-if "ny"
- (test-span '(-1 1) '() '(-1 1)))
- (pass-if "yn"
- (test-span '(1 -1) '(1) '(-1)))
- (pass-if "nn"
- (test-span '(-1 -2) '() '(-1 -2)))
- (pass-if "yyy"
- (test-span '(1 2 3) '(1 2 3) '()))
- (pass-if "nyy"
- (test-span '(-1 1 2) '() '(-1 1 2)))
- (pass-if "yny"
- (test-span '(1 -1 2) '(1) '(-1 2)))
- (pass-if "nny"
- (test-span '(-1 -2 1) '() '(-1 -2 1)))
- (pass-if "yyn"
- (test-span '(1 2 -1) '(1 2) '(-1)))
- (pass-if "nyn"
- (test-span '(-1 1 -2) '() '(-1 1 -2)))
- (pass-if "ynn"
- (test-span '(1 -1 -2) '(1) '(-1 -2)))
- (pass-if "nnn"
- (test-span '(-1 -2 -3) '() '(-1 -2 -3))))
- ;;
- ;; span!
- ;;
- (with-test-prefix "span!"
- (define (test-span! lst want-v1 want-v2)
- (call-with-values
- (lambda ()
- (span! positive? lst))
- (lambda (got-v1 got-v2)
- (and (equal? got-v1 want-v1)
- (equal? got-v2 want-v2)))))
- (pass-if "empty"
- (test-span! '() '() '()))
- (pass-if "y"
- (test-span! (list 1) '(1) '()))
- (pass-if "n"
- (test-span! (list -1) '() '(-1)))
- (pass-if "yy"
- (test-span! (list 1 2) '(1 2) '()))
- (pass-if "ny"
- (test-span! (list -1 1) '() '(-1 1)))
- (pass-if "yn"
- (test-span! (list 1 -1) '(1) '(-1)))
- (pass-if "nn"
- (test-span! (list -1 -2) '() '(-1 -2)))
- (pass-if "yyy"
- (test-span! (list 1 2 3) '(1 2 3) '()))
- (pass-if "nyy"
- (test-span! (list -1 1 2) '() '(-1 1 2)))
- (pass-if "yny"
- (test-span! (list 1 -1 2) '(1) '(-1 2)))
- (pass-if "nny"
- (test-span! (list -1 -2 1) '() '(-1 -2 1)))
- (pass-if "yyn"
- (test-span! (list 1 2 -1) '(1 2) '(-1)))
- (pass-if "nyn"
- (test-span! (list -1 1 -2) '() '(-1 1 -2)))
- (pass-if "ynn"
- (test-span! (list 1 -1 -2) '(1) '(-1 -2)))
- (pass-if "nnn"
- (test-span! (list -1 -2 -3) '() '(-1 -2 -3))))
- ;;
- ;; take!
- ;;
- (with-test-prefix "take!"
- (pass-if-exception "() -1" exception:out-of-range
- (take! '() -1))
- (pass-if (equal? '() (take! '() 0)))
- (pass-if-exception "() 1" exception:wrong-type-arg
- (take! '() 1))
- (pass-if-exception "(1) -1" exception:out-of-range
- (take! '(1) -1))
- (pass-if (equal? '() (take! '(1) 0)))
- (pass-if (equal? '(1) (take! '(1) 1)))
- (pass-if-exception "(1) 2" exception:wrong-type-arg
- (take! '(1) 2))
- (pass-if-exception "(4 5) -1" exception:out-of-range
- (take! '(4 5) -1))
- (pass-if (equal? '() (take! '(4 5) 0)))
- (pass-if (equal? '(4) (take! '(4 5) 1)))
- (pass-if (equal? '(4 5) (take! '(4 5) 2)))
- (pass-if-exception "(4 5) 3" exception:wrong-type-arg
- (take! '(4 5) 3))
- (pass-if-exception "(4 5 6) -1" exception:out-of-range
- (take! '(4 5 6) -1))
- (pass-if (equal? '() (take! '(4 5 6) 0)))
- (pass-if (equal? '(4) (take! '(4 5 6) 1)))
- (pass-if (equal? '(4 5) (take! '(4 5 6) 2)))
- (pass-if (equal? '(4 5 6) (take! '(4 5 6) 3)))
- (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
- (take! '(4 5 6) 4)))
- ;;
- ;; take-right
- ;;
- (with-test-prefix "take-right"
- (pass-if-exception "() -1" exception:out-of-range
- (take-right '() -1))
- (pass-if (equal? '() (take-right '() 0)))
- (pass-if-exception "() 1" exception:wrong-type-arg
- (take-right '() 1))
- (pass-if-exception "(1) -1" exception:out-of-range
- (take-right '(1) -1))
- (pass-if (equal? '() (take-right '(1) 0)))
- (pass-if (equal? '(1) (take-right '(1) 1)))
- (pass-if-exception "(1) 2" exception:wrong-type-arg
- (take-right '(1) 2))
- (pass-if-exception "(4 5) -1" exception:out-of-range
- (take-right '(4 5) -1))
- (pass-if (equal? '() (take-right '(4 5) 0)))
- (pass-if (equal? '(5) (take-right '(4 5) 1)))
- (pass-if (equal? '(4 5) (take-right '(4 5) 2)))
- (pass-if-exception "(4 5) 3" exception:wrong-type-arg
- (take-right '(4 5) 3))
- (pass-if-exception "(4 5 6) -1" exception:out-of-range
- (take-right '(4 5 6) -1))
- (pass-if (equal? '() (take-right '(4 5 6) 0)))
- (pass-if (equal? '(6) (take-right '(4 5 6) 1)))
- (pass-if (equal? '(5 6) (take-right '(4 5 6) 2)))
- (pass-if (equal? '(4 5 6) (take-right '(4 5 6) 3)))
- (pass-if-exception "(4 5 6) 4" exception:wrong-type-arg
- (take-right '(4 5 6) 4))
- (pass-if "(a b . c) 0"
- (equal? (take-right '(a b . c) 0) 'c))
- (pass-if "(a b . c) 1"
- (equal? (take-right '(a b . c) 1) '(b . c))))
- ;;
- ;; tenth
- ;;
- (with-test-prefix "tenth"
- (pass-if-exception "() -1" exception:wrong-type-arg
- (tenth '(a b c d e f g h i)))
- (pass-if (eq? 'j (tenth '(a b c d e f g h i j))))
- (pass-if (eq? 'j (tenth '(a b c d e f g h i j k)))))
- ;;
- ;; xcons
- ;;
- (with-test-prefix "xcons"
- (pass-if (equal? '(y . x) (xcons 'x 'y))))
|