;; -*-theme-d-*-

;; Copyright (C) 2015 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

(define-body (standard-library dynamic-list)


  (define d-car (unchecked-prim-proc d-car (<object>) <object> pure))


  (define d-cdr (unchecked-prim-proc d-cdr (<object>) <object> pure))


  (define d-list (unchecked-prim-proc list ((rest <object>)) <object> pure))


  (define-simple-proc d-list-ref (((l <object>) (i <integer>))
				  <object> pure)
    (cond
     ((< i 0) (raise-simple 'd-list-ref:invalid-index))
     ((pair? l)
      (if (equal? i 0)
	  (d-car l)
	  (d-list-ref (d-cdr l) (- i 1))))
     (else (raise-simple 'd-list-ref:invalid-list))))


  (define-simple-proc d-map1
      (((proc (:procedure (<object>) <object> pure))
	(l <object>))
       <object>
       pure)
    (if (null? l)
	null
	(cons (proc (d-car l))
	      (d-map1 proc (d-cdr l)))))


  (define-simple-proc d-map-nonpure1
      (((proc (:procedure (<object>) <object> nonpure))
	(l <object>))
       <object>
       nonpure)
    (if (null? l)
	null
	(cons (proc (d-car l))
	      (d-map-nonpure1 proc (d-cdr l)))))


  (define-simple-proc d-for-each1
      (((proc (:procedure (<object>) <none> nonpure))
	(l <object>))
       <none>
       nonpure)
    (if (null? l)
	null
	(begin
	  (proc (d-car l))
	  (d-for-each1 proc (d-cdr l)))))


  (define-simple-proc d-or-map1-0?
      (((proc (:procedure (<object>) <boolean> pure))
	(l <object>))
       <boolean>
	pure)
    (if (null? l)
	#f
	(let ((hd (d-car l))
	      (tl (d-cdr l)))
	  (or (proc hd) (d-or-map1-0? proc tl)))))


  (define-simple-proc d-map-car0 (((l-lists <object>)) <object> pure)
    (if (null? l-lists)
	null
	(cons (d-car (d-car l-lists))
	      (d-map-car0 (d-cdr l-lists)))))


  (define-simple-proc d-map-cdr0 (((l-lists <object>)) <object> pure)
    (if (null? l-lists)
	null
	(cons (d-cdr (d-car l-lists))
	      (d-map-cdr0 (d-cdr l-lists)))))


  (define-simple-proc d-map0
      (((proc (:procedure ((rest <object>)) <object> pure))
	(l-lists <object>))
       <object>
       pure)
    (if (d-or-map1-0? null? l-lists)
	null
	(let ((l-cars (d-map-car0 l-lists))
	      (l-cdrs (d-map-cdr0 l-lists)))
	  (cons
	   (apply proc (cast <list> l-cars))
	   (d-map0 proc l-cdrs)))))

  
  (define-simple-proc d-map
      (((proc (:procedure ((rest <object>)) <object> pure))
	(l-lists (rest <object>)))
       <object>
       pure)
    (d-map0 proc l-lists))


  (define-simple-proc d-map-nonpure0
      (((proc (:procedure ((rest <object>)) <object> nonpure))
	(l-lists <object>))
       <object>
       nonpure)
    (if (d-or-map1-0? null? l-lists)
	null
	(let ((l-cars (d-map-car0 l-lists))
	      (l-cdrs (d-map-cdr0 l-lists)))
	  (cons
	   (apply-nonpure proc (cast <list> l-cars))
	   (d-map-nonpure0 proc l-cdrs)))))

  
  (define-simple-proc d-map-nonpure
      (((proc (:procedure ((rest <object>)) <object> nonpure))
	(l-lists (rest <object>)))
       <object>
       nonpure)
    (d-map-nonpure0 proc l-lists))


  (define-simple-proc d-for-each0
      (((proc (:procedure ((rest <object>)) <none> nonpure))
	(l-lists <object>))
       <none>
       nonpure)
    (if (not (d-or-map1-0? null? l-lists))
	(let ((l-cars (d-map-car0 l-lists))
	      (l-cdrs (d-map-cdr0 l-lists)))
	  (begin
	   (apply-nonpure proc (cast <list> l-cars))
	   (d-for-each0 proc l-cdrs)))))

  
  (define-simple-proc d-for-each
      (((proc (:procedure ((rest <object>)) <none> nonpure))
	(l-lists (rest <object>)))
       <none>
       nonpure)
    (d-for-each0 proc l-lists))


  (define d-append (unchecked-prim-proc append
					((rest <object>)) <object> pure)))
