;;; dsssl-utils.scm
;;; Copyright Henry S. Thompson 1996
;;; Alpha verson 0.6, not for onward distribution

;;; Produced at HCRC, Edinburgh with support for the UK Economic and Social
;;;  Research Council and SunSoft

;;; miscellaneous utility fns
;;; Last edited: Fri Aug  9 1996

(define union
  (lambda (l1 l2)
    (if (pair? l2)
        (let loop ((ptr l1)
                   (res l2))
             (if (pair? ptr)
                 (loop (cdr ptr) (if (member (car ptr) res)
                                     res
                                   (cons (car ptr) res)))
               res))
      l1)))

(define tconc
  (lambda (tcp new)
    ;; add new last element
    ;; tcp is cons of list and last tail
    (let ((nn (cons new '())))
      (if (pair? tcp)
          (begin (set-cdr! (cdr tcp) nn)
                 (set-cdr! tcp nn)
                 tcp)
        (cons nn nn)))))

(define append!
  (lambda (l1 l2)
    (if (pair? l1)
        (let loop ((ptr l1))
             (if (pair? (cdr ptr))
                 (loop (cdr ptr))
               (begin
                (set-cdr! ptr l2)
                l1)))
      l2)))

(define ldiff
  (lambda (l1 l2)
    (let loop ((l1 l1)
               (res '()))
          (if (eq? l1 l2)
              res
            (loop (cdr l1)
                  (cons (car l1) res))))))

(define remove-one
  (lambda (elt l1)
    (if (pair? l1)
        (if (eq? elt (car l1))
            (cdr l1)
          (cons (car l1)
                (remove-one elt (cdr l1))))
      l1)))

(define dremove-use
  (lambda (type sym bu)
    ;; DEPENDS on u being cdr!!!
    (if (pair? bu)
	(if (and (pair? (bu-u bu))
		 (memq (cdar (bu-u bu)) type)
		 (or (not sym)
		     (eq? sym (caar (bu-u bu)))))
	    (begin (set-cdr! bu (cdr (bu-u bu)))
		   (dremove-use type sym bu))
	  (dremove-use type sym (cdr bu))))))

(define keyword?
  (lambda (sym)
    ;; temporary definition
    (and (pair? sym)
         (eq? (car sym) 'd!k))))

(define thereis 
  (lambda (pred ptr)
    (if (pair? ptr)
      (if
        (pred (car ptr))
        ptr
        (thereis pred (cdr ptr)))
      #f)))

