srfi1.scm

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

	      (values (cons a cars) (cons d cdrs)))))
	(values '() '()))))

(define-private (%cars+cdrs/no-test/pair lists)
  (let-values (((cars cdrs) (%cars+cdrs/no-test lists)))
    (cons cars cdrs)))

;;; count
;;;;;;;;;
(define (count pred :: <procedure> list1 . lists)
  (if (pair? lists)

      ;; N-ary case
      (let lp ((list1 list1) (lists lists) (i 0))
	(if (null-list? list1) 
            i
            (let* ((split (%cars+cdrs/pair lists))
                   (a-s (car split))
                   (d-s (cdr split)))
	      (if (null? a-s) i
		  (lp (cdr list1) 
                      d-s
		      (if (apply pred (car list1) a-s)
                          (+ i 1) 
                          i))))))

      ;; Fast path
      (let lp ((lis list1) (i 0))
	(if (null-list? lis) i
	    (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))))


;;; fold/unfold
;;;;;;;;;;;;;;;

(define (unfold-right p :: <procedure> f :: <procedure> g :: <procedure> seed #!optional (maybe-tail '()))
  (let lp ((seed seed) (ans maybe-tail))
    (if (p seed) ans
	(lp (g seed)
	    (cons (f seed) ans)))))


(define (unfold p :: <procedure> f :: <procedure> g :: <procedure> seed . maybe-tail-gen)
  (if (pair? maybe-tail-gen)

      (let ((tail-gen (car maybe-tail-gen)))
	(if (pair? (cdr maybe-tail-gen))
	    (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)

	    (let recur ((seed seed) (res '()))
	      (if (p seed) 
                  (append-reverse! res (tail-gen seed))
                  (recur (g seed) (cons (f seed) res))))))

      (let recur ((seed seed) (res '()))
	(if (p seed) 
            (reverse! res)
	    (recur (g seed) (cons (f seed) res))))))

(define (fold kons :: <procedure> knil lis1 . lists)
  (if (pair? lists)
      (let lp ((lists (cons lis1 lists)) (ans knil))	; N-ary case
	(receive (cars+ans cdrs) (%cars+cdrs+ lists ans)
	  (if (null? cars+ans) ans ; Done.
	      (lp cdrs (apply kons cars+ans)))))
	    
      (let lp ((lis lis1) (ans knil))			; Fast path
	(if (null-list? lis) ans
	    (lp (cdr lis) (kons (car lis) ans))))))


(define (fold-right kons :: <procedure> knil lis1 . lists)
  (if (pair? lists)
      (let recur ((lists (cons lis1 lists)))		; N-ary case
	(let ((cdrs (%cdrs lists)))
	  (if (null? cdrs) knil
	      (apply kons (%cars+ lists (recur cdrs))))))

      (let recur ((lis lis1))				; Fast path
	(if (null-list? lis) knil
	    (let ((head (car lis)))
	      (kons head (recur (cdr lis))))))))


(define (pair-fold-right f :: <procedure> zero lis1 . lists)
  (if (pair? lists)
      (let recur ((lists (cons lis1 lists)))		; N-ary case
	(let ((cdrs (%cdrs lists)))
	  (if (null? cdrs) zero
	      (apply f (append! lists (list (recur cdrs)))))))

      (let recur ((lis lis1))				; Fast path
	(if (null-list? lis) zero (f lis (recur (cdr lis)))))))

(define (pair-fold f :: <procedure> zero lis1 . lists)
  (if (pair? lists)
      (let lp ((lists (cons lis1 lists)) (ans zero))	; N-ary case
	(let ((tails (%cdrs lists)))
	  (if (null? tails) ans
	      (lp tails (apply f (append! lists (list ans)))))))

      (let lp ((lis lis1) (ans zero))
	(if (null-list? lis) ans
	    (let ((tail (cdr lis)))		; Grab the cdr now,
	      (lp tail (f lis ans)))))))	; in case F SET-CDR!s LIS.
      

;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
;;; These cannot meaningfully be n-ary.

(define (reduce f :: <procedure> ridentity lis)
  (if (null-list? lis) ridentity
      (fold f (car lis) (cdr lis))))

(define (reduce-right f :: <procedure> ridentity lis)
  (if (null-list? lis) ridentity
      (let recur ((head (car lis)) (lis (cdr lis)))
	(if (pair? lis)
	    (f head (recur (car lis) (cdr lis)))
	    head))))



;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (append-map f lis1 . lists)
  (if (pair? lists)
      (apply append (apply map f lis1 lists))
      (apply append (map f lis1))))

(define (append-map! f lis1 . lists)
  (if (pair? lists)
      (apply append! (apply map f lis1 lists))
      (apply append! (map f lis1))))

(define (pair-for-each proc :: <procedure> lis1 . lists)
  (if (pair? lists)

      (let lp ((lists (cons lis1 lists)))
	(let ((tails (%cdrs lists)))
	  (if (pair? tails)
	      (begin (apply proc lists)
		     (lp tails)))))

      ;; Fast path.
      (let lp ((lis lis1))
	(if (not (null-list? lis))
	    (let ((tail (cdr lis)))	; Grab the cdr now,
	      (proc lis)		; in case PROC SET-CDR!s LIS.
	      (lp tail))))))

;;; We stop when LIS1 runs out, not when any list runs out.
(define (map! f :: <procedure> lis1 . lists)
  (if (pair? lists)
      (let lp ((lis1 lis1) (lists lists))
	(if (not (null-list? lis1))
            (let* ((split (%cars+cdrs/no-test/pair lists))
                   (heads (car split))
                   (tails (cdr split)))
	      (set-car! lis1 (apply f (car lis1) heads))
	      (lp (cdr lis1) tails))))

      ;; Fast path.
      (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
  lis1)


;;; Map F across L, and save up all the non-false results.
(define (filter-map f :: <procedure> lis1 . lists)
  (if (pair? lists)
      (let recur ((lists (cons lis1 lists)) (res '()))
	(receive (cars cdrs) (%cars+cdrs lists)
                 (if (not-pair? cars)
                     (reverse! res)
                     (let ((head (apply f cars)))
                       (if head
                           (recur cdrs (cons head res))
                           (recur cdrs res))))))
      ;; Fast path.
      (let recur ((lis lis1) (res '()))
        (if (null-list? lis) 
            (reverse! res)
            (let ((head (f (car lis)))
                  (tail (cdr lis)))
              (if head
                  (recur tail (cons head res))
                  (recur tail res)))))))




;;; Map F across lists, guaranteeing to go left-to-right.
;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
;;; in which case this procedure may simply be defined as a synonym for MAP.

; COMMENTED OUT BY MARCO VEZZOLI FOR KAWA
; (define (map-in-order f :: <procedure> lis1 . lists)
;   (if (pair? lists)
;       (let recur ((lists (cons lis1 lists)))
; 	(receive (cars cdrs) (%cars+cdrs lists)
; 	  (if (pair? cars)
; 	      (let ((x (apply f cars)))		; Do head first,
; 		(cons x (recur cdrs)))		; then tail.
; 	      '())))
	    
;       ;; Fast path.
;       (let recur ((lis lis1))
; 	(if (null-list? lis) lis
; 	    (let ((tail (cdr lis))
; 		  (x (f (car lis))))		; Do head first,
; 	      (cons x (recur tail)))))))	; then tail.

(define map-in-order map)

;;; filter, remove, partition
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
;;; disorder the elements of their argument.

;; Simple filter that uses cons even if the tail of the list can be
;; shared

(define (filter pred :: <procedure> lis) 
  (let recur ((lis lis) (res '()))
    (if (null-list? lis) 
        (reverse! res)
	(let ((head (car lis))
	      (tail (cdr lis)))
	  (if (pred head)
              (recur tail (cons head res))
              (recur tail res))))))


;;; Another version that shares longest tail.
;(define (filter pred lis)
;  (receive (ans no-del?)
;      ;; (recur l) returns L with (pred x) values filtered.
;      ;; It also returns a flag NO-DEL? if the returned value
;      ;; is EQ? to L, i.e. if it didn't have to delete anything.
;      (let recur ((l l))
;	(if (null-list? l) (values l #t)
;	    (let ((x  (car l))
;		  (tl (cdr l)))
;	      (if (pred x)
;		  (receive (ans no-del?) (recur tl)
;		    (if no-del?
;			(values l #t)
;			(values (cons x ans) #f)))
;		  (receive (ans no-del?) (recur tl) ; Delete X.
;		    (values ans #f))))))
;    ans))



;(define (filter! pred lis)			; Things are much simpler
;  (let recur ((lis lis))			; if you are willing to
;    (if (pair? lis)				; push N stack frames & do N
;        (cond ((pred (car lis))		; SET-CDR! writes, where N is
;               (set-cdr! lis (recur (cdr lis))); the length of the answer.
;               lis)				
;              (else (recur (cdr lis))))
;        lis)))


;;; This implementation of FILTER!
;;; - doesn't cons, and uses no stack;
;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are 
;;;   usually expensive on modern machines, and can be extremely expensive on 
;;;   modern Schemes (e.g., ones that have generational GC's).
;;; It just zips down contiguous runs of in and out elts in LIS doing the 
;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the 
;;; beginning of the next.

(define (filter! pred :: <procedure> lis)
  (let lp ((ans lis))
    (cond ((null-list? ans)       ans)			; Scan looking for
	  ((not (pred (car ans))) (lp (cdr ans)))	; first cons of result.

	  ;; ANS is the eventual answer.
	  ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
	  ;;          Scan over a contiguous segment of the list that
	  ;;          satisfies PRED.
	  ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
	  ;;           segment of the list that *doesn't* satisfy PRED.
	  ;;           When the segment ends, patch in a link from PREV
	  ;;           to the start of the next good segment, and jump to
	  ;;           SCAN-IN.
	  (else (letrec ((scan-in (lambda (prev lis)
				    (if (pair? lis)
					(if (pred (car lis))
					    (scan-in lis (cdr lis))
					    (scan-out prev (cdr lis))))))
			 (scan-out (lambda (prev lis)
				     (let lp ((lis lis))
				       (if (pair? lis)
					   (if (pred (car lis))
					       (begin (set-cdr! prev lis)
						      (scan-in lis (cdr lis)))
					       (lp (cdr lis)))
					   (set-cdr! prev lis))))))
		  (scan-in ans (cdr ans))
		  ans)))))



(define (partition pred :: <procedure> lis)
  (let loop ((lis lis) (in '()) (out '()))
    (if (null-list? lis)
        (values (reverse! in) (reverse! out))
        (let ((head (car lis))
	      (tail (cdr lis)))
          (if (pred head)
              (loop tail (cons head in) out)
              (loop tail in (cons head out)))))))

;(define (partition! pred lis)			; Things are much simpler
;  (let recur ((lis lis))			; if you are willing to
;    (if (null-list? lis) (values lis lis)	; push N stack frames & do N
;        (let ((elt (car lis)))			; SET-CDR! writes, where N is
;          (receive (in out) (recur (cdr lis))	; the length of LIS.
;            (cond ((pred elt)
;                   (set-cdr! lis in)
;                   (values lis out))
;                  (else (set-cdr! lis out)
;                        (values in lis))))))))


;; A simple version of PARTITION! that Kawa can compile down to
;; iterative code.  It's possible to make this slightly more efficient
;; but it doesn't seem to run much faster.  We are not careful about
;; running set-cdr!.
(define (partition! pred :: <procedure> lis)
  (let ((in-head (cons 'tmp '())) (out-head (cons 'tmp '())))
    (let loop ((in in-head) (out out-head) (lis lis))
      (if (not-pair? lis)
          (begin
            (set-cdr! in '())
            (set-cdr! out '())
            (values (cdr in-head) (cdr out-head)))
	(if (pred (car lis))
              (begin
                (set-cdr! in lis)
                (loop lis out (cdr lis)))
              (begin
                (set-cdr! out lis)
                (loop in lis (cdr lis))))))))


#|
;;; This implementation of PARTITION!
;;; - doesn't cons, and uses no stack;
;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
;;;   usually expensive on modern machines, and can be extremely expensive on 
;;;   modern Schemes (e.g., ones that have generational GC's).
;;; It just zips down contiguous runs of in and out elts in LIS doing the
;;; minimal number of SET-CDR!s to splice these runs together into the result 
;;; lists.

(define (partition! pred :: <procedure> lis)
  (if (null-list? lis) (values lis lis)

      ;; This pair of loops zips down contiguous in & out runs of the
      ;; list, splicing the runs together. The invariants are
      ;;   SCAN-IN:  (cdr in-prev)  = LIS.
      ;;   SCAN-OUT: (cdr out-prev) = LIS.
      (letrec ((scan-in (lambda (in-prev out-prev lis)
			  (let lp ((in-prev in-prev) (lis lis))
			    (if (pair? lis)
				(if (pred (car lis))
				    (lp lis (cdr lis))
				    (begin (set-cdr! out-prev lis)
					   (scan-out in-prev lis (cdr lis))))
				(set-cdr! out-prev lis))))) ; Done.

	       (scan-out (lambda (in-prev out-prev lis)
			   (let lp ((out-prev out-prev) (lis lis))
			     (if (pair? lis)
				 (if (pred (car lis))
				     (begin (set-cdr! in-prev lis)
					    (scan-in lis out-prev (cdr lis)))
				     (lp lis (cdr lis)))
				 (set-cdr! in-prev lis)))))) ; Done.

	Crank up the scan&splice loops.
	(if (pred (car lis))
	    ;; LIS begins in-list. Search for out-list's first pair.
	    (let lp ((prev-l lis) (l (cdr lis)))
	      (cond ((not (pair? l)) (values lis l))
		    ((pred (car l)) (lp l (cdr l)))
		    (else (scan-out prev-l l (cdr l))
			  (values lis l))))	; Done.

	    ;; LIS begins out-list. Search for in-list's first pair.
	    (let lp ((prev-l lis) (l (cdr lis)))
	      (cond ((not (pair? l)) (values l lis))
		    ((pred (car l))
		     (scan-in l prev-l (cdr l))