added stupid make-list and stupid const

svn: r14693

collects/scheme/function.ss

@@ -1,6 +1,10 @@
 #lang scheme/base
 
-(provide negate curry curryr)
+(provide const negate curry curryr)
+
+(define (const c)
+  (define (const . _) c)
+  const)
 
 (define (negate f)
   (unless (procedure? f) (raise-type-error 'negate "procedure" f))

collects/scheme/list.ss

@@ -8,6 +8,8 @@
          empty
          empty?
 
+         make-list
+
          drop
          take
          split-at
@@ -81,6 +83,12 @@
 (define empty? (lambda (l) (null? l)))
 (define empty '())
 
+(define (make-list n x)
+  (unless (exact-nonnegative-integer? n)
+    (raise-type-error 'make-list "non-negative exact integer" n))
+  (let loop ([n n] [r '()])
+    (if (zero? n) r (loop (sub1 n) (cons x r)))))
+
 ;; internal use below
 (define (drop* list n) ; no error checking, returns #f if index is too large
   (if (zero? n) list (and (pair? list) (drop* (cdr list) (sub1 n)))))

collects/scribblings/reference/pairs.scrbl

@@ -513,6 +513,12 @@ Like @scheme[assoc], but finds an element using the predicate
 @defproc[(last-pair [p pair?]) pair?]{
 Returns the last pair of a (possibly improper) list.}
 
+@defproc[(make-list [k exact-nonnegative-integer?] [v any?]) list?]{
+Returns a newly constructed list of length @scheme[k], holding
+@scheme[v] in all positions.
+
+@mz-examples[(make-list 7 'foo)]}
+
 @defproc[(take [lst any/c] [pos exact-nonnegative-integer?]) list?]{
 Returns a fresh list whose elements are the first @scheme[pos] elements of
 @scheme[lst].  If @scheme[lst] has fewer than

collects/scribblings/reference/procedures.scrbl

@@ -422,6 +422,15 @@ applied.}
 @(define fun-eval (make-base-eval))
 @(interaction-eval #:eval fun-eval (require scheme/function))
 
+@defproc[(const [v any]) procedure?]{
+
+Returns a procedure that accepts any arguments and returns @scheme[v].
+
+@mz-examples[#:eval fun-eval
+((const 'foo) 1 2 3)
+((const 'foo))
+]}
+
 @defproc[(negate [proc procedure?]) procedure?]{
 
 Returns a procedure that is just like @scheme[proc], except that it

collects/srfi/1/cons.ss

@@ -34,12 +34,12 @@
 
 #lang scheme/base
 
-(require srfi/optional "selector.ss")
+(require srfi/optional "selector.ss" (only-in scheme/list make-list))
 
 (provide xcons
          make-list
          list-tabulate
-         cons*
+         (rename-out [list* cons*])
          list-copy
          circular-list
          iota)
@@ -50,9 +50,10 @@
 
 ;; Make a list of length LEN.
 
-(define (make-list len [elt #f])
+;; reprovided from mzscheme
-  (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list)
+;; (define (make-list len [elt #f])
-  (for/list ([i (in-range len)]) elt))
+;;   (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list)
+;;   (for/list ([i (in-range len)]) elt))
 
 ;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
 
@@ -66,7 +67,7 @@
 ;;
 ;; (cons first (unfold not-pair? car cdr rest values))
 
-(define cons* list*) ; same in mzscheme
+;; reprovided as mzscheme's list*
 ;; (define (cons* first . rest)
 ;;   (let recur ((x first) (rest rest))
 ;;     (if (pair? rest)

collects/tests/mzscheme/function.ss

@@ -42,6 +42,12 @@
   (test 'f object-name (rec  f (lambda (x) x)))
   (test (list 2) (rec (f . x) (if (= (car x) 3) (f 2) x)) 3))
 
+;; ---------- const ----------
+(let ()
+  (test 'foo (const 'foo))
+  (test 'foo (const 'foo) 1)
+  (test 'foo (const 'foo) 1 2 3 4 5))
+
 ;; ---------- negate ----------
 (let ()
   (define *not  (negate not))

collects/tests/mzscheme/list.ss

@@ -145,6 +145,13 @@
     (test '(1 2 3 4) sort '(4 2 3 1) < #:key getkey #:cache-keys? #t)
     (test #t = c 10)))
 
+;; ---------- make-list ----------
+(let ()
+  (test '()    make-list 0 'x)
+  (test '(x)   make-list 1 'x)
+  (test '(x x) make-list 2 'x)
+  (err/rt-test (make-list -3 'x)))
+
 ;; ---------- take/drop[-right] ----------
 (let ()
   (define-syntax-rule (vals-list expr)