PageRenderTime 6ms CodeModel.GetById 2ms app.highlight 9ms RepoModel.GetById 1ms app.codeStats 0ms

/scheme/ikarus.lists.sls

http://github.com/marcomaggi/vicare
Unknown | 1298 lines | 1182 code | 116 blank | 0 comment | 0 complexity | d901aa21df31e6019aff9f9007479ac0 MD5 | raw file
   1;;;Ikarus Scheme -- A compiler for R6RS Scheme.
   2;;;Copyright (C) 2006,2007,2008  Abdulaziz Ghuloum
   3;;;Modified by Marco Maggi <marco.maggi-ipsu@poste.it>
   4;;;
   5;;;This program is free software:  you can redistribute it and/or modify
   6;;;it under  the terms of  the GNU General  Public License version  3 as
   7;;;published by the Free Software Foundation.
   8;;;
   9;;;This program is  distributed in the hope that it  will be useful, but
  10;;;WITHOUT  ANY   WARRANTY;  without   even  the  implied   warranty  of
  11;;;MERCHANTABILITY  or FITNESS FOR  A PARTICULAR  PURPOSE.  See  the GNU
  12;;;General Public License for more details.
  13;;;
  14;;;You should  have received  a copy of  the GNU General  Public License
  15;;;along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16
  17
  18#!vicare
  19(library (ikarus lists)
  20  (export
  21    make-list-of-predicate
  22    list? circular-list? list-of-single-item?
  23    list cons* make-list append length list-ref reverse
  24    last-pair memq memp memv member find assq assp assv assoc
  25    remq remv remove remp filter map for-each
  26    (rename (for-each for-each-in-order)) andmap ormap list-tail
  27    partition for-all exists fold-left fold-right
  28    make-queue-procs
  29
  30    ;; unsafe bindings
  31    $length)
  32  (import (except (vicare)
  33		  make-list-of-predicate
  34		  list?  circular-list? list-of-single-item?
  35		  list cons* make-list append reverse
  36		  last-pair length list-ref memq memp memv member find
  37		  assq assp assv assoc remq remv remove remp filter
  38		  map for-each for-each-in-order andmap ormap list-tail partition
  39		  for-all exists fold-left fold-right
  40		  make-queue-procs)
  41    (vicare system $fx)
  42    (vicare system $pairs))
  43
  44
  45;;;; arguments validation
  46
  47(define (list-length? obj)
  48  (and (fixnum? obj) ($fxnonnegative? obj)))
  49
  50(define (list-index? obj)
  51  (and (fixnum? obj) ($fxnonnegative? obj)))
  52
  53(define-syntax-rule (%error-list-was-altered-while-processing)
  54  (assertion-violation __who__ "list was altered while processing"))
  55
  56(define-syntax-rule (%error-circular-list-is-invalid-as-argument ?obj)
  57  (assertion-violation __who__ "circular list is invalid as argument" ?obj))
  58
  59(define-syntax-rule (%error-length-mismatch-among-list-arguments)
  60  (procedure-arguments-consistency-violation __who__ "length mismatch among list arguments"))
  61
  62(define-syntax-rule (%error-expected-proper-list-as-argument ?obj)
  63  (assertion-violation __who__ "expected proper list as argument" ?obj))
  64
  65(define-syntax-rule (%error-improper-list-is-invalid-as-argument ?obj)
  66  (assertion-violation __who__ "improper list is invalid as argument" ?obj))
  67
  68(define-syntax-rule (%error-malformed-alist-as-argument ?arg-index ?arg)
  69  (procedure-argument-violation __who__ "malformed alist as argument" ?arg))
  70
  71
  72;;;; helpers
  73
  74(define-syntax-rule (with-who ?name . ?body)
  75  (fluid-let-syntax
  76      ((__who__ (identifier-syntax (quote ?name))))
  77    . ?body))
  78
  79;;Commented out because  it appears to be useless:  $MEMQ is a primitive
  80;;operation (Marco Maggi; Oct 28, 2011).
  81;;
  82;; (define ($memq x ls)
  83;;   (and (pair? ls)
  84;;        (if (eq? x ($car ls))
  85;; 	   ls
  86;; 	 ($memq x ($cdr ls)))))
  87
  88(define list (lambda x x))
  89
  90(define (cons* fst . rest)
  91  (let loop ((fst fst) (rest rest))
  92    (if (null? rest)
  93	fst
  94      (cons fst (loop ($car rest) ($cdr rest))))))
  95
  96(module (list?)
  97
  98  (define (list? x)
  99    (%race x x))
 100
 101  (define (%race h t)
 102    ;;Tortoise and hare algorithm to detect circular lists.
 103    (if (pair? h)
 104	(let ((h ($cdr h)))
 105	  (if (pair? h)
 106	      (and (not (eq? h t))
 107		   (%race ($cdr h) ($cdr t)))
 108	    (null? h)))
 109      (null? h)))
 110
 111  #| end of module |# )
 112
 113(define (list-of-single-item? ell)
 114  (and (pair? ell)
 115       (null? (cdr ell))))
 116
 117(define (circular-list? obj)
 118  ;;At every iteration ELL is CDR-ed twice, LAG is CDR-ed once.
 119  (let loop ((ell obj)
 120	     (lag obj))
 121    (and (pair? ell)
 122	 (let ((ell (cdr ell)))
 123	   (and (pair? ell)
 124		(let ((ell (cdr ell))
 125		      (lag (cdr lag)))
 126		  (or (eq? ell lag)
 127		      (loop ell lag))))))))
 128
 129(define (make-list-of-predicate item-pred)
 130  (define (%race h t)
 131    ;;Tortoise and hare algorithm to detect circular lists.
 132    (if (pair? h)
 133	(begin
 134	  (debug-print 'list-of (car h))
 135	  (and (item-pred ($car h))
 136	       (let ((h ($cdr h)))
 137		 (if (pair? h)
 138		     (begin
 139		       (debug-print 'list-of (car h))
 140		       (and (item-pred ($car h))
 141			    (not (eq? h t))
 142			    (%race ($cdr h) ($cdr t))))
 143		   (null? h)))))
 144      (null? h)))
 145  (lambda (obj)
 146    (%race obj obj)))
 147
 148(case-define* make-list
 149  (({n list-length?})
 150   (%$make-list n (void) '()))
 151  (({n list-length?} fill)
 152   (%$make-list n fill '())))
 153
 154(define (%$make-list n fill ls)
 155  (if ($fxzero? n)
 156      ls
 157    (%$make-list ($fxsub1 n) fill (cons fill ls))))
 158
 159(define* (length ls)
 160  (define (%race h t ls n)
 161    (with-who length
 162      (cond ((pair? h)
 163	     (let ((h ($cdr h)))
 164	       (if (pair? h)
 165		   (if (not (eq? h t))
 166		       (%race ($cdr h) ($cdr t) ls ($fx+ n 2))
 167		     (%error-circular-list-is-invalid-as-argument ls))
 168		 (if (null? h)
 169		     ($fxadd1 n)
 170		   (%error-improper-list-is-invalid-as-argument ls)))))
 171	    ((null? h)
 172	     n)
 173	    (else
 174	     (%error-expected-proper-list-as-argument ls)))))
 175  (%race ls ls ls 0))
 176
 177(define ($length ell)
 178  ;;Assume ELL is a proper list and compute its length as fast as possible.
 179  ;;
 180  (let recur ((len 0)
 181	      (ell ell))
 182    (if (pair? ell)
 183	(recur ($fxadd1 len) ($cdr ell))
 184      len)))
 185
 186
 187(define* (list-ref the-list {the-index list-index?})
 188  (define (%error-index-out-of-range)
 189    (procedure-arguments-consistency-violation __who__ "index is out of range" the-index the-list))
 190  (define (%$list-ref ls i)
 191    (with-who list-ref
 192      (cond (($fxzero? i)
 193	     (if (pair? ls)
 194		 ($car ls)
 195	       (%error-index-out-of-range)))
 196	    ((pair? ls)
 197	     (%$list-ref ($cdr ls) ($fxsub1 i)))
 198	    ((null? ls)
 199	     (%error-index-out-of-range))
 200	    (else
 201	     (%error-expected-proper-list-as-argument the-list)))))
 202  (%$list-ref the-list the-index))
 203
 204
 205(define* (list-tail list {index list-index?})
 206  (define (%$list-tail ls i)
 207    (with-who list-tail
 208      (cond (($fxzero? i)
 209	     ls)
 210	    ((pair? ls)
 211	     (%$list-tail ($cdr ls) ($fxsub1 i)))
 212	    ((null? ls)
 213	     (procedure-arguments-consistency-violation __who__ "index is out of range" index list))
 214	    (else
 215	     (%error-expected-proper-list-as-argument list)))))
 216  (%$list-tail list index))
 217
 218
 219(case-define* append
 220  (()		'())
 221  ((ls)		ls)
 222  ((ls . ls*)
 223   (define (reverse h t ls ac)
 224     (with-who append
 225       (cond ((pair? h)
 226	      (let ((h ($cdr h)) (a1 ($car h)))
 227		(cond ((pair? h)
 228		       (if (not (eq? h t))
 229			   (let ((a2 ($car h)))
 230			     (reverse ($cdr h) ($cdr t) ls (cons a2 (cons a1 ac))))
 231			 (%error-circular-list-is-invalid-as-argument ls)))
 232		      ((null? h)
 233		       (cons a1 ac))
 234		      (else
 235		       (%error-expected-proper-list-as-argument ls)))))
 236	     ((null? h)
 237	      ac)
 238	     (else
 239	      (%error-expected-proper-list-as-argument ls)))))
 240
 241   (define (rev! ls ac)
 242     (if (null? ls)
 243	 ac
 244       (let ((ls^ ($cdr ls)))
 245	 ($set-cdr! ls ac)
 246	 (rev! ls^ ls))))
 247
 248   (define (append1 ls ls*)
 249     (if (null? ls*)
 250	 ls
 251       (rev! (reverse ls ls ls '())
 252	     (append1 ($car ls*) ($cdr ls*)))))
 253
 254   (append1 ls ls*))
 255  #| end of CASE-DEFINE* |# )
 256
 257
 258(define* (reverse x)
 259  (define (%race h t ls ac)
 260    (with-who reverse
 261      (cond ((pair? h)
 262	     (let ((h  ($cdr h))
 263		   (ac (cons ($car h) ac)))
 264	       (cond ((pair? h)
 265		      (if (not (eq? h t))
 266			  (%race ($cdr h) ($cdr t) ls (cons ($car h) ac))
 267			(%error-circular-list-is-invalid-as-argument ls)))
 268		     ((null? h)
 269		      ac)
 270		     (else
 271		      (%error-expected-proper-list-as-argument ls)))))
 272	    ((null? h)
 273	     ac)
 274	    (else
 275	     (%error-expected-proper-list-as-argument ls)))))
 276  (%race x x x '()))
 277
 278
 279(define* (last-pair {x pair?})
 280  (define (%race h t ls last)
 281    (if (pair? h)
 282	(let ((h ($cdr h)) (last h))
 283	  (if (pair? h)
 284	      (if (not (eq? h t))
 285		  (%race ($cdr h) ($cdr t) ls h)
 286		(%error-circular-list-is-invalid-as-argument ls))
 287	    last))
 288      last))
 289  (let ((d ($cdr x)))
 290    (%race d d x x)))
 291
 292
 293(define* (memq x ls)
 294  (define (%race h t ls x)
 295    (with-who memq
 296      (cond ((pair? h)
 297	     (if (eq? ($car h) x)
 298		 h
 299	       (let ((h ($cdr h)))
 300		 (cond ((pair? h)
 301			(cond ((eq? ($car h) x)
 302			       h)
 303			      ((not (eq? h t))
 304			       (%race ($cdr h) ($cdr t) ls x))
 305			      (else
 306			       (%error-circular-list-is-invalid-as-argument ls))))
 307		       ((null? h)
 308			#f)
 309		       (else
 310			(%error-expected-proper-list-as-argument ls))))))
 311	    ((null? h)
 312	     #f)
 313	    (else
 314	     (%error-expected-proper-list-as-argument ls)))))
 315  (%race ls ls ls x))
 316
 317
 318(define* (memv x ls)
 319  (define (%race h t ls x)
 320    (with-who memv
 321      (cond ((pair? h)
 322	     (if (eqv? ($car h) x)
 323		 h
 324	       (let ((h ($cdr h)))
 325		 (cond ((pair? h)
 326			(cond ((eqv? ($car h) x)
 327			       h)
 328			      ((not (eq? h t))
 329			       (%race ($cdr h) ($cdr t) ls x))
 330			      (else
 331			       (%error-circular-list-is-invalid-as-argument ls))))
 332		       ((null? h)
 333			#f)
 334		       (else
 335			(%error-expected-proper-list-as-argument ls))))))
 336	    ((null? h)
 337	     #f)
 338	    (else
 339	     (%error-expected-proper-list-as-argument ls)))))
 340  (%race ls ls ls x))
 341
 342
 343(define* (member x ls)
 344  (define (%race h t ls x)
 345    (with-who member
 346      (cond ((pair? h)
 347	     (if (equal? ($car h) x)
 348		 h
 349	       (let ((h ($cdr h)))
 350		 (cond ((pair? h)
 351			(cond ((equal? ($car h) x)
 352			       h)
 353			      ((not (eq? h t))
 354			       (%race ($cdr h) ($cdr t) ls x))
 355			      (else
 356			       (%error-circular-list-is-invalid-as-argument ls))))
 357		       ((null? h)
 358			#f)
 359		       (else
 360			(%error-expected-proper-list-as-argument ls))))))
 361	    ((null? h)
 362	     #f)
 363	    (else
 364	     (%error-expected-proper-list-as-argument ls)))))
 365  (%race ls ls ls x))
 366
 367
 368(define* (memp {p procedure?} ls)
 369  (define (%race h t ls p)
 370    (with-who memp
 371      (cond ((pair? h)
 372	     (if (p ($car h))
 373		 h
 374	       (let ((h ($cdr h)))
 375		 (cond ((pair? h)
 376			(cond ((p ($car h))
 377			       h)
 378			      ((not (eq? h t))
 379			       (%race ($cdr h) ($cdr t) ls p))
 380			      (else
 381			       (%error-circular-list-is-invalid-as-argument ls))))
 382		       ((null? h)
 383			#f)
 384		       (else
 385			(%error-expected-proper-list-as-argument ls))))))
 386	    ((null? h)
 387	     #f)
 388	    (else
 389	     (%error-expected-proper-list-as-argument ls)))))
 390  (%race ls ls ls p))
 391
 392
 393(define* (find {p procedure?} ls)
 394  (define (%race h t ls p)
 395    (with-who find
 396      (cond ((pair? h)
 397	     (let ((a ($car h)))
 398	       (if (p a)
 399		   a
 400		 (let ((h ($cdr h)))
 401		   (cond ((pair? h)
 402			  (let ((a ($car h)))
 403			    (cond ((p a)
 404				   a)
 405				  ((not (eq? h t))
 406				   (%race ($cdr h) ($cdr t) ls p))
 407				  (else
 408				   (%error-circular-list-is-invalid-as-argument ls)))))
 409			 ((null? h)
 410			  #f)
 411			 (else
 412			  (%error-expected-proper-list-as-argument ls)))))))
 413	    ((null? h)
 414	     #f)
 415	    (else
 416	     (%error-expected-proper-list-as-argument ls)))))
 417  (%race ls ls ls p))
 418
 419
 420(define* (assq x ls)
 421  (define (%race x h t ls)
 422    (with-who assq
 423      (cond ((pair? h)
 424	     (let ((a ($car h)) (h ($cdr h)))
 425	       (if (pair? a)
 426		   (cond ((eq? ($car a) x)
 427			  a)
 428			 ((pair? h)
 429			  (if (not (eq? h t))
 430			      (let ((a ($car h)))
 431				(if (pair? a)
 432				    (if (eq? ($car a) x)
 433					a
 434				      (%race x ($cdr h) ($cdr t) ls))
 435				  (%error-malformed-alist-as-argument 2 ls)))
 436			    (%error-circular-list-is-invalid-as-argument ls)))
 437			 ((null? h)
 438			  #f)
 439			 (else
 440			  (%error-expected-proper-list-as-argument ls)))
 441		 (%error-malformed-alist-as-argument 2 ls))))
 442	    ((null? h)
 443	     #f)
 444	    (else
 445	     (%error-expected-proper-list-as-argument ls)))))
 446  (%race x ls ls ls))
 447
 448
 449(define* (assp {p procedure?} ls)
 450  (define (%race p h t ls)
 451    (with-who assp
 452      (cond ((pair? h)
 453	     (let ((a ($car h)) (h ($cdr h)))
 454	       (if (pair? a)
 455		   (cond ((p ($car a))
 456			  a)
 457			 ((pair? h)
 458			  (if (not (eq? h t))
 459			      (let ((a ($car h)))
 460				(if (pair? a)
 461				    (if (p ($car a))
 462					a
 463				      (%race p ($cdr h) ($cdr t) ls))
 464				  (%error-malformed-alist-as-argument 2 ls)))
 465			    (%error-circular-list-is-invalid-as-argument ls)))
 466			 ((null? h)
 467			  #f)
 468			 (else
 469			  (%error-expected-proper-list-as-argument ls)))
 470		 (%error-malformed-alist-as-argument 2 ls))))
 471	    ((null? h)
 472	     #f)
 473	    (else
 474	     (%error-expected-proper-list-as-argument ls)))))
 475  (%race p ls ls ls))
 476
 477
 478(define* (assv x ls)
 479  (define (%race x h t ls)
 480    (with-who assv
 481      (cond ((pair? h)
 482	     (let ((a ($car h)) (h ($cdr h)))
 483	       (if (pair? a)
 484		   (cond ((eqv? ($car a) x)
 485			  a)
 486			 ((pair? h)
 487			  (if (not (eq? h t))
 488			      (let ((a ($car h)))
 489				(if (pair? a)
 490				    (if (eqv? ($car a) x)
 491					a
 492				      (%race x ($cdr h) ($cdr t) ls))
 493				  (%error-malformed-alist-as-argument 2 ls)))
 494			    (%error-circular-list-is-invalid-as-argument ls)))
 495			 ((null? h)
 496			  #f)
 497			 (else
 498			  (%error-expected-proper-list-as-argument ls)))
 499		 (%error-malformed-alist-as-argument 2 ls))))
 500	    ((null? h)
 501	     #f)
 502	    (else
 503	     (%error-expected-proper-list-as-argument ls)))))
 504  (%race x ls ls ls))
 505
 506
 507(define* (assoc x ls)
 508  (define (%race x h t ls)
 509    (with-who assoc
 510      (cond ((pair? h)
 511	     (let ((a ($car h)) (h ($cdr h)))
 512	       (if (pair? a)
 513		   (cond ((equal? ($car a) x)
 514			  a)
 515			 ((pair? h)
 516			  (if (not (eq? h t))
 517			      (let ((a ($car h)))
 518				(if (pair? a)
 519				    (if (equal? ($car a) x)
 520					a
 521				      (%race x ($cdr h) ($cdr t) ls))
 522				  (%error-malformed-alist-as-argument 2 ls)))
 523			    (%error-circular-list-is-invalid-as-argument ls)))
 524			 ((null? h)
 525			  #f)
 526			 (else
 527			  (%error-expected-proper-list-as-argument ls)))
 528		 (%error-malformed-alist-as-argument 2 ls))))
 529	    ((null? h)
 530	     #f)
 531	    (else
 532	     (%error-expected-proper-list-as-argument ls)))))
 533  (%race x ls ls ls))
 534
 535
 536(define-syntax define-remover
 537  (syntax-rules ()
 538    ((_ ?name ?cmp ?check)
 539     (define* (?name {x ?check} ls)
 540       (define (%race h t ls x)
 541	 (with-who ?name
 542	   (cond ((pair? h)
 543		  (if (?cmp ($car h) x)
 544		      (let ((h ($cdr h)))
 545			(cond ((pair? h)
 546			       (if (not (eq? h t))
 547				   (if (?cmp ($car h) x)
 548				       (%race ($cdr h) ($cdr t) ls x)
 549				     (cons ($car h) (%race ($cdr h) ($cdr t) ls x)))
 550				 (%error-circular-list-is-invalid-as-argument ls)))
 551			      ((null? h)
 552			       '())
 553			      (else
 554			       (%error-expected-proper-list-as-argument ls))))
 555		    (let ((a0 ($car h)) (h ($cdr h)))
 556		      (cond ((pair? h)
 557			     (if (not (eq? h t))
 558				 (if (?cmp ($car h) x)
 559				     (cons a0 (%race ($cdr h) ($cdr t) ls x))
 560				   (cons* a0 ($car h) (%race ($cdr h) ($cdr t) ls x)))
 561			       (%error-circular-list-is-invalid-as-argument ls)))
 562			    ((null? h)
 563			     (list a0))
 564			    (else
 565			     (%error-expected-proper-list-as-argument ls))))))
 566		 ((null? h)
 567		  '())
 568		 (else
 569		  (%error-expected-proper-list-as-argument ls)))))
 570       (%race ls ls ls x)))
 571    ))
 572
 573(define (%always-true? obj)
 574  #t)
 575
 576(define-remover remq	eq?				%always-true?)
 577(define-remover remv	eqv?				%always-true?)
 578(define-remover remove	equal?				%always-true?)
 579(define-remover remp	(lambda (elt p) (p elt))		procedure?)
 580(define-remover filter	(lambda (elt p) (not (p elt)))	procedure?)
 581
 582
 583(module (map)
 584
 585  (case-define* map
 586    (({f procedure?} ls)
 587     (cond ((pair? ls)
 588	    (let ((d ($cdr ls)))
 589	      (map1 f ($car ls) d (len d d 0))))
 590	   ((null? ls)
 591	    '())
 592	   (else
 593	    (err-invalid (list ls)))))
 594
 595    (({f procedure?} ls ls2)
 596     (cond ((pair? ls)
 597	    (if (pair? ls2)
 598		(let ((d ($cdr ls)))
 599		  (map2 f ($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
 600	      (err-invalid (list ls ls2))))
 601	   ((and (null? ls) (null? ls2))
 602	    '())
 603	   (else
 604	    (err-invalid (list ls ls2)))))
 605
 606    (({f procedure?} ls . ls*)
 607     (cond ((pair? ls)
 608	    (let ((n (len ls ls 0)))
 609	      (mapm f ls ls* n (cons ls ls*))))
 610	   ((and (null? ls) (andmap null? ls*))
 611	    '())
 612	   (else
 613	    (err-invalid (cons ls ls*)))))
 614
 615    #| end of CASE-DEFINE* |# )
 616
 617  (define (len h t n)
 618    (with-who map
 619      (cond ((pair? h)
 620	     (let ((h ($cdr h)))
 621	       (cond ((pair? h)
 622		      (if (eq? h t)
 623			  (%error-circular-list-is-invalid-as-argument h)
 624			(len ($cdr h) ($cdr t) ($fx+ n 2))))
 625		     ((null? h)
 626		      ($fxadd1 n))
 627		     (else
 628		      (%error-expected-proper-list-as-argument h)))))
 629	    ((null? h)
 630	     n)
 631	    (else
 632	     (%error-expected-proper-list-as-argument h)))))
 633
 634  (define (map1 f a d n)
 635    (with-who map
 636      (cond ((pair? d)
 637	     (if ($fxzero? n)
 638		 (%error-list-was-altered-while-processing)
 639	       (cons (f a) (map1 f ($car d) ($cdr d) ($fxsub1 n)))))
 640	    ((null? d)
 641	     (if ($fxzero? n)
 642		 (cons (f a) '())
 643	       (%error-list-was-altered-while-processing)))
 644	    (else
 645	     (%error-list-was-altered-while-processing)))))
 646
 647  (define (map2 f a1 a2 d1 d2 n)
 648    (with-who map
 649      (cond ((pair? d1)
 650	     (cond ((pair? d2)
 651		    (if ($fxzero? n)
 652			(%error-list-was-altered-while-processing)
 653		      (cons (f a1 a2)
 654			    (map2 f
 655				  ($car d1) ($car d2)
 656				  ($cdr d1) ($cdr d2)
 657				  ($fxsub1 n)))))
 658		   ((null? d2)
 659		    (%error-length-mismatch-among-list-arguments))
 660		   (else
 661		    (%error-expected-proper-list-as-argument d2))))
 662	    ((null? d1)
 663	     (cond ((null? d2)
 664		    (if ($fxzero? n)
 665			(cons (f a1 a2) '())
 666		      (%error-list-was-altered-while-processing)))
 667		   (else
 668		    (if (list? d2)
 669			(%error-length-mismatch-among-list-arguments)
 670		      (%error-expected-proper-list-as-argument d2)))))
 671	    (else
 672	     (%error-list-was-altered-while-processing)))))
 673
 674  (define (cars ls*)
 675    (with-who map
 676      (if (null? ls*)
 677	  '()
 678	(let ((a (car ls*)))
 679	  (if (pair? a)
 680	      (cons (car a) (cars (cdr ls*)))
 681	    (%error-length-mismatch-among-list-arguments))))))
 682
 683  (define (cdrs ls*)
 684    (with-who map
 685      (if (null? ls*)
 686	  '()
 687	(let ((a (car ls*)))
 688	  (if (pair? a)
 689	      (cons (cdr a) (cdrs (cdr ls*)))
 690	    (%error-length-mismatch-among-list-arguments))))))
 691
 692  (define (err-mutated all-lists)
 693    (with-who map
 694      (%error-list-was-altered-while-processing)))
 695
 696  (define (err-mismatch all-lists)
 697    (with-who map
 698      (%error-length-mismatch-among-list-arguments)))
 699
 700  (define (err-invalid all-lists)
 701    (with-who map
 702      (apply assertion-violation __who__ "invalid arguments" all-lists)))
 703
 704  (define (mapm f ls ls* n all-lists)
 705    (cond ((null? ls)
 706	   (if (andmap null? ls*)
 707	       (if (fxzero? n)
 708		   '()
 709		 (err-mutated all-lists))
 710	     (err-mismatch all-lists)))
 711	  ((fxzero? n)
 712	   (err-mutated all-lists))
 713	  (else
 714	   (cons (apply f (car ls) (cars ls*))
 715		 (mapm f (cdr ls) (cdrs ls*) (fxsub1 n) all-lists)))))
 716
 717  #| end of module |# )
 718
 719
 720(module (for-each)
 721
 722  (case-define* for-each
 723    (({f procedure?} ls)
 724     (cond ((pair? ls)
 725	    (let ((d ($cdr ls)))
 726	      (for-each1 f ($car ls) d (len d d 0))))
 727	   ((null? ls)
 728	    (void))
 729	   (else
 730	    (%error-expected-proper-list-as-argument ls))))
 731
 732    (({f procedure?} ls ls2)
 733     (cond ((pair? ls)
 734	    (if (pair? ls2)
 735		(let ((d ($cdr ls)))
 736		  (for-each2 f ($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
 737	      (%error-length-mismatch-among-list-arguments)))
 738	   ((null? ls)
 739	    (if (null? ls2)
 740		(void)
 741	      (%error-length-mismatch-among-list-arguments)))
 742	   (else
 743	    (%error-expected-proper-list-as-argument ls))))
 744
 745    (({f procedure?} {ls list?} . ls*)
 746     (let ((n (length ls)))
 747       (for-each (lambda (x)
 748		   (unless (and (list? x) (= (length x) n))
 749		     (%error-expected-proper-list-as-argument x)))
 750	 ls*)
 751       (let loop ((n (length ls)) (ls ls) (ls* ls*))
 752	 (if ($fxzero? n)
 753	     (unless (and (null? ls) (andmap null? ls*))
 754	       (%error-list-was-altered-while-processing))
 755	   (begin
 756	     (unless (and (pair? ls) (andmap pair? ls*))
 757	       (%error-list-was-altered-while-processing))
 758	     (apply f (car ls) (map car ls*))
 759	     (loop (fx- n 1) (cdr ls) (map cdr ls*)))))))
 760
 761    #| end of CASE-DEFINE* |# )
 762
 763  (define (len h t n)
 764    (with-who for-each
 765      (cond ((pair? h)
 766	     (let ((h ($cdr h)))
 767	       (cond ((pair? h)
 768		      (if (eq? h t)
 769			  (%error-circular-list-is-invalid-as-argument h)
 770			(len ($cdr h) ($cdr t) ($fx+ n 2))))
 771		     ((null? h)
 772		      ($fxadd1 n))
 773		     (else
 774		      (%error-expected-proper-list-as-argument h)))))
 775	    ((null? h)
 776	     n)
 777	    (else
 778	     (%error-expected-proper-list-as-argument h)))))
 779
 780  (define (for-each1 f a d n)
 781    (with-who for-each
 782      (cond ((pair? d)
 783	     (if ($fxzero? n)
 784		 (%error-list-was-altered-while-processing)
 785	       (begin
 786		 (f a)
 787		 (for-each1 f ($car d) ($cdr d) ($fxsub1 n)))))
 788	    ((null? d)
 789	     (if ($fxzero? n)
 790		 (f a)
 791	       (%error-list-was-altered-while-processing)))
 792	    (else
 793	     (%error-list-was-altered-while-processing)))))
 794
 795  (define (for-each2 f a1 a2 d1 d2 n)
 796    (with-who for-each
 797      (cond ((pair? d1)
 798	     (if (pair? d2)
 799		 (if ($fxzero? n)
 800		     (%error-list-was-altered-while-processing)
 801		   (begin
 802		     (f a1 a2)
 803		     (for-each2 f
 804				($car d1) ($car d2)
 805				($cdr d1) ($cdr d2)
 806				($fxsub1 n))))
 807	       (%error-length-mismatch-among-list-arguments)))
 808	    ((null? d1)
 809	     (if (null? d2)
 810		 (if ($fxzero? n)
 811		     (f a1 a2)
 812		   (%error-list-was-altered-while-processing))
 813	       (%error-length-mismatch-among-list-arguments)))
 814	    (else
 815	     (%error-list-was-altered-while-processing)))))
 816
 817  #| end of module |#)
 818
 819
 820(module (andmap)
 821  ;;ANDMAP should be the same as R6RS's FOR-ALL (Marco Maggi; Oct 28, 2011).
 822  ;;
 823  (case-define* andmap
 824    (({f procedure?} ls)
 825     (cond ((pair? ls)
 826	    (let ((d ($cdr ls)))
 827	      (andmap1 f ($car ls) d (len d d 0))))
 828	   ((null? ls)
 829	    #t)
 830	   (else
 831	    (%error-expected-proper-list-as-argument ls))))
 832
 833    (({f procedure?} ls ls2)
 834     (cond ((pair? ls)
 835	    (if (pair? ls2)
 836		(let ((d ($cdr ls)))
 837		  (andmap2 f
 838			   ($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
 839	      (%error-length-mismatch-among-list-arguments)))
 840	   ((null? ls)
 841	    (if (null? ls2)
 842		#t
 843	      (%error-length-mismatch-among-list-arguments)))
 844	   (else
 845	    (%error-expected-proper-list-as-argument ls))))
 846
 847    #| end of CASE-DEFINE* |# )
 848
 849  (define (len h t n)
 850    (with-who andmap
 851      (cond ((pair? h)
 852	     (let ((h ($cdr h)))
 853	       (cond ((pair? h)
 854		      (if (eq? h t)
 855			  (%error-circular-list-is-invalid-as-argument h)
 856			(len ($cdr h) ($cdr t) ($fx+ n 2))))
 857		     ((null? h)
 858		      ($fxadd1 n))
 859		     (else
 860		      (%error-expected-proper-list-as-argument h)))))
 861	    ((null? h)
 862	     n)
 863	    (else
 864	     (%error-expected-proper-list-as-argument h)))))
 865
 866  (define (andmap1 f a d n)
 867    (with-who for-each
 868      (cond ((pair? d)
 869	     (if ($fxzero? n)
 870		 (%error-list-was-altered-while-processing)
 871	       (and (f a)
 872		    (andmap1 f ($car d) ($cdr d) ($fxsub1 n)))))
 873	    ((null? d)
 874	     (if ($fxzero? n)
 875		 (f a)
 876	       (%error-list-was-altered-while-processing)))
 877	    (else
 878	     (%error-list-was-altered-while-processing)))))
 879
 880  (define (andmap2 f a1 a2 d1 d2 n)
 881    (with-who for-each
 882      (cond ((pair? d1)
 883	     (if (pair? d2)
 884		 (if ($fxzero? n)
 885		     (%error-list-was-altered-while-processing)
 886		   (and (f a1 a2)
 887			(andmap2 f
 888				 ($car d1) ($car d2)
 889				 ($cdr d1) ($cdr d2)
 890				 ($fxsub1 n))))
 891	       (%error-length-mismatch-among-list-arguments)))
 892	    ((null? d1)
 893	     (if (null? d2)
 894		 (if ($fxzero? n)
 895		     (f a1 a2)
 896		   (%error-list-was-altered-while-processing))
 897	       (%error-length-mismatch-among-list-arguments)))
 898	    (else
 899	     (%error-list-was-altered-while-processing)))))
 900
 901  #| end of module |# )
 902
 903
 904(module (ormap)
 905  ;;ANDMAP should be the same as R6RS's EXISTS (Marco Maggi; Oct 28, 2011).
 906  ;;
 907  (define* (ormap {f procedure?} ls)
 908    (cond ((pair? ls)
 909	   (let ((d ($cdr ls)))
 910	     (ormap1 f ($car ls) d (len d d 0))))
 911	  ((null? ls)
 912	   #f)
 913	  (else
 914	   (%error-expected-proper-list-as-argument ls))))
 915
 916  (define (len h t n)
 917    (with-who for-each
 918      (cond ((pair? h)
 919	     (let ((h ($cdr h)))
 920	       (cond ((pair? h)
 921		      (if (eq? h t)
 922			  (%error-circular-list-is-invalid-as-argument h)
 923			(len ($cdr h) ($cdr t) ($fx+ n 2))))
 924		     ((null? h)
 925		      ($fxadd1 n))
 926		     (else
 927		      (%error-expected-proper-list-as-argument h)))))
 928	    ((null? h)
 929	     n)
 930	    (else
 931	     (%error-expected-proper-list-as-argument h)))))
 932
 933  (define (ormap1 f a d n)
 934    (with-who for-each
 935      (cond ((pair? d)
 936	     (if ($fxzero? n)
 937		 (%error-list-was-altered-while-processing)
 938	       (or (f a)
 939		   (ormap1 f ($car d) ($cdr d) ($fxsub1 n)))))
 940	    ((null? d)
 941	     (if ($fxzero? n)
 942		 (f a)
 943	       (%error-list-was-altered-while-processing)))
 944	    (else
 945	     (%error-list-was-altered-while-processing)))))
 946
 947  #| end of module |# )
 948
 949
 950(define* (partition {p procedure?} ls)
 951  (define (%race h t ls p)
 952    (with-who partition
 953      (cond ((pair? h)
 954	     (let ((a0 ($car h))
 955		   (h  ($cdr h)))
 956	       (cond ((pair? h)
 957		      (if (eq? h t)
 958			  (%error-circular-list-is-invalid-as-argument ls)
 959			(let ((a1 ($car h)))
 960			  (let-values (((a* b*) (%race ($cdr h) ($cdr t) ls p)))
 961			    (cond ((p a0)
 962				   (if (p a1)
 963				       (values (cons* a0 a1 a*) b*)
 964				     (values (cons a0 a*) (cons a1 b*))))
 965				  ((p a1)
 966				   (values (cons a1 a*) (cons a0 b*)))
 967				  (else
 968				   (values a* (cons* a0 a1 b*))))))))
 969		     ((null? h)
 970		      (if (p a0)
 971			  (values (list a0) '())
 972			(values '() (list a0))))
 973		     (else
 974		      (%error-expected-proper-list-as-argument ls)))))
 975	    ((null? h)
 976	     (values '() '()))
 977	    (else
 978	     (%error-expected-proper-list-as-argument ls)))))
 979  (%race ls ls ls p))
 980
 981
 982(define-syntax define-iterator
 983  (syntax-rules ()
 984    ((_ ?name ?combine)
 985     (module (?name)
 986       (case-define* ?name
 987	 (({f procedure?} ls)
 988	  (cond ((pair? ls)
 989		 (loop1 f (car ls) (cdr ls) (cdr ls) ls))
 990		((null? ls)
 991		 (?combine))
 992		(else
 993		 (%error-expected-proper-list-as-argument ls))))
 994
 995	 (({f procedure?} ls . ls*)
 996	  (cond ((pair? ls)
 997		 (let-values (((cars cdrs) (cars+cdrs ls* ls*)))
 998		   (loopn f (car ls) cars (cdr ls) cdrs (cdr ls) ls ls*)))
 999		((and (null? ls) (null*? ls*))
1000		 (?combine))
1001		(else
1002		 (err* ls*))))
1003	 #| end of CASE-DEFINE* |# )
1004
1005       (define (null*? ls)
1006	 (or (null? ls) (and (null? (car ls)) (null*? (cdr ls)))))
1007
1008       (define (err* ls*)
1009	 (with-who ?name
1010	   (for-each (lambda (ls)
1011		       (unless (list? ls)
1012			 (%error-expected-proper-list-as-argument ls)))
1013	     ls*)
1014	   (%error-length-mismatch-among-list-arguments)))
1015
1016       (define (cars+cdrs ls ls*)
1017	 (with-who ?name
1018	   (if (null? ls)
1019	       (values '() '())
1020	     (let ((a (car ls)))
1021	       (cond ((pair? a)
1022		      (let-values (((cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))))
1023			(values (cons (car a) cars) (cons (cdr a) cdrs))))
1024		     ((list? (car ls*))
1025		      (%error-length-mismatch-among-list-arguments))
1026		     (else
1027		      (%error-expected-proper-list-as-argument (car ls*))))))))
1028
1029       (define (loop1 f a h t ls)
1030	 (with-who ?name
1031	   (cond ((pair? h)
1032		  (let ((b (car h)) (h (cdr h)))
1033		    (?combine (f a)
1034			      (cond ((pair? h)
1035				     (if (eq? h t)
1036					 (%error-circular-list-is-invalid-as-argument h)
1037				       (let ((c (car h)) (h (cdr h)))
1038					 (?combine (f b) (loop1 f c h (cdr t) ls)))))
1039				    ((null? h)
1040				     (f b))
1041				    (else
1042				     (?combine (f b)
1043					       (%error-expected-proper-list-as-argument ls)))))))
1044		 ((null? h)
1045		  (f a))
1046		 (else
1047		  (?combine (f a) (%error-expected-proper-list-as-argument ls))))))
1048
1049       (define (loopn f a a* h h* t ls ls*)
1050	 (with-who ?name
1051	   (cond ((pair? h)
1052		  (let-values (((b* h*) (cars+cdrs h* ls*)))
1053		    (let ((b (car h)) (h (cdr h)))
1054		      (?combine (apply f a a*)
1055				(if (pair? h)
1056				    (if (eq? h t)
1057					(%error-circular-list-is-invalid-as-argument h)
1058				      (let-values (((c* h*) (cars+cdrs h* ls*)))
1059					(let ((c (car h)) (h (cdr h)))
1060					  (?combine (apply f b b*)
1061						    (loopn f c c* h h* (cdr t) ls ls*)))))
1062				  (if (and (null? h) (null*? h*))
1063				      (apply f b b*)
1064				    (?combine (apply f b b*) (err* (cons ls ls*)))))))))
1065		 ((and (null? h) (null*? h*))
1066		  (apply f a a*))
1067		 (else
1068		  (?combine (apply f a a*) (err* (cons ls ls*)))))))
1069
1070       #| end of module |# )
1071     )))
1072
1073(define-iterator for-all and)
1074(define-iterator exists  or)
1075
1076
1077(module (fold-left)
1078  (case-define* fold-left
1079    (({f procedure?} nil ls)
1080     (loop1 f nil ls ls ls))
1081    (({f procedure?} nil ls . ls*)
1082     (loopn f nil ls ls* ls ls ls*))
1083    #| end of CASE-DEFINE* |# )
1084
1085  (define (null*? ls)
1086    (or (null? ls) (and (null? (car ls)) (null*? (cdr ls)))))
1087
1088  (define (err* ls*)
1089    (with-who fold-left
1090      (cond ((null? ls*)
1091	     (%error-length-mismatch-among-list-arguments))
1092	    ((list? (car ls*))
1093	     (err* (cdr ls*)))
1094	    (else
1095	     (%error-expected-proper-list-as-argument (car ls*))))))
1096
1097  (define (cars+cdrs ls ls*)
1098    (with-who fold-left
1099      (if (null? ls)
1100	  (values '() '())
1101	(let ((a (car ls)))
1102	  (cond ((pair? a)
1103		 (let-values (((cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))))
1104		   (values (cons (car a) cars) (cons (cdr a) cdrs))))
1105		((list? (car ls*))
1106		 (%error-length-mismatch-among-list-arguments))
1107		(else
1108		 (%error-expected-proper-list-as-argument (car ls*))))))))
1109
1110  (define (loop1 f nil h t ls)
1111    (with-who fold-left
1112      (cond ((pair? h)
1113	     (let ((a (car h)) (h (cdr h)))
1114	       (cond ((pair? h)
1115		      (if (eq? h t)
1116			  (%error-circular-list-is-invalid-as-argument ls)
1117			(let ((b (car h)) (h (cdr h)) (t (cdr t)))
1118			  (loop1 f (f (f nil a) b) h t ls))))
1119		     ((null? h)
1120		      (f nil a))
1121		     (else
1122		      (%error-expected-proper-list-as-argument ls)))))
1123	    ((null? h)
1124	     nil)
1125	    (else
1126	     (%error-expected-proper-list-as-argument ls)))))
1127
1128  (define (loopn f nil h h* t ls ls*)
1129    (with-who fold-left
1130      (cond ((pair? h)
1131	     (let-values (((a* h*) (cars+cdrs h* ls*)))
1132	       (let ((a (car h)) (h (cdr h)))
1133		 (cond ((pair? h)
1134			(if (eq? h t)
1135			    (%error-circular-list-is-invalid-as-argument ls)
1136			  (let-values (((b* h*) (cars+cdrs h* ls*)))
1137			    (let ((b (car h)) (h (cdr h)) (t (cdr t)))
1138			      (loopn f
1139				     (apply f (apply f nil a a*) b b*)
1140				     h h* t ls ls*)))))
1141		       ((and (null?  h)
1142			     (null*? h*))
1143			(apply f nil a a*))
1144		       (else
1145			(err* (cons ls ls*)))))))
1146	    ((and (null? h) (null*? h*))
1147	     nil)
1148	    (else
1149	     (err* (cons ls ls*))))))
1150
1151  #| end of module |# )
1152
1153
1154(module (fold-right)
1155  (case-define* fold-right
1156    (({f procedure?} nil ls)
1157     (loop1 f nil ls ls ls))
1158    (({f procedure?} nil ls . ls*)
1159     (loopn f nil ls ls* ls ls ls*))
1160    #| end of CASE-DEFINE* |# )
1161
1162  (define (null*? ls)
1163    (or (null? ls) (and (null? (car ls)) (null*? (cdr ls)))))
1164
1165  (define (err* ls*)
1166    (with-who fold-right
1167      (cond ((null? ls*)
1168	     (%error-length-mismatch-among-list-arguments))
1169	    ((list? (car ls*))
1170	     (err* (cdr ls*)))
1171	    (else
1172	     (%error-expected-proper-list-as-argument (car ls*))))))
1173
1174  (define (cars+cdrs ls ls*)
1175    (with-who fold-right
1176      (if (null? ls)
1177	  (values '() '())
1178	(let ((a (car ls)))
1179	  (cond ((pair? a)
1180		 (let-values (((cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))))
1181		   (values (cons (car a) cars) (cons (cdr a) cdrs))))
1182		((list? (car ls*))
1183		 (%error-length-mismatch-among-list-arguments))
1184		(else
1185		 (%error-expected-proper-list-as-argument (car ls*))))))))
1186
1187  (define (loop1 f nil h t ls)
1188    (with-who fold-right
1189      (cond ((pair? h)
1190	     (let ((a (car h)) (h (cdr h)))
1191	       (cond ((pair? h)
1192		      (if (eq? h t)
1193			  (%error-circular-list-is-invalid-as-argument ls)
1194			(let ((b (car h)) (h (cdr h)) (t (cdr t)))
1195			  (f a (f b (loop1 f nil h t ls))))))
1196		     ((null? h)
1197		      (f a nil))
1198		     (else
1199		      (%error-expected-proper-list-as-argument ls)))))
1200	    ((null? h)
1201	     nil)
1202	    (else
1203	     (%error-expected-proper-list-as-argument ls)))))
1204
1205  (define (loopn f nil h h* t ls ls*)
1206    (with-who fold-right
1207      (cond ((pair? h)
1208	     (let-values (((a* h*) (cars+cdrs h* ls*)))
1209	       (let ((a (car h)) (h (cdr h)))
1210		 (cond ((pair? h)
1211			(if (eq? h t)
1212			    (%error-circular-list-is-invalid-as-argument ls)
1213			  (let-values (((b* h*) (cars+cdrs h* ls*)))
1214			    (let ((b (car h))
1215				  (h (cdr h))
1216				  (t (cdr t)))
1217			      (apply f a
1218				     (append
1219				      a* (list
1220					  (apply f
1221						 b (append
1222						    b* (list (loopn f nil h h* t ls ls*)))))))))))
1223		       ((and (null?  h)
1224			     (null*? h*))
1225			(apply f a (append a* (list nil))))
1226		       (else
1227			(err* (cons ls ls*)))))))
1228	    ((and (null? h) (null*? h*))
1229	     nil)
1230	    (else
1231	     (err* (cons ls ls*))))))
1232
1233  #| end of module |#)
1234
1235
1236;;;; queue of items
1237
1238(define make-queue-procs
1239  (case-lambda
1240   (()
1241    (make-queue-procs '()))
1242   ((init-values)
1243    ;;The value of this variable is #f or a pair representing a queue of
1244    ;;items.
1245    ;;
1246    ;;The car of the queue-pair is the  first pair of the list of items.
1247    ;;The cdr of the queue-pair is the last pair of the list of items.
1248    ;;
1249    (define queue-pair
1250      (if (null? init-values)
1251	  #f
1252	(cons init-values
1253	      (let find-last-pair ((L init-values))
1254		(if (null? ($cdr L))
1255		    L
1256		  (find-last-pair ($cdr L)))))))
1257
1258    (define-syntax queue
1259      (syntax-rules ()
1260	((_)
1261	 queue-pair)
1262	((_ ?item)
1263	 (set! queue-pair ?item))))
1264
1265    (define (empty-queue?)
1266      (not (queue)))
1267
1268    (define (enqueue! item)
1269      (if (queue)
1270	  (let ((old-last-pair ($cdr (queue)))
1271		(new-last-pair (list item)))
1272	    ($set-cdr! old-last-pair new-last-pair)
1273	    ($set-cdr! (queue) new-last-pair))
1274	(let ((Q (list item)))
1275	  (queue (cons Q Q)))))
1276
1277    (define (dequeue!)
1278      (if (queue)
1279	  (let ((head ($car (queue))))
1280	    (begin0
1281		($car head)
1282	      (let ((head ($cdr head)))
1283		(if (null? head)
1284		    (queue #f)
1285		  ($set-car! (queue) head)))))
1286	(error 'dequeue! "no more items in queue")))
1287
1288    (values empty-queue? enqueue! dequeue!))))
1289
1290
1291;;;; done
1292
1293#| end of library |# )
1294
1295;;; end of file
1296;; Local Variables:
1297;; eval: (put 'with-who 'scheme-indent-function		1)
1298;; End: