sunet/scheme/xml/plt.scm

; Taken directly from the SRFI document.

(define-syntax let-values
  (syntax-rules ()
    ((let-values (?binding ...) ?body0 ?body1 ...)
     (let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
    
    ((let-values "bind" () ?tmps ?body)
     (let ?tmps ?body))
    
    ((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
     (let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
    
    ((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
     (call-with-values 
       (lambda () ?e0)
       (lambda ?args
         (let-values "bind" ?bindings ?tmps ?body))))
    
    ((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
     (let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
    
    ((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
     (call-with-values
       (lambda () ?e0)
       (lambda (?arg ... . x)
         (let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))

(define-syntax let*-values
  (syntax-rules ()
    ((let*-values () ?body0 ?body1 ...)
     (begin ?body0 ?body1 ...))

    ((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...)
     (let-values (?binding0)
       (let*-values (?binding1 ...) ?body0 ?body1 ...)))))

(define (add1 x) (+ x 1))
(define (sub1 x) (- x 1))

(define-syntax when
  (syntax-rules 
   ()
   ((when test expr ...)
    (if test (begin expr ...)))))

(define-syntax unless
  (syntax-rules
   ()
   ((unless test expr ...)
    (if (not test) (begin expr ...)))))

(define (void . a) 
  (if #f #f))

(define-syntax begin0
  (syntax-rules
   ()
   ((begin0 expr1 expr ...)
    (let ((r expr1))
      (begin expr ...)
      r))))

(define andmap
  (lambda (f list0 . lists)
    (if (null? list0)
	(and)
	(let loop ((lists (cons list0 lists)))
	  (if (null? (cdr (car lists)))
	      (apply f (map car lists))
	      (and (apply f (map car lists))
		   (loop (map cdr lists))))))))
(define null '())

; stolen from mzlib/functior.ss
(define (quicksort l less-than)
  (let* ((v (list->vector l))
	 (count (vector-length v)))
    (let loop ((min 0)(max count))
      (if (< min (sub1 max))
	  (let ((pval (vector-ref v min)))
	    (let pivot-loop ((pivot min)
			     (pos (add1 min)))
	      (if (< pos max)
		  (let ((cval (vector-ref v pos)))
		    (if (less-than cval pval)
			(begin
			  (vector-set! v pos (vector-ref v pivot))
                               (vector-set! v pivot cval)
                               (pivot-loop (add1 pivot) (add1 pos)))
			(pivot-loop pivot (add1 pos))))
		  (if (= min pivot)
		      (loop (add1 pivot) max)
		      (begin
			(loop min pivot)
			(loop pivot max))))))))
    (vector->list v)))

;;; HACK!
(define call/ec call-with-current-continuation)
(define-syntax let/ec
  (syntax-rules
   ()
   ((let/ec k expr ...)
    (call-with-current-continuation (lambda (k) expr ...)))))


;;; HACK!
(define (make-parameter val)
  (lambda ()
    val))

(define (list* . args)
  (if (null? (cdr args))
      (car args)
      (cons (car args) (apply list* (cdr args)))))

(define (format str . args)
  (apply (structure-ref big-scheme format) #f str args))

(define fprintf (structure-ref big-scheme format))

(define foldr (structure-ref list-lib fold-right))

(define regexp posix-string->regexp)

;;; convert "\\1y \\2" to '(1 "y " 2)
(define (convert-string str)
  (let ((e.s 
	 (regexp-fold (rx (: "\\" numeric)) 
		      (lambda (s m nil) 
			(cons (match:end m) 
			      (append (cdr nil)
				      (list (substring str (car nil) (match:start m))
					    (string->number 
					     (string-drop (match:substring m) 2))))))
		      (cons 0 '())  str)))
    (append (cdr e.s) (list (substring str (car e.s) (string-length str))))))

;;; does not handle &
(define (regexp-replace* pattern string insert-string)
  (apply regexp-substitute/global #f pattern string 
	 (append (cons 'pre (convert-string insert-string)) (list 'post))))

(define (compose f g)
  (lambda (x) 
    (call-with-values (lambda () (g x)) f)))

(define open-output-string make-string-output-port)
(define get-output-string string-output-port-output)