scsh-0.5/big/big-util.scm

; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


(define (concatenate-symbol . stuff)
  (string->symbol
   (apply string-append
	  (map (lambda (x)
		 (cond ((string? x) x)
		       ((symbol? x) (symbol->string x))
		       ((number? x) (number->string x))
		       (else
			(error "cannot coerce ~S to a string" x))))
	       stuff))))

(define (error format-string . args)
  ((structure-ref signals error)
   (apply format (cons #f (cons format-string args)))))

(define (breakpoint format-string . args)
  ((structure-ref debugging breakpoint) 
   (apply format (cons #f (cons format-string args)))))

; For macro expanders

(define (syntax-error message form)
  (error "syntax error: ~A ~S" message form))

(define (atom? x)
  (not (pair? x)))

(define (neq? x y)
  (not (eq? x y)))

(define (n= x y)
  (not (= x y)))

(define (identity x) x)

(define (no-op x) x)    ; guaranteed not to be in-lined

(define (null-list? x)
  (cond ((null? x) #t)
	((pair? x) #f)
	(error "null-list? got a non-list" x)))

(define (reverse! l)
  (cond ((or (null? l)
	     (null? (cdr l)))
	 l)
	(else
	 (let ((rest (cdr l)))
	   (set-cdr! l '())
	   (let loop ((l1 l) (l2 rest))
	     (cond ((null? l2)
		    l1)
		   (else
		    (let ((rest (cdr l2)))
		      (set-cdr! l2 l1)
		      (loop l2 rest)))))))))

(define (memq? x l)
  (let loop ((l l))
    (cond ((null? l)       #f)
	  ((eq? x (car l)) #t)
	  (else            (loop (cdr l))))))

(define (first pred list)
  (let loop ((list list))
    (cond ((null? list)
	   #f)
          ((pred (car list))
	   (car list))
          (else
	   (loop (cdr list))))))

(define any first)  ; ANY? need not search in order, but it does anyway

(define (any? proc list)
  (let loop ((list list))
    (cond ((null? list)
	   #f)
          ((proc (car list))
	   #t)
          (else
	   (loop (cdr list))))))

(define (every? pred list)
  (let loop ((list list))
    (cond ((null? list)
	   #t)
          ((pred (car list))
	   (loop (cdr list)))
          (else
	   #f))))

(define (filter pred l)
  (let loop ((l l) (r '()))
    (cond ((null? l)
	   (reverse r))
          ((pred (car l))
	   (loop (cdr l) (cons (car l) r)))
          (else
	   (loop (cdr l) r)))))

(define (filter! pred list)
  (let filter! ((list list))
    (cond ((null-list? list)
	   '())
          ((pred (car list))
	   (set-cdr! list (filter! (cdr list))) list)
          (else
	   (filter! (cdr list))))))

(define (filter-map f l)
  (let loop ((l l) (r '()))
    (cond ((null? l)
	   (reverse r))
          ((f (car l))
           => (lambda (x)
                (loop (cdr l) (cons x r))))
          (else
	   (loop (cdr l) r)))))

(define (remove-duplicates list)
  (do ((list list (cdr list))
       (res  '()  (if (memq? (car list) res)
                      res
                      (cons (car list) res))))
      ((null-list? list)
       res)))

(define (partition-list pred l)
  (let loop ((l l) (yes '()) (no '()))
    (cond ((null? l)
           (values (reverse yes) (reverse no)))
          ((pred (car l))
           (loop (cdr l) (cons (car l) yes) no))
          (else
           (loop (cdr l) yes (cons (car l) no))))))

(define (partition-list! pred l)
  (let loop ((l l) (yes '()) (no '()))
    (cond ((null? l)
           (values (reverse! yes) (reverse! no)))
          ((pred (car l))
	   (let ((rest (cdr l)))
	     (set-cdr! l yes)
	     (loop rest l no)))
          (else
	   (let ((rest (cdr l)))
	     (set-cdr! l no)
	     (loop rest yes l))))))

(define (delq! object list)
  (let loop ((list list))
    (cond ((null? list)
	   '())
	  ((eq? object (car list))
	   (loop (cdr list)))
	  (else
	   (let loop ((next (cdr list)) (prev list))
	     (cond ((null? next)
		    list)
		   ((eq? (car next) object)
		    (set-cdr! prev (cdr next))
		    (loop (cdr next) prev))
		   (else
		    (loop (cdr next) next))))))))

(define (delq thing list)
  (delete (lambda (x) (eq? x thing)) list))

(define (append-reverse! l1 l2)
  (let loop ((list l1) (res l2))
    (if (pair? list)
	(let ((next (cdr list)))
	  (set-cdr! list res)
	  (loop next list))
	res)))

;; This DELETE shares the longest tail of L that has no deleted elements.
;; If we had multi-continuation calls, this could be made more efficient.

(define (delete pred l)
  (call-with-values (lambda ()
		      ;; (recur l) returns L with (pred x) values deleted.
		      ;; It also returns a flag NO-DEL? if the returned value
		      ;; is EQ? to L, i.e. if it didn't delete anything.
		      (let recur ((l l))
			(if (pair? l)
			    (let ((x (car l))
				  (tl (cdr l)))
			      (if (pred x)
				  (call-with-values (lambda () (recur tl))
				    (lambda (ans no-del?)
				      (values ans #f))) ; Deleted X.
				  (call-with-values (lambda () (recur tl))
				    (lambda (ans no-del?)
				      (if no-del?
					  (values l #t)
					  (values (cons x ans) #f))))))
			    (values '() #t))))
    (lambda (ans no-del?) ans)))