scsh-0.5/scsh/lib/list-pack.scm

;;; This is a Scheme48 interface spec for the SRFI-1 list-lib package.
;;; It defines the LIST-LIB-INTERFACE interface and LIST-LIB structure.
;;; Bindings are typed as tightly as one can in Scheme48's type language.
;;;     -Olin Shivers
;;;      shivers@ai.mit.edu

;;; list-lib
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; xcons cons* make-list list-tabulate list-copy circular-list iota
;;; proper-list? circular-list? dotted-list? not-pair? null-list? list=
;;; first second third fourth fifth sixth seventh eighth ninth tenth
;;; car+cdr
;;; take       drop       
;;; take-right drop-right 
;;; take!      drop-right!
;;; last last-pair
;;; length+
;;; append! reverse! append-reverse append-reverse!
;;; zip unzip1 unzip2 unzip3 unzip4 unzip5
;;; count
;;; unfold unfold-right
;;; fold       unfold       pair-fold       reduce
;;; fold-right unfold-right pair-fold-right reduce-right
;;; append-map append-map! map! pair-for-each filter-map map-in-order
;;; filter  partition  remove
;;; filter! partition! remove! 
;;; find find-tail any every list-index
;;; delete delete! delete-duplicates delete-duplicates!
;;; alist-cons alist-copy
;;; alist-delete alist-delete!
;;; 
;;; lset<= lset= lset-adjoin  
;;; lset-union			lset-union!
;;; lset-intersection		lset-intersection!
;;; lset-difference		lset-difference!
;;; lset-xor			lset-xor!
;;; lset-diff+intersection	lset-diff+intersection!
;;;
;;; map for-each member assoc			(Extended R4RS procedures)
;;;
;;; cons pair? null? list length append reverse		    (These are the
;;; car cdr ... cdddar cddddr set-car! set-cdr! list-ref     R4RS procedures
;;; memq memv assoc assq assv				     re-exported by
;;; 							     list-lib unchanged.)

