#| -*-Scheme-*-
-$Id: list.scm,v 14.20 1995/03/03 23:40:17 cph Exp $
+$Id: list.scm,v 14.21 1995/07/27 21:33:33 adams Exp $
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-1995 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;;; List Operations
;;; package: (runtime list)
+
+;;; Note: Many list operations (like LIST-COPY and DELQ) have been
+;; replaced with iterative versions which are slightly longer than
+;; the recursive ones. The iterative versions have the advantage
+;; that they are not limited by the stack size. If you can execute
+;; (MAKE-LIST 100000) you should be able to process it. Some
+;; machines have a problem with large stacks - Win32s as a max stack
+;; size of 128k.
+;;
+;; The disadvantage of the iterative versions is that side-effects are
+;; detectable in horrible ways with CALL-WITH-CURRENT-CONTINUATION.
+;; Due to this only those procedures which call procedures known NOT
+;; to use CALL-WITH-CURRENT-CONTINUATION can be written this way, so
+;; MAP is still recursive, but LIST-COPY is iterative. The
+;; assumption is that any other way of grabbing the continuation
+;; (e.g. the threads package via a timer interrupt) will invoke the
+;; continuation at most once.
+;;
+;; We did some performance measurements. The iterative versions were
+;; slightly faster. These comparisons should be checked after major
+;; compiler work.
+;;
+;; Each interative version appears after the commented-out recursive
+;; version. Please leave them in the file, we may want them in the
+;; future. We have commented them out with ;; rather than block (i.e
+;; #||#) comments deliberately.
+;;
+;; -- Yael & Stephen
+
(declare (usual-integrations))
\f
(define-primitives
(cdr rest-elements))))))
(define (make-list length #!optional value)
- (guarantee-index length 'MAKE-LIST)
+ (guarantee-index/list length 'MAKE-LIST)
(let ((value (if (default-object? value) '() value)))
(let loop ((n length) (result '()))
- (if (zero? n)
+ (if (fix:zero? n)
result
- (loop (- n 1) (cons value result))))))
+ (loop (fix:- n 1) (cons value result))))))
(define (circular-list . items)
(if (not (null? items))
items)
(define (make-circular-list length #!optional value)
- (guarantee-index length 'MAKE-CIRCULAR-LIST)
- (if (positive? length)
+ (guarantee-index/list length 'MAKE-CIRCULAR-LIST)
+ (if (not (fix:zero? length))
(let ((value (if (default-object? value) '() value)))
(let ((last (cons value '())))
- (let loop ((n (- length 1)) (result last))
+ (let loop ((n (fix:- length 1)) (result last))
(if (zero? n)
(begin
(set-cdr! last result)
result)
- (loop (- n 1) (cons value result))))))
+ (loop (fix:- n 1) (cons value result))))))
'()))
(define (make-initialized-list length initialization)
- (guarantee-index length 'MAKE-INITIALIZED-LIST)
+ (guarantee-index/list length 'MAKE-INITIALIZED-LIST)
(let loop ((index (- length 1)) (result '()))
(if (negative? index)
result
(car tail)))
(define (list-tail list index)
- (guarantee-index index 'LIST-TAIL)
+ (guarantee-index/list index 'LIST-TAIL)
(let loop ((list list) (index* index))
- (if (zero? index*)
+ (if (fix:zero? index*)
list
(begin
(if (not (pair? list))
(error:bad-range-argument index 'LIST-TAIL))
- (loop (cdr list) (- index* 1))))))
+ (loop (cdr list) (fix:- index* 1))))))
(define (list-head list index)
- (guarantee-index index 'LIST-HEAD)
+ (guarantee-index/list index 'LIST-HEAD)
(let loop ((list list) (index* index))
- (if (zero? index*)
+ (if (fix:zero? index*)
'()
(begin
(if (not (pair? list))
(error:bad-range-argument index 'LIST-HEAD))
- (cons (car list) (loop (cdr list) (- index* 1)))))))
+ (cons (car list) (loop (cdr list) (fix:- index* 1)))))))
(define (sublist list start end)
(list-head (list-tail list start) (- end start)))
(null? l1)))))
(null? l1))))
+;;(define (list-copy items)
+;; (let loop ((items* items))
+;; (if (pair? items*)
+;; (cons (car items*) (loop (cdr items*)))
+;; (begin
+;; (if (not (null? items*))
+;; (error:wrong-type-argument items "list" 'LIST-COPY))
+;; '()))))
+
+;; Iterative version:
+
(define (list-copy items)
- (let loop ((items* items))
- (if (pair? items*)
- (cons (car items*) (loop (cdr items*)))
- (begin
- (if (not (null? items*))
- (error:wrong-type-argument items "list" 'LIST-COPY))
- '()))))
+ (define (end-check list result)
+ (if (not (null? list))
+ (error:wrong-type-argument items "list" 'LIST-COPY))
+ result)
+ (if (pair? items)
+ (let ((head (cons (car items) '())))
+ (let loop ((list (cdr items)) (previous head))
+ (if (pair? list)
+ (let ((new (cons (car list) '())))
+ (set-cdr! previous new)
+ (loop (cdr list) new))
+ (end-check list head))))
+ (end-check items '())))
+
+;;(define (alist-copy alist)
+;; (let loop ((alist* alist))
+;; (if (pair? alist*)
+;; (begin
+;; (if (not (pair? (car alist*)))
+;; (error:wrong-type-argument alist "alist" 'ALIST-COPY))
+;; (cons (cons (car (car alist*)) (cdr (car alist*)))
+;; (loop (cdr alist*))))
+;; (begin
+;; (if (not (null? alist*))
+;; (error:wrong-type-argument alist "alist" 'ALIST-COPY))
+;; '()))))
+
+;; Iterative version:
(define (alist-copy alist)
- (let loop ((alist* alist))
- (if (pair? alist*)
- (begin
- (if (not (pair? (car alist*)))
- (error:wrong-type-argument alist "alist" 'ALIST-COPY))
- (cons (cons (car (car alist*)) (cdr (car alist*)))
- (loop (cdr alist*))))
- (begin
- (if (not (null? alist*))
- (error:wrong-type-argument alist "alist" 'ALIST-COPY))
- '()))))
+ (define (end-check list result)
+ (if (not (null? list))
+ (error:wrong-type-argument alist "list" 'ALIST-COPY))
+ result)
+ (if (pair? alist)
+ (begin
+ (if (not (pair? (car alist)))
+ (error:wrong-type-argument alist "alist" 'ALIST-COPY))
+ (let ((head (cons (car alist) '())))
+ (let loop ((alist* (cdr alist)) (previous head))
+ (if (pair? alist*)
+ (begin
+ (if (not (pair? (car alist*)))
+ (error:wrong-type-argument alist "alist" 'ALIST-COPY))
+ (let ((new (cons (cons (car (car alist*))
+ (cdr (car alist*))) '())))
+ (set-cdr! previous new)
+ (loop (cdr alist*) new)))
+ (end-check alist* head)))))
+ (end-check alist '())))
(define (tree-copy tree)
- (let loop ((tree tree))
+ (let walk ((tree tree))
(if (pair? tree)
- (cons (loop (car tree)) (loop (cdr tree)))
+ (cons (walk (car tree)) (walk (cdr tree)))
tree)))
\f
;;;; Weak Pairs
;;; everyone would write in assembly language.
(define (append . lists)
+ (%append lists))
+
+(define (%append lists)
(let ((lists (reverse! lists)))
(if (null? lists)
'()
(cdr rest)))))))
(define (append! . lists)
+ (%append! lists))
+
+(define (%append! lists)
(if (null? lists)
'()
(let loop ((head (car lists)) (tail (cdr lists)))
(loop (car tail) (cdr tail)))))))
(define (reverse l)
- (let loop ((rest l) (so-far '()))
+ (%reverse l '()))
+
+(define (%reverse l tail)
+ (let loop ((rest l) (so-far tail))
(if (pair? rest)
(loop (cdr rest) (cons (car rest) so-far))
(begin
(if (not (null? rest))
- (error:wrong-type-argument l "list" 'REVERSE))
+ (error:wrong-type-argument l "list" '%REVERSE))
so-far))))
(define (reverse! l)
new-cdr))))
\f
;;;; Mapping Procedures
+;;
+;; This is an iterative, side effecting version of map. It is not used
+;; because it interacts with call-with-current-continuation.
+;;
+;;(define (map procedure first . rest)
+;;
+;; (define (bad-list thing)
+;; (error:wrong-type-argument thing "list" 'MAP))
+;;
+;; (define (map-1 list)
+;; (define-integrable (end-check thing result)
+;; (if (not (null? thing)) (bad-list list))
+;; result)
+;; (if (pair? list)
+;; (let ((head (cons (procedure (car list)) '())))
+;; (let 1-loop ((list* (cdr list)) (previous head))
+;; (if (pair? list*)
+;; (let ((new (cons (procedure (car list*)) '())))
+;; (set-cdr! previous new)
+;; (1-loop (cdr list*) new))
+;; (end-check list* head))))
+;; (end-check list '())))
+;;
+;; (define (map-2 list1 list2)
+;; (define-integrable (end-check end1 end2 result)
+;; (if (pair? end1)
+;; (if (not (null? end2)) (bad-list list2))
+;; (if (pair? end2)
+;; (if (not (null? end1)) (bad-list list1))))
+;; result)
+;; (if (and (pair? list1) (pair? list2))
+;; (let ((head (cons (procedure (car list1) (car list2)) '())))
+;; (let 2-loop ((list1* (cdr list1))
+;; (list2* (cdr list2))
+;; (previous head))
+;; (if (and (pair? list1*) (pair? list2*))
+;; (let ((new (cons (procedure (car list1*) (car list2*))
+;; '())))
+;; (set-cdr! previous new)
+;; (2-loop (cdr list1*) (cdr list2*) new))
+;; (end-check list1* list2* head))))
+;; (end-check list1 list2 '())))
+;;
+;; (define (map-n lists)
+;; ;; LISTS has at least one list.
+;; (let ((head (cons '() '())))
+;; (let n-loop ((lists* lists) (previous head))
+;; (let parse-cars ((lists lists)
+;; (lists* lists*)
+;; (cars '())
+;; (cdrs '()))
+;; (cond ((null? lists*)
+;; (let ((new (cons (apply procedure
+;; (reverse! cars)) '())))
+;; (set-cdr! previous new)
+;; (n-loop (reverse! cdrs) new)))
+;; ((pair? (car lists*))
+;; (parse-cars (cdr lists)
+;; (cdr lists*)
+;; (cons (car (car lists*)) cars)
+;; (cons (cdr (car lists*)) cdrs)))
+;; (else
+;; (if (not (null? (car lists*)))
+;; (bad-list (car lists)))
+;; (cdr head)))))))
+;;
+;; (cond ((null? rest)
+;; (map-1 first))
+;; ((null? (cdr rest))
+;; (map-2 first (car rest)))
+;; (else
+;; (map-n (cons first rest)))))
+
(let-syntax
((mapping-procedure
(macro (name combiner initial-value procedure first rest)
(let ((name (string-upcase (symbol->string name))))
- `(IF (NULL? ,rest)
- (LET 1-LOOP ((LIST ,first))
- (IF (PAIR? LIST)
- (,combiner (,procedure (CAR LIST))
- (1-LOOP (CDR LIST)))
- (BEGIN
- (IF (NOT (NULL? LIST))
- (ERROR:WRONG-TYPE-ARGUMENT ,first "list" ',name))
- ,initial-value)))
- (LET ((LISTS (CONS ,first ,rest)))
- (LET N-LOOP ((LISTS* LISTS))
- (LET PARSE-CARS
- ((LISTS LISTS)
- (LISTS* LISTS*)
- (CARS '())
- (CDRS '()))
- (COND ((NULL? LISTS*)
- (,combiner (APPLY ,procedure (REVERSE! CARS))
- (N-LOOP (REVERSE! CDRS))))
- ((PAIR? (CAR LISTS*))
- (PARSE-CARS (CDR LISTS)
- (CDR LISTS*)
- (CONS (CAR (CAR LISTS*)) CARS)
- (CONS (CDR (CAR LISTS*)) CDRS)))
- (ELSE
- (IF (NOT (NULL? (CAR LISTS*)))
- (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list"
- ',name))
- ,initial-value))))))))))
+ `(COND ((NULL? ,rest)
+ (LET 1-LOOP ((LIST ,first))
+ (IF (PAIR? LIST)
+ (,combiner (,procedure (CAR LIST))
+ (1-LOOP (CDR LIST)))
+ (BEGIN
+ (IF (NOT (NULL? LIST))
+ (ERROR:WRONG-TYPE-ARGUMENT ,first "list" ',name))
+ ,initial-value))))
+ ((NULL? (CDR ,rest))
+ (LET 2-LOOP ((LIST1 ,first) (LIST2 (CAR ,rest)))
+ (IF (AND (PAIR? LIST1) (PAIR? LIST2))
+ (,combiner (,procedure (CAR LIST1) (CAR LIST2))
+ (2-LOOP (CDR LIST1) (CDR LIST2)))
+ (BEGIN
+ (IF (AND (NOT (PAIR? LIST1))
+ (NOT (NULL? LIST1)))
+ (ERROR:WRONG-TYPE-ARGUMENT ,first "list" ',name))
+ (IF (AND (NOT (PAIR? LIST2))
+ (NOT (NULL? LIST2)))
+ (ERROR:WRONG-TYPE-ARGUMENT (CAR ,rest)
+ "list" ',name))
+ ,initial-value))))
+ (ELSE
+ (LET ((LISTS (CONS ,first ,rest)))
+ (LET N-LOOP ((LISTS* LISTS))
+ (LET PARSE-CARS
+ ((LISTS LISTS)
+ (LISTS* LISTS*)
+ (CARS '())
+ (CDRS '()))
+ (COND ((NULL? LISTS*)
+ (,combiner (APPLY ,procedure (REVERSE! CARS))
+ (N-LOOP (REVERSE! CDRS))))
+ ((PAIR? (CAR LISTS*))
+ (PARSE-CARS (CDR LISTS)
+ (CDR LISTS*)
+ (CONS (CAR (CAR LISTS*)) CARS)
+ (CONS (CDR (CAR LISTS*)) CDRS)))
+ (ELSE
+ (IF (NOT (NULL? (CAR LISTS*)))
+ (ERROR:WRONG-TYPE-ARGUMENT (CAR LISTS) "list"
+ ',name))
+ ,initial-value)))))))))))
(define (for-each procedure first . rest)
(mapping-procedure for-each begin unspecific procedure first rest))
(error:wrong-type-argument list "list" 'REDUCE-RIGHT))
initial)))
-(define (fold-left procedure initial olist)
- (let fold ((initial initial)
- (list olist))
+(define (fold-left procedure initial-value a-list)
+ (let fold ((initial-value initial-value)
+ (list a-list))
(if (pair? list)
- (fold (procedure initial (car list))
+ (fold (procedure initial-value (car list))
(cdr list))
(begin
(if (not (null? list))
- (error:wrong-type-argument olist "list" 'FOLD-LEFT))
- initial))))
+ (error:wrong-type-argument a-list "list" 'FOLD-LEFT))
+ initial-value))))
-(define (fold-right procedure initial olist)
- (let fold ((list olist))
+(define (fold-right procedure initial-value a-list)
+ (let fold ((list a-list))
(if (pair? list)
(procedure (car list) (fold (cdr list)))
(begin
(if (not (null? list))
- (error:wrong-type-argument olist "list" 'FOLD-RIGHT))
- initial))))
+ (error:wrong-type-argument a-list "list" 'FOLD-RIGHT))
+ initial-value))))
\f
;;;; Generalized List Operations
'LIST-TRANSFORM-POSITIVE))
'()))))
+;; Iterative version:
+;;
+;;(define (list-transform-positive items predicate)
+;; (define (end-check list result)
+;; (if (not (null? list))
+;; (error:wrong-type-argument items "list" 'LIST-TRANSFORM-POSITIVE))
+;; result)
+;; (if (pair? items)
+;; (let ((head (cons (car items) '())))
+;; (let loop ((items* (cdr items)) (previous head))
+;; (if (pair? items*)
+;; (if (not (predicate (car items*)))
+;; (loop (cdr items*) previous)
+;; (let ((new (cons (car items*) '())))
+;; (set-cdr! previous new)
+;; (loop (cdr items*) new)))
+;; (if (predicate (car items))
+;; (end-check items* head)
+;; (end-check items* (cdr head))))))
+;; (end-check items '())))
+
+
(define (list-transform-negative items predicate)
(let loop ((items* items))
(if (pair? items*)
'LIST-TRANSFORM-NEGATIVE))
'()))))
+;; Iterative version:
+;;
+;;(define (list-transform-negative items predicate)
+;; (define (end-check list result)
+;; (if (not (null? list))
+;; (error:wrong-type-argument items "list" 'LIST-TRANSFORM-NEGATIVE))
+;; result)
+;; (if (pair? items)
+;; (let ((head (cons (car items) '())))
+;; (let loop ((items* (cdr items)) (previous head))
+;; (if (pair? items*)
+;; (if (predicate (car items*))
+;; (loop (cdr items*) previous)
+;; (let ((new (cons (car items*) '())))
+;; (set-cdr! previous new)
+;; (loop (cdr items*) new)))
+;; (if (not (predicate (car items)))
+;; (end-check items* head)
+;; (end-check items* (cdr head))))))
+;; (end-check items '())))
+
(define (list-search-positive items predicate)
(let loop ((items* items))
(if (pair? items*)
(error:wrong-type-argument alist "alist" 'ASSQ))
#f))))
+;;(define (delq item items)
+;; (let loop ((items* items))
+;; (if (pair? items*)
+;; (if (eq? item (car items*))
+;; (loop (cdr items*))
+;; (cons (car items*) (loop (cdr items*))))
+;; (begin
+;; (if (not (null? items*))
+;; (error:wrong-type-argument items "list" 'DELQ))
+;; '()))))
+
+;; Iterative version:
+
(define (delq item items)
- (let loop ((items* items))
- (if (pair? items*)
- (if (eq? item (car items*))
- (loop (cdr items*))
- (cons (car items*) (loop (cdr items*))))
- (begin
- (if (not (null? items*))
- (error:wrong-type-argument items "list" 'DELQ))
- '()))))
+ (define (end-check list result)
+ (if (not (null? list))
+ (error:wrong-type-argument items "list" 'DELQ))
+ result)
+ (if (pair? items)
+ (let ((head (cons (car items) '())))
+ (let loop ((items* (cdr items)) (previous head))
+ (if (pair? items*)
+ (if (eq? item (car items*))
+ (loop (cdr items*) previous)
+ (let ((new (cons (car items*) '())))
+ (set-cdr! previous new)
+ (loop (cdr items*) new)))
+ (if (not (eq? item (car items)))
+ (end-check items* head)
+ (end-check items* (cdr head))))))
+ (end-check items '())))
(define (delq! item items)
(letrec ((trim-initial-segment
(loop (cdr list))
list)))
+;;(define (except-last-pair list)
+;; (guarantee-pair list 'EXCEPT-LAST-PAIR)
+;; (let loop ((list list))
+;; (if (pair? (cdr list))
+;; (cons (car list)
+;; (loop (cdr list)))
+;; '())))
+
+;; Iterative version:
+
(define (except-last-pair list)
(guarantee-pair list 'EXCEPT-LAST-PAIR)
- (let loop ((list list))
- (if (pair? (cdr list))
- (cons (car list)
- (loop (cdr list)))
- '())))
+ (if (not (pair? (cdr list)))
+ '()
+ (let ((head (cons (car list) '())))
+ (let loop ((list* (cdr list)) (previous head))
+ (if (pair? (cdr list*))
+ (let ((new (cons (car list*) '())))
+ (set-cdr! previous new)
+ (loop (cdr list*) new))
+ head)))))
+
(define (except-last-pair! list)
(guarantee-pair list 'EXCEPT-LAST-PAIR!)
(if (not (pair? object))
(error:wrong-type-argument object "pair" procedure)))
-(define-integrable (guarantee-index object procedure)
- (if (not (exact-nonnegative-integer? object))
- (error:wrong-type-argument object "exact nonnegative integer"
- procedure)))
\ No newline at end of file
+(define-integrable (guarantee-index/list object procedure)
+ (if (not (index-fixnum? object))
+ (guarantee-index/list/fail object procedure)))
+
+(define (guarantee-index/list/fail object procedure)
+ (error:wrong-type-argument object "valid list index"
+ procedure))
+
#| -*-Scheme-*-
-$Id: string.scm,v 14.11 1994/03/02 16:51:02 gjr Exp $
+$Id: string.scm,v 14.12 1995/07/27 21:33:44 adams Exp $
-Copyright (c) 1988-1994 Massachusetts Institute of Technology
+Copyright (c) 1988-1995 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;; Substring Covers
(define (string=? string1 string2)
+ (guarantee-2-strings string1 string2 'string=?)
(substring=? string1 0 (string-length string1)
string2 0 (string-length string2)))
(define (string-ci=? string1 string2)
+ (guarantee-2-strings string1 string2 'string-ci=?)
(substring-ci=? string1 0 (string-length string1)
string2 0 (string-length string2)))
(define (string<? string1 string2)
+ (guarantee-2-strings string1 string2 'string<?)
(substring<? string1 0 (string-length string1)
string2 0 (string-length string2)))
(define (string-ci<? string1 string2)
+ (guarantee-2-strings string1 string2 'string-ci<?)
(substring-ci<? string1 0 (string-length string1)
string2 0 (string-length string2)))
(define (string>? string1 string2)
+ (guarantee-2-strings string1 string2 'string>?)
(substring<? string2 0 (string-length string2)
string1 0 (string-length string1)))
(define (string-ci>? string1 string2)
+ (guarantee-2-strings string1 string2 'string-ci>?)
(substring-ci<? string2 0 (string-length string2)
string1 0 (string-length string1)))
(define (string>=? string1 string2)
+ (guarantee-2-strings string1 string2 'string-ci>=?)
(not (substring<? string1 0 (string-length string1)
string2 0 (string-length string2))))
(define (string-ci>=? string1 string2)
+ (guarantee-2-strings string1 string2 'string-ci>=?)
(not (substring-ci<? string1 0 (string-length string1)
string2 0 (string-length string2))))
(define (string<=? string1 string2)
+ (guarantee-2-strings string1 string2 'string<=?)
(not (substring<? string2 0 (string-length string2)
string1 0 (string-length string1))))
(define (string-ci<=? string1 string2)
+ (guarantee-2-strings string1 string2 'string-ci<=?)
(not (substring-ci<? string2 0 (string-length string2)
string1 0 (string-length string1))))
(define (string-fill! string char)
+ (guarantee-string string 'string-fill!)
(substring-fill! string 0 (string-length string) char))
(define (string-find-next-char string char)
+ (guarantee-string string 'string-find-next-char)
(substring-find-next-char string 0 (string-length string) char))
(define (string-find-previous-char string char)
+ (guarantee-string string 'string-find-previous-char)
(substring-find-previous-char string 0 (string-length string) char))
(define (string-find-next-char-ci string char)
+ (guarantee-string string 'string-find-next-char-ci)
(substring-find-next-char-ci string 0 (string-length string) char))
(define (string-find-previous-char-ci string char)
+ (guarantee-string string 'string-find-previous-char-ci)
(substring-find-previous-char-ci string 0 (string-length string) char))
(define (string-find-next-char-in-set string char-set)
+ (guarantee-string string 'string-find-next-char-in-set)
(substring-find-next-char-in-set string 0 (string-length string) char-set))
(define (string-find-previous-char-in-set string char-set)
+ (guarantee-string string 'string-find-previous-char-in-set)
(substring-find-previous-char-in-set string 0 (string-length string)
char-set))
(define (string-match-forward string1 string2)
+ (guarantee-2-strings string1 string2 'string-match-forward)
(substring-match-forward string1 0 (string-length string1)
string2 0 (string-length string2)))
(define (string-match-backward string1 string2)
+ (guarantee-2-strings string1 string2 'string-match-backward)
(substring-match-backward string1 0 (string-length string1)
string2 0 (string-length string2)))
(define (string-match-forward-ci string1 string2)
+ (guarantee-2-strings string1 string2 'string-match-forward-ci)
(substring-match-forward-ci string1 0 (string-length string1)
string2 0 (string-length string2)))
(define (string-match-backward-ci string1 string2)
+ (guarantee-2-strings string1 string2 'string-match-backward-ci)
(substring-match-backward-ci string1 0 (string-length string1)
string2 0 (string-length string2)))
\f
;;;; Basic Operations
(define (make-string length #!optional char)
+ (guarantee-index/string length 'make-string)
(if (default-object? char)
(string-allocate length)
(let ((result (string-allocate length)))
(substring-fill! result 0 length char)
result)))
-(define-integrable (string-null? string)
+(define (string-null? string)
+ (guarantee-string string 'string-null?)
+ (%string-null? string))
+
+(define-integrable (%string-null? string)
(fix:= 0 (string-length string)))
+(define-integrable (%substring string start end)
+ (let ((start start)
+ (end end))
+ (let ((result (string-allocate (fix:- end start))))
+ (substring-move-right! string start end result 0)
+ result)))
+
(define (substring string start end)
- (let ((result (string-allocate (fix:- end start))))
- (substring-move-right! string start end result 0)
- result))
+ (guarantee-string string 'substring)
+ (guarantee-index/string start 'substring)
+ (guarantee-index/string end 'substring)
+ (%substring string start end))
-(define-integrable (string-head string end)
- (substring string 0 end))
+(define (string-head string end)
+ (guarantee-string string 'string-head)
+ (guarantee-index/string end 'string-head)
+ (%substring string 0 end))
(define (string-tail string start)
- (substring string start (string-length string)))
+ (guarantee-string string 'string-tail)
+ (guarantee-index/string start 'string-tail)
+ (%substring string start (string-length string)))
(define (list->string chars)
+ ;; This should check that each element of CHARS satisfies CHAR? but at
+ ;; worst it will generate strings containing rubbish from the
+ ;; addresses of the objects ...
(let ((result (string-allocate (length chars))))
(let loop ((index 0) (chars chars))
(if (null? chars)
result
+ ;; LENGTH would have barfed if input is not a proper list:
(begin (string-set! result index (car chars))
(loop (fix:+ index 1) (cdr chars)))))))
(define char->string string)
(define (string->list string)
- (substring->list string 0 (string-length string)))
+ (guarantee-string string 'string->list)
+ (%substring->list string 0 (string-length string)))
+
+;; This version is unnecessarily recursive:
+;;
+;;(define (%substring->list string start end)
+;; (let loop ((index start))
+;; (if (fix:< index end)
+;; (cons (string-ref string index)
+;; (loop (fix:+ index 1)))
+;; '())))
+
+(define (%substring->list string start end)
+ (let loop ((index (fix:- end 1)) (list '()))
+ (if (fix:>= index start)
+ (loop (fix:- index 1)
+ (cons (string-ref string index) list))
+ list)))
(define (substring->list string start end)
- (let loop ((index (fix:- end 1))
- (result '()))
- (if (fix:< index start)
- result
- (loop (fix:- index 1)
- (cons (string-ref string index)
- result)))))
+ (guarantee-string string 'substring->list)
+ (guarantee-index/string start 'substring->list)
+ (guarantee-string-bound end string 'substring->list)
+ (%substring->list string start end))
(define (string-copy string)
+ (guarantee-string string 'string-copy)
(let ((size (string-length string)))
(let ((result (string-allocate size)))
(substring-move-right! string 0 size result 0)
result)))
-(define (string-append . strings)
+(define (%string-append strings)
(let ((result
(string-allocate
- (let loop ((strings strings))
+ (let loop ((strings strings) (length 0))
(if (null? strings)
- 0
- (fix:+ (string-length (car strings))
- (loop (cdr strings))))))))
+ length
+ (begin
+ (guarantee-string (car strings) 'string-append)
+ (loop (cdr strings)
+ (fix:+ (string-length (car strings)) length))))))))
+
(let loop ((strings strings) (index 0))
(if (null? strings)
result
(let ((size (string-length (car strings))))
(substring-move-right! (car strings) 0 size result index)
(loop (cdr strings) (fix:+ index size)))))))
+
+(define (string-append . strings)
+ (%string-append strings))
\f
;;;; Case
(define (string-upper-case? string)
- (substring-upper-case? string 0 (string-length string)))
+ (guarantee-string string 'string-upper-case?)
+ (%substring-upper-case? string 0 (string-length string)))
(define (substring-upper-case? string start end)
+ (guarantee-string string 'substring-upper-case?)
+ (guarantee-index/string start 'substring-upper-case?)
+ (guarantee-string-bound end string 'substring-upper-case?)
+ (%substring-upper-case? string start end))
+
+(define (%substring-upper-case? string start end)
(let find-upper ((start start))
(and (fix:< start end)
(let ((char (string-ref string start)))
(define (string-upcase string)
(let ((string (string-copy string)))
- (string-upcase! string)
+ (substring-upcase! string 0 (string-length string))
string))
(define (string-upcase! string)
+ (guarantee-string string 'string-upcase!)
(substring-upcase! string 0 (string-length string)))
+;;
+
(define (string-lower-case? string)
- (substring-lower-case? string 0 (string-length string)))
+ (guarantee-string string 'string-lower-case?)
+ (%substring-lower-case? string 0 (string-length string)))
(define (substring-lower-case? string start end)
+ (guarantee-string string 'substring-lower-case?)
+ (guarantee-index/string start 'substring-lower-case?)
+ (guarantee-string-bound end string 'substring-lower-case?)
+ (%substring-lower-case? string start end))
+
+(define (%substring-lower-case? string start end)
(let find-lower ((start start))
(and (fix:< start end)
(let ((char (string-ref string start)))
(define (string-downcase string)
(let ((string (string-copy string)))
- (string-downcase! string)
+ (substring-downcase! string 0 (string-length string))
string))
(define (string-downcase! string)
+ (guarantee-string string 'string-downcase!)
(substring-downcase! string 0 (string-length string)))
\f
(define (string-capitalized? string)
+ (guarantee-string string 'string-capitalized?)
(substring-capitalized? string 0 (string-length string)))
(define (substring-capitalized? string start end)
+ (guarantee-string string 'substring-capitalized?)
+ (guarantee-index/string start 'substring-capitalized?)
+ (guarantee-string-bound end string 'substring-capitalized?)
+ (%substring-capitalized? string start end))
+
+(define (%substring-capitalized? string start end)
;; Testing for capitalization is somewhat more involved than testing
;; for upper or lower case. This algorithm requires that the first
;; word be capitalized, and that the subsequent words be either
(define (string-capitalize string)
(let ((string (string-copy string)))
- (string-capitalize! string)
+ (substring-capitalize! string 0 (string-length string))
string))
(define (string-capitalize! string)
+ (guarantee-string string 'string-capitalize!)
(substring-capitalize! string 0 (string-length string)))
(define (substring-capitalize! string start end)
string))
(define (string-replace! string char1 char2)
+ (guarantee-string string 'string-replace!)
(substring-replace! string 0 (string-length string) char1 char2))
(define (substring-replace! string start end char1 char2)
;;;; Compare
(define (string-compare string1 string2 if= if< if>)
+ (guarantee-2-strings string1 string2 'string-compare)
(let ((size1 (string-length string1))
(size2 (string-length string2)))
(let ((match (substring-match-forward string1 0 size1 string2 0 size2)))
if< if>)))))))
(define (string-prefix? string1 string2)
+ (guarantee-2-strings string1 string2 'string-prefix?)
(substring-prefix? string1 0 (string-length string1)
string2 0 (string-length string2)))
length))))
(define (string-suffix? string1 string2)
+ (guarantee-2-strings string1 string2 'string-suffix?)
(substring-suffix? string1 0 (string-length string1)
string2 0 (string-length string2)))
length))))
(define (string-compare-ci string1 string2 if= if< if>)
+ (guarantee-2-strings string1 string2 'string-compare-ci)
(let ((size1 (string-length string1))
(size2 (string-length string2)))
(let ((match (substring-match-forward-ci string1 0 size1 string2 0 size2)))
if< if>)))))))
(define (string-prefix-ci? string1 string2)
+ (guarantee-2-strings string1 string2 'string-prefix-ci?)
(substring-prefix-ci? string1 0 (string-length string1)
string2 0 (string-length string2)))
length))))
(define (string-suffix-ci? string1 string2)
+ (guarantee-2-strings string1 string2 'string-suffix-ci?)
(substring-suffix-ci? string1 0 (string-length string1)
string2 0 (string-length string2)))
1))))))
(define (string-pad-right string n #!optional char)
+ (guarantee-string string 'string-pad-right)
+ (guarantee-index/string n 'string-pad-right)
(let ((length (string-length string)))
(if (fix:= length n)
string
result))))
(define (string-pad-left string n #!optional char)
+ (guarantee-string string 'string-pad-left)
+ (guarantee-index/string n 'string-pad-left)
(let ((length (string-length string)))
(if (fix:= length n)
string
(define (substring? substring string)
;; Returns starting-position or #f if not true.
- (if (string-null? substring)
+ (guarantee-string substring 'substring?)
+ (guarantee-string string 'substring?)
+ (if (%string-null? substring)
0
(let ((len (string-length substring))
(end (string-length string))
(char (string-ref substring 0)))
(let loop ((posn -1))
- (let ((posn* (substring-find-next-char string (1+ posn) end char)))
+ (let ((posn*
+ (substring-find-next-char string (fix:+ posn 1) end char)))
(and posn*
- (let ((end* (+ posn* len)))
- (and (<= end* end)
+ (let ((end* (fix:+ posn* len)))
+ (and (fix:<= end* end)
(if (substring=? substring 0 len
string posn* end*)
posn*
- (loop posn*))))))))))
\ No newline at end of file
+ (loop posn*))))))))))
+\f
+(define-integrable (guarantee-string object procedure)
+ (if (not (string? object))
+ (error:wrong-type-argument object "string" procedure)))
+
+(define-integrable (guarantee-2-strings object1 object2 procedure)
+ (if (and (string? object1)
+ (string? object2))
+ unspecific
+ (guarantee-2-strings/fail object1 object2 procedure)))
+
+(define (guarantee-2-strings/fail object1 object2 procedure)
+ (cond ((not (string? object1))
+ (error:wrong-type-argument object1 "string" procedure))
+ ((not (string? object2))
+ (error:wrong-type-argument object1 "string" procedure))))
+
+(define-integrable (guarantee-index/string object procedure)
+ (if (not (index-fixnum? object))
+ (guarantee-index/string/fail object procedure)))
+
+(define (guarantee-index/string/fail object procedure)
+ (error:wrong-type-argument object "valid string index"
+ procedure))
+;; Not used:
+;;(define-integrable (guarantee-string-index object string procedure)
+;; (guarantee-index/string object procedure)
+;; (if (not (fix:< object (string-length string)))
+;; (error:bad-range-argument object procedure)))
+
+(define-integrable (guarantee-string-bound object string procedure)
+ (guarantee-index/string object procedure)
+ (if (not (fix:<= object (string-length string)))
+ (error:bad-range-argument object procedure)))
+
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 14.5 1989/08/12 08:18:37 cph Rel $
+$Id: vector.scm,v 14.6 1995/07/27 21:33:27 adams Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988-1995 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(object-type? (ucode-type vector) object))
(define (make-vector size #!optional fill)
- (if (default-object? fill) (set! fill false))
+ (guarantee-index/vector size 'make-vector)
+ (let ((fill (if (default-object? fill) default-vector-fill-value fill)))
+ (%make-vector size fill)))
+
+
+(define-integrable default-vector-fill-value #F)
+
+(define-integrable (%make-vector size fill)
((ucode-primitive vector-cons) size fill))
(define (vector->list vector)
+ (guarantee-vector vector 'vector->list)
(subvector->list vector 0 (vector-length vector)))
(define (vector-fill! vector value)
+ (guarantee-vector vector 'vector-fill!)
(subvector-fill! vector 0 (vector-length vector) value))
(define (subvector vector start end)
- (let ((result (make-vector (- end start))))
+ ;; VECTOR, START and END checked by `-' and SUBVECTOR-MOVE-RIGHT!
+ (let ((result (make-vector (- end start) #F)))
(subvector-move-right! vector start end result 0)
result))
(subvector vector 0 end))
(define (vector-tail vector start)
+ (guarantee-vector vector 'vector-tail)
(subvector vector start (vector-length vector)))
(define (vector-copy vector)
+ (guarantee-vector vector 'vector-copy)
(let ((length (vector-length vector)))
- (let ((new-vector (make-vector length)))
+ (let ((new-vector (%make-vector length #F)))
(subvector-move-right! vector 0 length new-vector 0)
new-vector)))
+(define (%vector-append vectors)
+ (let ((result
+ (%make-vector
+ (let loop ((vectors vectors) (length 0))
+ (if (null? vectors)
+ length
+ (begin
+ (guarantee-vector (car vectors) 'vector-append)
+ (loop (cdr vectors)
+ (fix:+ (vector-length (car vectors)) length)))))
+ #F)))
+
+ (let loop ((vectors vectors) (index 0))
+ (if (null? vectors)
+ result
+ (let ((size (vector-length (car vectors))))
+ (subvector-move-right! (car vectors) 0 size result index)
+ (loop (cdr vectors) (fix:+ index size)))))))
+
+(define (vector-append . vectors)
+ (%vector-append vectors))
+
(define (vector-grow vector length)
- (let ((new-vector (make-vector length)))
+ (guarantee-vector vector 'vector-grow)
+ (let ((new-vector (make-vector length default-vector-fill-value)))
(subvector-move-right! vector 0 (vector-length vector) new-vector 0)
new-vector))
(define (make-initialized-vector length initialization)
- (let ((vector (make-vector length)))
+ ;; LENGTH is checked by MAKE-VECTOR
+ (let ((vector (make-vector length #F)))
(let loop ((index 0))
- (if (< index length)
+ (if (fix:< index length)
(begin
(vector-set! vector index (initialization index))
- (loop (1+ index)))))
+ (loop (fix:+ index 1)))))
vector))
\f
(define (vector-map vector procedure)
+ (guarantee-vector vector 'vector-map)
(let ((length (vector-length vector)))
- (if (zero? length)
+ (if (fix:zero? length)
vector
- (let ((result (make-vector length)))
+ (let ((result (%make-vector length #F)))
(let loop ((index 0))
- (if (< index length)
+ (if (fix:< index length)
(begin
(vector-set! result
index
(procedure (vector-ref vector index)))
- (loop (1+ index)))))
+ (loop (fix:+ index 1)))))
result))))
(define (for-each-vector-element vector procedure)
+ (guarantee-vector vector 'for-each-vector-element)
(let ((length (vector-length vector)))
(let loop ((index 0))
- (if (< index length)
+ (if (fix:< index length)
(begin
(procedure (vector-ref vector index))
- (loop (1+ index)))))))
+ (loop (fix:+ index 1)))))))
(define (subvector-find-next-element vector start end item)
+ (guarantee-vector vector 'subvector-find-next-element)
+ (guarantee-index/vector start 'subvector-find-next-element)
+ (guarantee-vector-bound end vector 'subvector-find-next-element)
(let loop ((index start))
- (and (< index end)
+ (and (fix:< index end)
(if (eqv? (vector-ref vector index) item)
index
- (loop (1+ index))))))
+ (loop (fix:+ index 1))))))
(define (subvector-find-previous-element vector start end item)
- (let loop ((index (-1+ end)))
- (and (<= start index)
+ (guarantee-vector vector 'subvector-find-previous-element)
+ (guarantee-index/vector start 'subvector-find-previous-element)
+ (guarantee-vector-bound end vector 'subvector-find-previous-element)
+ (let loop ((index (fix:- end 1)))
+ (and (fix:<= start index)
(if (eqv? (vector-ref vector index) item)
index
- (loop (-1+ index))))))
+ (loop (fix:- index 1))))))
(define-integrable (vector-find-next-element vector item)
+ (guarantee-vector vector 'vector-find-next-element)
(subvector-find-next-element vector 0 (vector-length vector) item))
(define-integrable (vector-find-previous-element vector item)
+ (guarantee-vector vector 'vector-find-previous-element)
(subvector-find-previous-element vector 0 (vector-length vector) item))
(define (vector-binary-search vector key<? unwrap-key key)
+ (guarantee-vector vector 'vector-binary-search)
(let loop ((start 0) (end (vector-length vector)))
- (and (< start end)
- (let ((midpoint (quotient (+ start end) 2)))
+ (and (fix:< start end)
+ (let ((midpoint (fix:quotient (fix:+ start end) 2)))
(let ((item (vector-ref vector midpoint)))
(let ((key* (unwrap-key item)))
(cond ((key<? key key*) (loop start midpoint))
- ((key<? key* key) (loop (1+ midpoint) end))
+ ((key<? key* key) (loop (fix:+ midpoint 1) end))
(else item))))))))
-(define-integrable (vector-first vector) (vector-ref vector 0))
-(define-integrable (vector-second vector) (vector-ref vector 1))
-(define-integrable (vector-third vector) (vector-ref vector 2))
-(define-integrable (vector-fourth vector) (vector-ref vector 3))
-(define-integrable (vector-fifth vector) (vector-ref vector 4))
-(define-integrable (vector-sixth vector) (vector-ref vector 5))
-(define-integrable (vector-seventh vector) (vector-ref vector 6))
-(define-integrable (vector-eighth vector) (vector-ref vector 7))
\ No newline at end of file
+(define-integrable (safe-vector-ref vector index)
+ (guarantee-vector vector 'safe-vector-ref)
+ (guarantee-vector-index index vector 'safe-vector-ref)
+ (vector-ref vector index))
+
+(define-integrable (vector-first vector) (safe-vector-ref vector 0))
+(define-integrable (vector-second vector) (safe-vector-ref vector 1))
+(define-integrable (vector-third vector) (safe-vector-ref vector 2))
+(define-integrable (vector-fourth vector) (safe-vector-ref vector 3))
+(define-integrable (vector-fifth vector) (safe-vector-ref vector 4))
+(define-integrable (vector-sixth vector) (safe-vector-ref vector 5))
+(define-integrable (vector-seventh vector) (safe-vector-ref vector 6))
+(define-integrable (vector-eighth vector) (safe-vector-ref vector 7))
+\f
+(define-integrable (guarantee-vector object procedure)
+ (if (not (vector? object))
+ (error:wrong-type-argument object "vector" procedure)))
+
+(define-integrable (guarantee-index/vector object procedure)
+ (if (not (index-fixnum? object))
+ (guarantee-index/vector/fail object procedure)))
+
+(define (guarantee-index/vector/fail object procedure)
+ (error:wrong-type-argument object "valid vector index"
+ procedure))
+
+(define-integrable (guarantee-vector-index object vector procedure)
+ (guarantee-index/vector object procedure)
+ (if (not (fix:< object (vector-length vector)))
+ (error:bad-range-argument object procedure)))
+
+(define-integrable (guarantee-vector-bound object vector procedure)
+ (guarantee-index/vector object procedure)
+ (if (not (fix:<= object (vector-length vector)))
+ (error:bad-range-argument object procedure)))
+
projects / mit-scheme.git / commitdiff