From c026e2a5faa6974155e20cb82e39256088c2783b Mon Sep 17 00:00:00 2001 From: Stephen Adams Date: Thu, 27 Jul 1995 21:33:44 +0000 Subject: [PATCH] General improvement of library procedures: Improved error checking. More procedures have checks. Code is organized to avoid duplicate checks and to reduce bloat from integrated GUARANTEE-* procedures. Makes use of new INDEX-FIXNUM? predicate. Replaced some recurive algorithms by iterative equivalents. New procedure: VECTOR-APPEND --- v7/src/runtime/list.scm | 440 ++++++++++++++++++++++++++++++-------- v7/src/runtime/string.scm | 202 ++++++++++++++--- v7/src/runtime/vector.scm | 137 +++++++++--- 3 files changed, 621 insertions(+), 158 deletions(-) diff --git a/v7/src/runtime/list.scm b/v7/src/runtime/list.scm index 36cf54f37..4b6b0e823 100644 --- a/v7/src/runtime/list.scm +++ b/v7/src/runtime/list.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -35,6 +35,35 @@ MIT in each case. |# ;;;; 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)) (define-primitives @@ -52,12 +81,12 @@ MIT in each case. |# (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)) @@ -68,20 +97,20 @@ MIT in each case. |# 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 @@ -95,24 +124,24 @@ MIT in each case. |# (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))) @@ -139,32 +168,73 @@ MIT in each case. |# (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))) ;;;; Weak Pairs @@ -345,6 +415,9 @@ MIT in each case. |# ;;; everyone would write in assembly language. (define (append . lists) + (%append lists)) + +(define (%append lists) (let ((lists (reverse! lists))) (if (null? lists) '() @@ -374,6 +447,9 @@ MIT in each case. |# (cdr rest))))))) (define (append! . lists) + (%append! lists)) + +(define (%append! lists) (if (null? lists) '() (let loop ((head (car lists)) (tail (cdr lists))) @@ -388,12 +464,15 @@ MIT in each case. |# (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) @@ -408,40 +487,128 @@ MIT in each case. |# new-cdr)))) ;;;; 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)) @@ -498,25 +665,25 @@ MIT in each case. |# (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)))) ;;;; Generalized List Operations @@ -532,6 +699,28 @@ MIT in each case. |# '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*) @@ -544,6 +733,27 @@ MIT in each case. |# '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*) @@ -688,16 +898,37 @@ MIT in each case. |# (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 @@ -731,13 +962,28 @@ MIT in each case. |# (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!) @@ -754,7 +1000,11 @@ MIT in each case. |# (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)) + diff --git a/v7/src/runtime/string.scm b/v7/src/runtime/string.scm index 186c595ca..483ed52f5 100644 --- a/v7/src/runtime/string.scm +++ b/v7/src/runtime/string.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -86,111 +86,153 @@ MIT in each case. |# ;;; 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 string2) + (guarantee-2-strings string1 string2 'string-ci>?) (substring-ci=? string1 string2) + (guarantee-2-strings string1 string2 'string-ci>=?) (not (substring=? string1 string2) + (guarantee-2-strings string1 string2 'string-ci>=?) (not (substring-cistring 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))))))) @@ -200,44 +242,72 @@ MIT in each case. |# (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)) ;;;; 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))) @@ -251,16 +321,26 @@ MIT in each case. |# (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))) @@ -274,16 +354,24 @@ MIT in each case. |# (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))) (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 @@ -318,10 +406,11 @@ MIT in each case. |# (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) @@ -350,6 +439,7 @@ MIT in each case. |# 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) @@ -363,6 +453,7 @@ MIT in each case. |# ;;;; 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))) @@ -374,6 +465,7 @@ MIT in each case. |# 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))) @@ -385,6 +477,7 @@ MIT in each case. |# 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))) @@ -396,6 +489,7 @@ MIT in each case. |# 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))) @@ -407,6 +501,7 @@ MIT in each case. |# 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))) @@ -418,6 +513,7 @@ MIT in each case. |# 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))) @@ -463,6 +559,8 @@ MIT in each case. |# 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 @@ -476,6 +574,8 @@ MIT in each case. |# 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 @@ -491,17 +591,55 @@ MIT in each case. |# (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*)))))))))) + +(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))) + diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm index 6054e71ea..96a42cb36 100644 --- a/v7/src/runtime/vector.scm +++ b/v7/src/runtime/vector.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -46,17 +46,27 @@ MIT in each case. |# (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)) @@ -64,85 +74,150 @@ MIT in each case. |# (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)) (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