srfi1.scm

A framework written in Java for implementing high-level and dynamic languages, compiling them into J

;;; This is a legal definition which is fast and sloppy:
;;;     (define null-list? not-pair?)
;;; but we'll provide a more careful one:
;(define (null-list? l)
;  (cond ((pair? l) #f)
;	((null? l) #t)
;	(else (error "null-list?: argument out of domain" l))))
;; let's at least inline
(define (null-list? l)
  (cond ((instance? l <pair>) #f)
	((eq? l '()) #t)
	(else (error "null-list?: argument out of domain" l))))
           

(define (list= = . lists)
  (or (null? lists) ; special case

      (let lp1 ((list-a (car lists)) (others (cdr lists)))
	(or (null? others)
	    (let ((list-b (car others))
		  (others (cdr others)))
	      (if (eq? list-a list-b)	; EQ? => LIST=
		  (lp1 list-b others)
		  (let lp2 ((list-a list-a) (list-b list-b))
		    (if (null-list? list-a)
			(and (null-list? list-b)
			     (lp1 list-b others))
			(and (not (null-list? list-b))
			     (= (car list-a) (car list-b))
			     (lp2 (cdr list-a) (cdr list-b)))))))))))
			


;;; R4RS, so commented out.
;(define (length x)			; LENGTH may diverge or
;  (let lp ((x x) (len 0))		; raise an error if X is
;    (if (pair? x)			; a circular list. This version
;        (lp (cdr x) (+ len 1))		; diverges.
;        len)))

(define (length+ x)			; Returns #f if X is circular.
  (let lp ((x x) (lag x) (len 0))
    (if (pair? x)
	(let ((x (cdr x))
	      (len (+ len 1)))
	  (if (pair? x)
	      (let ((x   (cdr x))
		    (lag (cdr lag))
		    (len (+ len 1)))
		(and (not (eq? x lag)) (lp x lag len)))
	      len))
	len)))

(define (zip list1 . more-lists) (apply map list list1 more-lists))


;;; Selectors
;;;;;;;;;;;;;

;;; R4RS non-primitives:
;(define (caar   x) (car (car x)))
;(define (cadr   x) (car (cdr x)))
;(define (cdar   x) (cdr (car x)))
;(define (cddr   x) (cdr (cdr x)))
;
;(define (caaar  x) (caar (car x)))
;(define (caadr  x) (caar (cdr x)))
;(define (cadar  x) (cadr (car x)))
;(define (caddr  x) (cadr (cdr x)))
;(define (cdaar  x) (cdar (car x)))
;(define (cdadr  x) (cdar (cdr x)))
;(define (cddar  x) (cddr (car x)))
;(define (cdddr  x) (cddr (cdr x)))
;
;(define (caaaar x) (caaar (car x)))
;(define (caaadr x) (caaar (cdr x)))
;(define (caadar x) (caadr (car x)))
;(define (caaddr x) (caadr (cdr x)))
;(define (cadaar x) (cadar (car x)))
;(define (cadadr x) (cadar (cdr x)))
;(define (caddar x) (caddr (car x)))
;(define (cadddr x) (caddr (cdr x)))
;(define (cdaaar x) (cdaar (car x)))
;(define (cdaadr x) (cdaar (cdr x)))
;(define (cdadar x) (cdadr (car x)))
;(define (cdaddr x) (cdadr (cdr x)))
;(define (cddaar x) (cddar (car x)))
;(define (cddadr x) (cddar (cdr x)))
;(define (cdddar x) (cdddr (car x)))
;(define (cddddr x) (cdddr (cdr x)))


(define first  car)
(define second cadr)
(define third  caddr)
(define fourth cadddr)
(define (fifth   x) (car    (cddddr x)))
(define (sixth   x) (cadr   (cddddr x)))
(define (seventh x) (caddr  (cddddr x)))
(define (eighth  x) (cadddr (cddddr x)))
(define (ninth   x) (car  (cddddr (cddddr x))))
(define (tenth   x) (cadr (cddddr (cddddr x))))

(define (car+cdr pair) (values (car pair) (cdr pair)))

;;; take & drop

(define (take lis k :: <integer>)
  (let recur ((lis lis) (k k) (res '()))
    (if (zero? k) 
        (reverse! res)
        (recur (cdr lis) (- k 1) (cons (car lis) res)))))

(define (drop lis k :: <integer>)
  (let iter ((lis lis) (k k))
    (if (zero? k) lis (iter (cdr lis) (- k 1)))))

(define (take! lis k :: <integer>)
  (if (zero? k) '()
      (begin (set-cdr! (drop lis (- k 1)) '())
	     lis)))

;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, 
;;; off by K, then chasing down the list until the lead pointer falls off
;;; the end.

(define (take-right lis k :: <integer>)
  (let lp ((lag lis)  (lead (drop lis k)))
    (if (pair? lead)
	(lp (cdr lag) (cdr lead))
	lag)))

(define (drop-right lis k :: <integer>)
  (let recur ((lag lis) (lead (drop lis k)))
    (if (pair? lead)
	(cons (car lag) (recur (cdr lag) (cdr lead)))
	'())))

;;; In this function, LEAD is actually K+1 ahead of LAG. This lets
;;; us stop LAG one step early, in time to smash its cdr to ().
(define (drop-right! lis k :: <integer>)
  (let ((lead (drop lis k)))
    (if (pair? lead)

	(let lp ((lag lis)  (lead (cdr lead)))	; Standard case
	  (if (pair? lead)
	      (lp (cdr lag) (cdr lead))
	      (begin (set-cdr! lag '())
		     lis)))

	'())))	; Special case dropping everything -- no cons to side-effect.

;(define (list-ref lis i) (car (drop lis i)))	; R4RS

;;; These use the APL convention, whereby negative indices mean 
;;; "from the right." I liked them, but they didn't win over the
;;; SRFI reviewers.
;;; K >= 0: Take and drop  K elts from the front of the list.
;;; K <= 0: Take and drop -K elts from the end   of the list.

;(define (take lis k)
;  (check-arg integer? k take)
;  (if (negative? k)
;      (list-tail lis (+ k (length lis)))
;      (let recur ((lis lis) (k k))
;	(if (zero? k) '()
;	    (cons (car lis)
;		  (recur (cdr lis) (- k 1)))))))
;
;(define (drop lis k)
;  (check-arg integer? k drop)
;  (if (negative? k)
;      (let recur ((lis lis) (nelts (+ k (length lis))))
;	(if (zero? nelts) '()
;	    (cons (car lis)
;		  (recur (cdr lis) (- nelts 1)))))
;      (list-tail lis k)))
;
;
;(define (take! lis k)
;  (check-arg integer? k take!)
;  (cond ((zero? k) '())
;	((positive? k)
;	 (set-cdr! (list-tail lis (- k 1)) '())
;	 lis)
;	(else (list-tail lis (+ k (length lis))))))
;
;(define (drop! lis k)
;  (check-arg integer? k drop!)
;  (if (negative? k)
;      (let ((nelts (+ k (length lis))))
;	(if (zero? nelts) '()
;	    (begin (set-cdr! (list-tail lis (- nelts 1)) '())
;		   lis)))
;      (list-tail lis k)))

(define (split-at x k :: <integer>)
  (let recur ((prefix '()) (suffix x) (k k))
    (if (zero? k) 
        (values (reverse! prefix) suffix)
        (recur (cons (car suffix) prefix) (cdr suffix) (- k 1)))))

(define (split-at! x k :: <integer>)
  (if (zero? k) (values '() x)
      (let* ((prev (drop x (- k 1)))
	     (suffix (cdr prev)))
	(set-cdr! prev '())
	(values x suffix))))


(define (last lis) (car (last-pair lis)))

(define (last-pair lis :: <pair>)
  (let lp ((lis lis))
    (let ((tail (cdr lis)))
      (if (pair? tail) (lp tail) lis))))


;;; Unzippers -- 1 through 5
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (unzip1 lis) (map car lis))

(define (unzip2 lis)
  (let recur ((lis lis))
    (if (null-list? lis) (values lis lis)	; Use NOT-PAIR? to handle
	(let ((elt (car lis)))			; dotted lists.
	  (receive (a b) (recur (cdr lis))
	    (values (cons (car  elt) a)
		    (cons (cadr elt) b)))))))

(define (unzip3 lis)
  (let recur ((lis lis))
    (if (null-list? lis) (values lis lis lis)
	(let ((elt (car lis)))
	  (receive (a b c) (recur (cdr lis))
	    (values (cons (car   elt) a)
		    (cons (cadr  elt) b)
		    (cons (caddr elt) c)))))))

(define (unzip4 lis)
  (let recur ((lis lis))
    (if (null-list? lis) (values lis lis lis lis)
	(let ((elt (car lis)))
	  (receive (a b c d) (recur (cdr lis))
	    (values (cons (car    elt) a)
		    (cons (cadr   elt) b)
		    (cons (caddr  elt) c)
		    (cons (cadddr elt) d)))))))

(define (unzip5 lis)
  (let recur ((lis lis))
    (if (null-list? lis) (values lis lis lis lis lis)
	(let ((elt (car lis)))
	  (receive (a b c d e) (recur (cdr lis))
	    (values (cons (car     elt) a)
		    (cons (cadr    elt) b)
		    (cons (caddr   elt) c)
		    (cons (cadddr  elt) d)
		    (cons (car (cddddr  elt)) e)))))))


;;; append! append-reverse append-reverse! concatenate concatenate!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (append! . lists)
  ;; First, scan through lists looking for a non-empty one.
  (let lp ((lists lists) (prev '()))
    (if (not (pair? lists)) prev
	(let ((first (car lists))
	      (rest (cdr lists)))
	  (if (not (pair? first)) (lp rest first)

	      ;; Now, do the splicing.
	      (let lp2 ((tail-cons (last-pair first))
			(rest rest))
		(if (pair? rest)
		    (let ((next (car rest))
			  (rest (cdr rest)))
		      (set-cdr! tail-cons next)
		      (lp2 (if (pair? next) (last-pair next) tail-cons)
			   rest))
		    first)))))))

;;; APPEND is R4RS.
;(define (append . lists)
;  (if (pair? lists)
;      (let recur ((list1 (car lists)) (lists (cdr lists)))
;        (if (pair? lists)
;            (let ((tail (recur (car lists) (cdr lists))))
;              (fold-right cons tail list1)) ; Append LIST1 & TAIL.
;            list1))
;      '()))

;(define (append-reverse rev-head tail) (fold cons tail rev-head))

;(define (append-reverse! rev-head tail)
;  (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
;             tail
;             rev-head))

;;; Hand-inline the FOLD and PAIR-FOLD ops for speed.

(define (append-reverse rev-head tail)
  (let lp ((rev-head rev-head) (tail tail))
    (if (null-list? rev-head) tail
	(lp (cdr rev-head) (cons (car rev-head) tail)))))

(define (append-reverse! rev-head tail)
  (let lp ((rev-head rev-head) (tail tail))
    (if (null-list? rev-head) tail
	(let ((next-rev (cdr rev-head)))
	  (set-cdr! rev-head tail)
	  (lp next-rev rev-head)))))


(define (concatenate  lists) (reduce-right append  '() lists))
(define (concatenate! lists) (reduce-right append! '() lists))

;;; Fold/map internal utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These little internal utilities are used by the general
;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
;;; One the other hand, the n-ary cases are painfully inefficient as it is.
;;; An aggressive implementation should simply re-write these functions 
;;; for raw efficiency; I have written them for as much clarity, portability,
;;; and simplicity as can be achieved.
;;;
;;; I use the dreaded call/cc to do local aborts. A good compiler could
;;; handle this with extreme efficiency. An implementation that provides
;;; a one-shot, non-persistent continuation grabber could help the compiler
;;; out by using that in place of the call/cc's in these routines.
;;;
;;; These functions have funky definitions that are precisely tuned to
;;; the needs of the fold/map procs -- for example, to minimize the number
;;; of times the argument lists need to be examined.

;;; Return (map cdr lists). 
;;; However, if any element of LISTS is empty, just abort and return '().
(define-private (%cdrs lists)
  (call-with-current-continuation
    (lambda (abort)
      (let recur ((lists lists))
	(if (pair? lists)
	    (let ((lis (car lists)))
	      (if (null-list? lis) (abort '())
		  (cons (cdr lis) (recur (cdr lists)))))
	    '())))))

(define-private (%cars+ lists last-elt)	; (append! (map car lists) (list last-elt))
  (let recur ((lists lists))
    (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))

;;; LISTS is a (not very long) non-empty list of lists.
;;; Return two lists: the cars & the cdrs of the lists.
;;; However, if any of the lists is empty, just abort and return [() ()].

(define-private (%cars+cdrs lists)
  (call-with-current-continuation
    (lambda (abort)
      (let recur ((lists lists))
        (if (pair? lists)
	    (receive (list other-lists) (car+cdr lists)
	      (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
		  (receive (a d) (car+cdr list)
		    (receive (cars cdrs) (recur other-lists)
		      (values (cons a cars) (cons d cdrs))))))
	    (values '() '()))))))

;;; Return the %cars+cdrs result as a pair instead of a multiple value
;;; return.  Kawa finds it easier to optimize a tail recursive loop
;;; when the %cars+cdrs logic is called this way.
(define-private (%cars+cdrs/pair lists)
  (let-values (((cars cdrs) (%cars+cdrs lists)))
    (cons cars cdrs)))

;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
;;; cars list. What a hack.
(define-private (%cars+cdrs+ lists cars-final)
  (call-with-current-continuation
    (lambda (abort)
      (let recur ((lists lists))
        (if (pair? lists)
	    (receive (list other-lists) (car+cdr lists)
	      (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
		  (receive (a d) (car+cdr list)
		    (receive (cars cdrs) (recur other-lists)
		      (values (cons a cars) (cons d cdrs))))))
	    (values (list cars-final) '()))))))

;;; Like %CARS+CDRS, but blow up if any list is empty.
(define-private (%cars+cdrs/no-test lists)
  (let recur ((lists lists))
    (if (pair? lists)
	(receive (list other-lists) (car+cdr lists)
	  (receive (a d) (car+cdr list)
	    (receive (cars cdrs) (recur other-lists)