DataMuseum.dk

top - download

    Length: 10675 (0x29b3)
    Types: TextFile
    Names: »list.scm.49«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/list.scm.49« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; List Operations

(declare (usual-integrations))
\f


(define cons (make-primitive-procedure 'CONS))
(define pair? (make-primitive-procedure 'PAIR?))
(define null? (make-primitive-procedure 'NULL?))
(define length (make-primitive-procedure 'LENGTH))

(define (list . elements)
  elements)

(define (list? frob)
  (disjunction (null? frob)
	       (conjunction (pair? frob)
			    (list? (cdr frob)))))

(define (cons* first-element . rest-elements)
  (let loop ((this-element first-element)
	     (rest-elements rest-elements))
    (if (null? rest-elements)
	this-element
	(cons this-element
	      (loop (car rest-elements)
		    (cdr rest-elements))))))

(define (make-list size #!optional value)
  (subvector->list (vector-cons size (if (unassigned? value) '() value))
		   0
		   size))

(define (list-copy elements)
  (apply list elements))

(define (list-ref l n)
  (car (list-tail l n)))

(define (list-tail l n)
  (if (zero? n)
      l
      (list-tail (cdr l) (-1+ n))))
\f


;;;; Standard Selectors

(define car (make-primitive-procedure 'CAR))
(define cdr (make-primitive-procedure 'CDR))

(define set-car! (make-primitive-procedure 'SET-CAR!))
(define set-cdr! (make-primitive-procedure 'SET-CDR!))

(define general-car-cdr (make-primitive-procedure 'GENERAL-CAR-CDR))

(define (cddr x) (general-car-cdr x #o4))
(define (cdar x) (general-car-cdr x #o5))
(define (cadr x) (general-car-cdr x #o6))
(define (caar x) (general-car-cdr x #o7))

(define (cdddr x) (general-car-cdr x #o10))
(define (cddar x) (general-car-cdr x #o11))
(define (cdadr x) (general-car-cdr x #o12))
(define (cdaar x) (general-car-cdr x #o13))
(define (caddr x) (general-car-cdr x #o14))
(define (cadar x) (general-car-cdr x #o15))
(define (caadr x) (general-car-cdr x #o16))
(define (caaar x) (general-car-cdr x #o17))

(define (cddddr x) (general-car-cdr x #o20))
(define (cdddar x) (general-car-cdr x #o21))
(define (cddadr x) (general-car-cdr x #o22))
(define (cddaar x) (general-car-cdr x #o23))
(define (cdaddr x) (general-car-cdr x #o24))
(define (cdadar x) (general-car-cdr x #o25))
(define (cdaadr x) (general-car-cdr x #o26))
(define (cdaaar x) (general-car-cdr x #o27))
(define (cadddr x) (general-car-cdr x #o30))
(define (caddar x) (general-car-cdr x #o31))
(define (cadadr x) (general-car-cdr x #o32))
(define (cadaar x) (general-car-cdr x #o33))
(define (caaddr x) (general-car-cdr x #o34))
(define (caadar x) (general-car-cdr x #o35))
(define (caaadr x) (general-car-cdr x #o36))
(define (caaaar x) (general-car-cdr x #o37))

(define first car)
(define (second x) (general-car-cdr x #o6))
(define (third x) (general-car-cdr x #o14))
(define (fourth x) (general-car-cdr x #o30))
(define (fifth x) (general-car-cdr x #o60))
(define (sixth x) (general-car-cdr x #o140))
(define (seventh x) (general-car-cdr x #o300))
(define (eighth x) (general-car-cdr x #o600))
\f


;;;; Sequence Operations

(define (append . lists)
  (if (null? lists)
      '()
      (let list-loop ((head (car lists))
		      (tail (cdr lists)))
	   (if (null? tail)
	       head
	       (let append-loop ((list head))
		    (if (null? list)
			(list-loop (car tail)
				   (cdr tail))
			(cons (car list)
			      (append-loop (cdr list)))))))))

(define (append! . lists)
  (let loop ((lists lists))
    (if (null? lists)
	'()
	(if (pair? (car lists))
	    (sequence (set-cdr! (last-pair (car lists))
				(loop (cdr lists)))
		      (car lists))
	    (loop (cdr lists))))))

(define (reverse l)
  (let loop ((rest l)
	     (so-far '()))
    (if (null? rest)
	so-far
	(loop (cdr rest)
	      (cons (car rest) so-far)))))

(define (reverse! l)
  (if (null? l)
      l
      (let loop ((previous-cell '())
		 (this-cell l)
		 (next-cell (cdr l)))
	(set-cdr! this-cell previous-cell)
	(if (null? next-cell)
	    this-cell
	    (loop this-cell next-cell (cdr next-cell))))))
\f


;;;; Mapping Procedures

(define (mapcar f . lists)
  (if (null? lists)
      (error "No arguments to MAPCAR" f)
      (let loop ((lists lists))
	(let scan ((lists lists)
		   (c (lambda (cars cdrs)
			(cons (apply f cars)
			      (loop cdrs)))))
	  (cond ((null? lists) (c '() '()))
		((null? (car lists)) '())
		(else
		 (scan (cdr lists)
		       (lambda (cars cdrs)
			 (c (cons (car (car lists)) cars)
			    (cons (cdr (car lists)) cdrs))))))))))

(define (mapcar* initial-value f . lists)
  (if (null? lists)
      (error "No arguments to MAPCAR*" f)
      (let loop ((lists lists))
	(let scan ((lists lists)
		   (c (lambda (cars cdrs)
			(cons (apply f cars)
			      (loop cdrs)))))
	  (cond ((null? lists) (c '() '()))
		((null? (car lists)) initial-value)
		(else
		 (scan (cdr lists)
		       (lambda (cars cdrs)
			 (c (cons (car (car lists)) cars)
			    (cons (cdr (car lists)) cdrs))))))))))

(define (mapc f . lists)
  (if (null? lists)
      (error "No arguments to MAPC" f)
      (let loop ((lists lists))
	(let scan ((lists lists)
		   (c (lambda (cars cdrs)
			(apply f cars)
			(loop cdrs))))
	  (cond ((null? lists) (c '() '()))
		((null? (car lists)) '())
		(else
		 (scan (cdr lists)
		       (lambda (cars cdrs)
			 (c (cons (car (car lists)) cars)
			    (cons (cdr (car lists)) cdrs)))))))))
  *the-non-printing-object*)
\f


;;;; Generalized List Operations

(define (positive-list-searcher pred if-win if-lose)
  (named-lambda (list-searcher-loop list)
    (if (pair? list)
	(if (pred list)
	    (if-win list)
	    (list-searcher-loop (cdr list)))
	(if-lose))))

(define (negative-list-searcher pred if-win if-lose)
  (named-lambda (list-searcher-loop list)
    (if (pair? list)
	(if (if-win list)
	    (pred list)
	    (list-searcher-loop (cdr list)))
	(if-lose))))

(define (positive-list-transformer predicate tail)
  (named-lambda (list-transform-loop list)
    (if (pair? list)
	(if (predicate (car list))
	    (cons (car list)
		  (list-transform-loop (cdr list)))
	    (list-transform-loop (cdr list)))
	tail)))

(define (negative-list-transformer predicate tail)
  (named-lambda (list-transform-loop list)
    (if (pair? list)
	(if (predicate (car list))
	    (list-transform-loop (cdr list))
	    (cons (car list)
		  (list-transform-loop (cdr list))))
	tail)))

;;; Not so general, but useful.

(define (list-deletor pred)
  (negative-list-transformer pred '()))

(define (list-deletor! pred)
  (define (trim-initial-segment list)
    (if (pair? list)
	(if (pred (car list))
	    (trim-initial-segment (cdr list))
	    (sequence (locate-initial-segment list (cdr list))
		      list))
	list))
  (define (locate-initial-segment last this)
    (if (pair? this)
	(if (pred (car this))
	    (set-cdr! last (trim-initial-segment (cdr this)))
	    (locate-initial-segment this (cdr this)))
	this))
  trim-initial-segment)
\f


;;;; Membership Lists

(define ((member-procedure pred) element list)
  ((positive-list-searcher (lambda (sub-list)
			     (pred (car sub-list) element))
			   identity-procedure
			   (lambda () #!FALSE))
   list))

(define memq (make-primitive-procedure 'MEMQ))
(define memv (member-procedure eqv?))
(define member (member-procedure equal?))

(define ((delete-member-procedure deletor pred) element list)
  ((deletor (lambda (match)
	      (pred match element)))
   list))

(define delq (delete-member-procedure list-deletor eq?))
(define delv (delete-member-procedure list-deletor eqv?))
(define delete (delete-member-procedure list-deletor equal?))

(define delq! (delete-member-procedure list-deletor! eq?))
(define delv! (delete-member-procedure list-deletor! eqv?))
(define delete! (delete-member-procedure list-deletor! equal?))
\f


;;;; Association Lists

(define ((association-procedure pred selector) key alist)
  ((positive-list-searcher (lambda (sub-alist)
			     (pred (selector (car sub-alist)) key))
			   car
			   (lambda () #!FALSE))
   alist))

(define assq (make-primitive-procedure 'ASSQ))
(define assv (association-procedure eqv? car))
(define assoc (association-procedure equal? car))

(define ((delete-association-procedure deletor pred selector) key alist)
  ((deletor (lambda (association)
	      (pred (selector association) key)))
   alist))

(define del-assq (delete-association-procedure list-deletor eq? car))
(define del-assv (delete-association-procedure list-deletor eqv? car))
(define del-assoc (delete-association-procedure list-deletor equal? car))

(define del-assq! (delete-association-procedure list-deletor! eq? car))
(define del-assv! (delete-association-procedure list-deletor! eqv? car))
(define del-assoc! (delete-association-procedure list-deletor! equal? car))
\f


;;;; Lastness

(define (last-pair l)
  (if (pair? l)
      (let loop ((l l))
	(if (pair? (cdr l))
	    (loop (cdr l))
	    l))
      (error "Argument not a list" 'LAST-PAIR l)))

(define (except-last-pair l)
  (if (pair? l)
      (let loop ((l l))
	(if (pair? (cdr l))
	    (cons (car l)
		  (loop (cdr l)))
	    '()))
      (error "Argument not a list" 'EXCEPT-LAST-PAIR l)))

(define (except-last-pair! l)
  (if (pair? l)
      (if (pair? (cdr l))
	  (sequence (let loop ((l l))
		      (if (pair? (cddr l))
			  (loop (cdr l))
			  (set-cdr! l '())))
		    l)
	  '())
      (error "Argument not a list" 'EXCEPT-LAST-PAIR! l)))