~ chicken-core (chicken-5) ca281584884f5ab1d5d83e69031b5e61150a42dd

commit ca281584884f5ab1d5d83e69031b5e61150a42dd
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Mon Aug 11 19:40:22 2014 +1200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Oct 5 20:41:02 2014 +0200

    Add procedure argument checks for srfi-1's list= and lset procedures
    
    Fixes #1085.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/NEWS b/NEWS
index c1d3882a..1b66f7e4 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,7 @@
      require extras but use procedures from it.
   - SRFI-13: fix string-copy! in cases source and destination strings'
     memory areas overlap (#1135).
+  - SRFI-1: Check argument types in lset and list= procedures (#1085).
   - Fixed another, similar bug in move-memory! for overlapping memory.
   - Fixed broken specialisation for move-memory! on pointer types.
   - Fixed bug in make-kmp-restart-vector from SRFI-13.
diff --git a/srfi-1.scm b/srfi-1.scm
index a347fea9..40b9f56a 100644
--- a/srfi-1.scm
+++ b/srfi-1.scm
@@ -402,6 +402,7 @@
 (define (null-list? l) (##core#inline "C_i_null_list_p" l))           
 
 (define (list= = . lists)
+  (##sys#check-closure = 'list=)
   (or (null? lists) ; special case
       (let lp1 ((list-a (car lists)) (others (cdr lists)))
 	(or (null? others)
@@ -1458,6 +1459,7 @@
 
 (define (lset<= = . lists)
 ;  (check-arg procedure? = lset<=)
+  (##sys#check-closure = 'lset<=)
   (or (not (pair? lists)) ; 0-ary case
       (let lp ((s1 (car lists)) (rest (cdr lists)))
 	(or (not (pair? rest))
@@ -1468,6 +1470,7 @@
 
 (define (lset= = . lists)
 ;  (check-arg procedure? = lset=)
+  (##sys#check-closure = 'lset=)
   (or (not (pair? lists)) ; 0-ary case
       (let lp ((s1 (car lists)) (rest (cdr lists)))
 	(or (not (pair? rest))
@@ -1480,12 +1483,14 @@
 
 (define (lset-adjoin = lis . elts)
 ;  (check-arg procedure? = lset-adjoin)
+  (##sys#check-closure = 'lset-adjoin)
   (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans)))
 	lis elts))
 
 
 (define (lset-union = . lists)
 ;  (check-arg procedure? = lset-union)
+  (##sys#check-closure = 'lset-union)
   (reduce (lambda (lis ans)		; Compute ANS + LIS.
 	    (cond ((null? lis) ans)	; Don't copy any lists
 		  ((null? ans) lis) 	; if we don't have to.
@@ -1499,6 +1504,7 @@
 
 (define (lset-union! = . lists)
 ;  (check-arg procedure? = lset-union!)
+  (##sys#check-closure = 'lset-union!)
   (reduce (lambda (lis ans)		; Splice new elts of LIS onto the front of ANS.
 	    (cond ((null? lis) ans)	; Don't copy any lists
 		  ((null? ans) lis) 	; if we don't have to.
@@ -1515,6 +1521,7 @@
 
 (define (lset-intersection = lis1 . lists)
 ;  (check-arg procedure? = lset-intersection)
+  (##sys#check-closure = 'lset-intersection)
   (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
     (cond ((any null-list? lists) '())		; Short cut
 	  ((null? lists)          lis1)		; Short cut
@@ -1524,6 +1531,7 @@
 
 (define (lset-intersection! = lis1 . lists)
 ;  (check-arg procedure? = lset-intersection!)
+  (##sys#check-closure = 'lset-intersection!)
   (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
     (cond ((any null-list? lists) '())		; Short cut
 	  ((null? lists)          lis1)		; Short cut
@@ -1534,6 +1542,7 @@
 
 (define (lset-difference = lis1 . lists)
 ;  (check-arg procedure? = lset-difference)
+  (##sys#check-closure = 'lset-difference)
   (let ((lists (filter pair? lists)))	; Throw out empty lists.
     (cond ((null? lists)     lis1)	; Short cut
 	  ((memq lis1 lists) '())	; Short cut
@@ -1544,6 +1553,7 @@
 
 (define (lset-difference! = lis1 . lists)
 ;  (check-arg procedure? = lset-difference!)
+  (##sys#check-closure = 'lset-difference!)
   (let ((lists (filter pair? lists)))	; Throw out empty lists.
     (cond ((null? lists)     lis1)	; Short cut
 	  ((memq lis1 lists) '())	; Short cut
@@ -1555,6 +1565,7 @@
 
 (define (lset-xor = . lists)
 ;  (check-arg procedure? = lset-xor)
+  (##sys#check-closure = 'lset-xor)
   (reduce (lambda (b a)			; Compute A xor B:
 	    ;; Note that this code relies on the constant-time
 	    ;; short-cuts provided by LSET-DIFF+INTERSECTION,
@@ -1577,6 +1588,7 @@
 
 (define (lset-xor! = . lists)
 ;  (check-arg procedure? = lset-xor!)
+  (##sys#check-closure = 'lset-xor!)
   (reduce (lambda (b a)			; Compute A xor B:
 	    ;; Note that this code relies on the constant-time
 	    ;; short-cuts provided by LSET-DIFF+INTERSECTION,
@@ -1600,6 +1612,7 @@
 
 (define (lset-diff+intersection = lis1 . lists)
 ;  (check-arg procedure? = lset-diff+intersection)
+  (##sys#check-closure = 'lset-diff+intersection)
   (cond ((every null-list? lists) (values lis1 '()))	; Short cut
 	((memq lis1 lists)        (values '() lis1))	; Short cut
 	(else (partition (lambda (elt)
@@ -1609,6 +1622,7 @@
 
 (define (lset-diff+intersection! = lis1 . lists)
 ;  (check-arg procedure? = lset-diff+intersection!)
+  (##sys#check-closure = 'lset-diff+intersection!)
   (cond ((every null-list? lists) (values lis1 '()))	; Short cut
 	((memq lis1 lists)        (values '() lis1))	; Short cut
 	(else (partition! (lambda (elt)