a3d00a910a
Also, removed the LGPL blurbs from srfi/1, and redirect to the Racket license. (To avoid possible future issues with license changes, such as LGPL version.)
109 lines
3.9 KiB
Racket
109 lines
3.9 KiB
Racket
;;;
|
|
;;; <util.ss> ---- Utility functions
|
|
;;; Time-stamp: <02/02/28 12:05:00 noel>
|
|
;;;
|
|
;;; Copyright (C) 2002 by Noel Welsh.
|
|
;;;
|
|
;;; This file is part of SRFI-1.
|
|
|
|
;;; This SRFI-1 implementation is distributed under the same terms as
|
|
;;; Racket.
|
|
|
|
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
|
|
|
|
;; Commentary:
|
|
|
|
;; Based on the reference implementation by Olin Shiver and hence:
|
|
|
|
;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
|
|
;; this code as long as you do not remove this copyright notice or
|
|
;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
|
|
;; -Olin
|
|
|
|
;; Olin Shivers verified that he is fine with redistributing this code
|
|
;; under the LGPL. (Verified personally by Eli Barzilay.)
|
|
|
|
#lang scheme/base
|
|
|
|
(require "predicate.ss"
|
|
"selector.ss")
|
|
|
|
(provide %cdrs
|
|
%cars+
|
|
%cars+cdrs
|
|
%cars+cdrs+
|
|
%cars+cdrs/no-test)
|
|
|
|
;; 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 (%cdrs lists)
|
|
(let/ec abort
|
|
(let recur ((lists lists))
|
|
(if (pair? lists)
|
|
(let ((lis (car lists)))
|
|
(if (null-list? lis) (abort '())
|
|
(cons (cdr lis) (recur (cdr lists)))))
|
|
'()))))
|
|
|
|
(define (%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 (%cars+cdrs lists)
|
|
(let/ec abort
|
|
(let recur ((lists lists))
|
|
(if (pair? lists)
|
|
(let-values ([(list other-lists) (car+cdr lists)])
|
|
(if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
|
|
(let-values ([(a d) (car+cdr list)]
|
|
[(cars cdrs) (recur other-lists)])
|
|
(values (cons a cars) (cons d cdrs)))))
|
|
(values '() '())))))
|
|
|
|
;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
|
|
;; cars list. What a hack.
|
|
(define (%cars+cdrs+ lists cars-final)
|
|
(let/ec abort
|
|
(let recur ((lists lists))
|
|
(if (pair? lists)
|
|
(let-values ([(list other-lists) (car+cdr lists)])
|
|
(if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
|
|
(let-values ([(a d) (car+cdr list)]
|
|
[(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 (%cars+cdrs/no-test lists)
|
|
(let recur ((lists lists))
|
|
(if (pair? lists)
|
|
(let*-values ([(list other-lists) (car+cdr lists)]
|
|
[(a d) (car+cdr list)]
|
|
[(cars cdrs) (recur other-lists)])
|
|
(values (cons a cars) (cons d cdrs)))
|
|
(values '() '()))))
|
|
|
|
;;; util.ss ends here
|