;==============================================================================
;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

; file: "utils.scm"

;------------------------------------------------------------------------------
;
; Utilities:
; ---------

(define (make-counter limit limit-error)
  (let ((count 0))
    (lambda ()
      (if (< count limit)
        (begin (set! count (+ count 1)) count)
        (limit-error)))))

(define (pos-in-list x l)
  (let loop ((l l) (i 0))
    (cond ((not (pair? l)) #f)
          ((eq? (car l) x) i)
          (else            (loop (cdr l) (+ i 1))))))

(define (string-pos-in-list x l)
  (let loop ((l l) (i 0))
    (cond ((not (pair? l))      #f)
          ((string=? (car l) x) i)
          (else                 (loop (cdr l) (+ i 1))))))

(define (nth-after l n)
  (let loop ((l l) (n n))
    (if (> n 0)
      (loop (cdr l) (- n 1))
      l)))

(define (pair-up l1 l2)
  (define (pair l1 l2)
    (if (pair? l1)
      (cons (cons (car l1) (car l2)) (pair (cdr l1) (cdr l2)))
      '()))
  (pair l1 l2))

(define (sort-list l <?)

  (define (mergesort l)

    (define (merge l1 l2)
      (cond ((null? l1) l2)
            ((null? l2) l1)
            (else
             (let ((e1 (car l1)) (e2 (car l2)))
               (if (<? e1 e2)
                 (cons e1 (merge (cdr l1) l2))
                 (cons e2 (merge l1 (cdr l2))))))))

    (define (split l)
      (if (or (null? l) (null? (cdr l)))
        l
        (cons (car l) (split (cddr l)))))

    (if (or (null? l) (null? (cdr l)))
      l
      (let* ((l1 (mergesort (split l)))
             (l2 (mergesort (split (cdr l)))))
        (merge l1 l2))))

  (mergesort l))

(define (lst->vector l)
  (let* ((n (length l))
         (v (make-vector n)))
    (let loop ((l l) (i 0))
      (if (pair? l)
        (begin
          (vector-set! v i (car l))
          (loop (cdr l) (+ i 1)))
        v))))

(define (vector->lst v)
  (let loop ((l '()) (i (- (vector-length v) 1)))
    (if (< i 0)
      l
      (loop (cons (vector-ref v i) l) (- i 1)))))

(define (string->lst s)
  (let loop ((l '()) (i (- (string-length s) 1)))
    (if (< i 0)
      l
      (loop (cons (string-ref s i) l) (- i 1)))))

;------------------------------------------------------------------------------
;
; Exception processing
; --------------------

(define (with-exception-handling proc)
  (let ((old-exception-handler throw-to-exception-handler))
    (let ((val
            (call-with-current-continuation
              (lambda (cont)
                (set! throw-to-exception-handler cont)
                (proc)))))
    (set! throw-to-exception-handler old-exception-handler)
    val)))

(define (throw-to-exception-handler val)
  (fatal-err "*** Internal error, no exception handler at this point" val))

;------------------------------------------------------------------------------
;
; Compiler warnings and error messaging
; -------------------------------------

(define (compiler-warning msg . args)
  (newline)
  (display "*** Warning: ") (display msg)
  (for-each (lambda (x) (display " ") (write x)) args)
  (newline))

(define (compiler-error msg . args)
  (newline)
  (display "*** Error: ")
  (display msg)
  (for-each (lambda (x) (display " ") (write x)) args)
  (newline)
  (compiler-abort))

(define (compiler-user-error loc msg . args)
  (newline)
  (display "*** User error detected") (locat-show loc) (newline)
  (display "*** ") (display msg)
  (for-each (lambda (x) (display " ") (write x)) args)
  (newline)
  (compiler-abort))

(define (compiler-internal-error msg . args)
  (newline)
  (display "*** Internal error detected") (newline)
  (display "*** in procedure ") (display msg)
  (for-each (lambda (x) (display " ") (write x)) args)
  (newline)
  (compiler-abort))

(define (compiler-limitation-error msg . args)
  (newline)
  (display "*** Compiler limit reached") (newline)
  (display "*** ") (display msg)
  (for-each (lambda (x) (display " ") (write x)) args)
  (newline)
  (compiler-abort))

(define (compiler-abort)
  (display "*** Aborting compilation") (newline)
  (throw-to-exception-handler #f))

;------------------------------------------------------------------------------
;
; SET manipulation stuff
; ----------------------

(define (list->set list)    list)         ; convert list to set
(define (set->list set)     set)          ; convert set to list
(define (set-empty)         '())          ; the empty set
(define (set-empty? set)    (null? set))  ; is 'x' the empty set?
(define (set-member? x set) (memq x set)) ; is 'x' a member of the 'set'?
(define (set-singleton x)   (list x))     ; create a set containing only 'x'

(define (set-adjoin set x)                ; add the element 'x' to the 'set'
  (if (memq x set) set (cons x set)))

(define (set-remove set x)                ; remove the element 'x' from 'set'
  (cond ((null? set)       '())
        ((eq? (car set) x) (cdr set))
        (else              (cons (car set) (set-remove (cdr set) x)))))

(define (set-equal? s1 s2)
  (cond ((null? s1)         (null? s2))
        ((memq (car s1) s2) (set-equal? (cdr s1) (set-remove s2 (car s1))))
        (else               #f)))

(define (set-difference set . other-sets) ; return difference of sets
  (define (difference s1 s2)
    (cond ((null? s1)         '())
          ((memq (car s1) s2) (difference (cdr s1) s2))
          (else               (cons (car s1) (difference (cdr s1) s2)))))
  (n-ary difference set other-sets))

(define (set-union . sets)                ; return union of sets
  (define (union s1 s2)
    (cond ((null? s1)         s2)
          ((memq (car s1) s2) (union (cdr s1) s2))
          (else               (cons (car s1) (union (cdr s1) s2)))))
  (n-ary union '() sets))

(define (set-intersection set . other-sets) ; return intersection of sets
  (define (intersection s1 s2)
    (cond ((null? s1)         '())
          ((memq (car s1) s2) (cons (car s1) (intersection (cdr s1) s2)))
          (else               (intersection (cdr s1) s2))))
  (n-ary intersection set other-sets))

(define (n-ary function first rest)
  (if (null? rest)
    first
    (n-ary function (function first (car rest)) (cdr rest))))

(define (set-keep keep? set)
  (cond ((null? set)       '())
        ((keep? (car set)) (cons (car set) (set-keep keep? (cdr set))))
        (else              (set-keep keep? (cdr set)))))

(define (set-every? pred? set)
  (or (null? set)
      (and (pred? (car set))
           (set-every? pred? (cdr set)))))

(define (set-map proc set)
  (if (null? set)
    '()
    (cons (proc (car set)) (set-map proc (cdr set)))))

;------------------------------------------------------------------------------
;
; QUEUE manipulation stuff
; ------------------------

(define (list->queue list)    ; convert list to queue
  (define (last-pair l)
    (if (pair? (cdr l)) (last-pair (cdr l)) l))
  (cons list (if (pair? list) (last-pair list) '())))

(define (queue->list queue)   ; convert queue to list
  (car queue))

(define (queue-empty)         ; the empty queue
  (cons '() '()))

(define (queue-empty? queue)  ; is the queue empty?
  (null? (car queue)))

(define (queue-get! queue)    ; remove the first element of the queue
  (if (null? (car queue))
    (compiler-internal-error "queue-get!, queue is empty")
    (let ((x (caar queue)))
      (set-car! queue (cdar queue))
      (if (null? (car queue)) (set-cdr! queue '()))
      x)))

(define (queue-put! queue x)  ; add an element to the end of the queue
  (let ((entry (cons x '())))
    (if (null? (car queue))
      (set-car! queue entry)
      (set-cdr! (cdr queue) entry))
    (set-cdr! queue entry)
    x))

;==============================================================================