(define-interface list-lib-interface
  (export
   ;; xcons <cdr> <car>
   (xcons (proc (:value :value) :value))

   ;; cons* item ... 
   (cons* (proc (:value &rest :value) :value))

   ;; make-list len [fill]
   (make-list (proc (:exact-integer &opt :value) :value))

   ;; list-tabulate elt-proc len
   (list-tabulate (proc (:exact-integer (proc (:exact-integer) :value)) :value))

   ;; list-copy lis
   (list-copy (proc (:value) :value))

   (circular-list (proc (:value &rest :value) :pair))

;  ((:iota iota:)
;   (proc (:number &opt :number :number) :value))

   (iota (proc (:exact-integer &opt :number :number) :value))

   (proper-list?   (proc (:value) :boolean))
   (dotted-list?   (proc (:value) :boolean))
   (circular-list? (proc (:value) :boolean))

   (not-pair?  (proc (:value) :boolean))
   (null-list? (proc (:value) :boolean))

   (list= (proc ((proc (:value :value) :boolean) &rest :value) :boolean))

   ((first second third fourth fifth sixth seventh eighth ninth tenth)
    (proc (:pair) :value))

   (car+cdr (proc (:pair) (some-values :value :value)))

   ;; take  lis i	take-right  lis i
   ;; drop  lis i	drop-right  lis i
   ;; take! lis i	drop-right! lis i
   ((take drop take-right drop-right take! drop-right!)
    (proc (:value :exact-integer) :value))

   (last (proc (:pair) :value))
   (last-pair (proc (:pair) :pair))

   (length+ (proc (:value) :value))
   (append! (proc (:value &rest :value) :value))
   (reverse! (proc (:value) :value))
   ((append-reverse append-reverse!) (proc (:value :value) :value))

   (zip    (proc (:value &rest :value) :value))
   (unzip1 (proc (:value) :value))
   (unzip2 (proc (:value) (some-values :value :value)))
   (unzip3 (proc (:value) (some-values :value :value :value)))
   (unzip4 (proc (:value) (some-values :value :value :value :value)))
   (unzip5 (proc (:value) (some-values :value :value :value :value :value)))

   (count (proc ((proc (:value &rest :value) :boolean) :value) :exact-integer))

   ((fold fold-right)
    (proc ((proc (:value :value &rest :value) :value)
	   :value :value &rest :value)
	  :value))

   ((unfold unfold-right) (proc ((proc (:value) :boolean)
				 (proc (:value) :value)
				 (proc (:value) :value)
				 :value
				 &opt (proc (:value) :value))
				:value))

   ((pair-fold pair-fold-right)
    (proc ((proc (:pair :value &rest :value) :value)
	   :value :value &rest :value)
	  :value))

   ((reduce reduce-right)
    (proc ((proc (:value :value) :value) :value :value) :value))

   ((append-map append-map! map! filter-map map-in-order)
    (proc ((proc (:value &rest :value) :value) :value &rest :value) :value))

   (pair-for-each (proc ((proc (:pair &rest :pair) :values) :value &rest :value)
			:unspecific))

   ((filter filter! remove remove!)
    (proc ((proc (:value) :boolean) :value) :value))

   ((partition partition!) (proc ((proc (:value) :boolean) :value)
				 (some-values :value :value)))

   ((find find-tail) (proc ((proc (:value) :boolean) :value) :value))

   ((any every)
    (proc ((proc (:value &rest :value) :value) :value &rest :value) :value))

   (list-index (proc ((proc (:value &rest :value) :value) :value &rest :value)
		     :value))

   ((delete delete!)
    (proc (:value :value &opt (proc (:value :value) :boolean)) :value))

   ;; Extended from their R5RS definitions to take an optional comparison
   ;; function: (MEMBER x lis [=]).
   (member (proc (:value :value &opt (proc (:value :value) :boolean)) :value))
   (assoc  (proc (:value :value &opt (proc (:value :value) :boolean)) :value))

   ((delete-duplicates delete-duplicates!)
    (proc (:value &opt (proc (:value :value) :boolean)) :value))

   (alist-cons (proc (:value :value :value) :value))
   (alist-copy (proc (:value) :value))
   ((alist-delete alist-delete!)
    (proc (:value :value &opt (proc (:value :value) :value)) :value))

   ;; Extended from their R4RS definitions.
   (map (proc ((proc (:value) :value) &rest :value) :value))
   (for-each (proc ((proc (:value) :values) &rest :value) :unspecific))

   ;; R4RS exports
   (cons (proc (:value :value) :pair))
   ((pair? null?) (proc (:value) :boolean))
   (list-ref (proc (:value :exact-integer) :value))
   (list (proc (&rest :value) :value))
   (length (proc (:value) :exact-integer))
   (append (proc (&rest :value) :value))
   (reverse (proc (:value) :value))
   ((car cdr
     caaaar caaadr caadar caaddr caaar caadr caar
     cadaar cadadr caddar cadddr cadar caddr cadr
     cdaaar cdaadr cdadar cdaddr cdaar cdadr cdar
     cddaar cddadr cdddar cddddr cddar cdddr cddr) (proc (:value) :value))
   ((set-car! set-cdr!) (proc (:pair :value) :unspecific))
   ((memq memv) (proc (:value :value) :value))
   ((assq assv) (proc (:value :value) :value))


   ;; lset-lib
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; lset<= = list1 list2 ...
   ;; lset=  = list1 list2 ...
   ;; lset-adjoin = list elt1 ...
   ;; lset-union = list1 ...
   ;; lset-intersection = list1 list2 ...
   ;; lset-difference = list1 list2 ...
   ;; lset-xor = list1 ...
   ;; lset-diff+intersection = list1 list2 ...
   ;; ... and their side effecting counterparts:
   ;;   lset-union! lset-intersection! lset-difference! lset-xor! 
   ;;   lset-diff+intersection!

   ;; lset=  = list1 ... -> boolean
   ;; lset<= = list1 ... -> boolean
   ((lset= lset<=)
    (proc ((proc (:value :value) :boolean) &rest :value) :boolean))

   ;; lset-adjoin = list elt1 ...
   (lset-adjoin (proc ((proc (:value :value) :boolean) :value &rest :value) :value))

   ;; lset-union  = list1 ...	lset-xor  = list1 ...
   ;; lset-union! = list1 ...	lset-xor! = list1 ...
   ((lset-union lset-xor)
    (proc ((proc (:value :value) :boolean) &rest :value) :value))

   ;; lset-intersection  = list1 list2 ...
   ;; lset-intersection! = list1 list2 ...
   ;; lset-difference    = list1 list2 ...
   ;; lset-difference!   = list1 list2 ...
   ((lset-intersection  lset-difference
     lset-intersection! lset-difference!)
    (proc ((proc (:value :value) :boolean) :value &rest :value) :value))

   ;; lset-diff+intersection  = list1 list2 ...
   ;; lset-diff+intersection! = list1 list2 ...
   ((lset-diff+intersection lset-diff+intersection!)
    (proc ((proc (:value :value) :boolean) :value &rest :value)
	  (some-values :value :value)))
   ))

(define-structure list-lib list-lib-interface
  (open error-package	; ERROR procedure
	receiving	; RECEIVE m-v macro
	let-opt		; LET-OPTIONALS and :OPTIONAL.
	scheme)
  (begin (define (check-arg pred val caller)
	   (let lp ((val val))
	     (if (pred val) val (lp (error "Bad argument" val pred caller))))))
  (files list-lib))