diff --git a/collects/scheme/function.ss b/collects/scheme/function.ss index ffe2962b95..56a55e7a38 100644 --- a/collects/scheme/function.ss +++ b/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)) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index cedd06621c..25820d9c9d 100644 --- a/collects/scheme/list.ss +++ b/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))))) diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index cc60d0af62..14c990dc76 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/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 diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index e062acab2d..329ca50ed4 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/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 diff --git a/collects/srfi/1/cons.ss b/collects/srfi/1/cons.ss index 21ff7097ea..45230fb774 100644 --- a/collects/srfi/1/cons.ss +++ b/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]) - (check-arg (lambda (n) (and (integer? n) (>= n 0))) len 'make-list) - (for/list ([i (in-range len)]) elt)) +;; reprovided from mzscheme +;; (define (make-list len [elt #f]) +;; (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) diff --git a/collects/tests/mzscheme/function.ss b/collects/tests/mzscheme/function.ss index 8f60fd65c7..9dfa210674 100644 --- a/collects/tests/mzscheme/function.ss +++ b/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)) diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index ca1d8877db..cf6d65578c 100644 --- a/collects/tests/mzscheme/list.ss +++ b/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)