adding more of the primitives we need for cs19

compiler/bootstrapped-primitives.rkt

@@ -80,9 +80,14 @@
                                  ,(make-PopControlFrame)
                                  ,(make-GotoStatement (make-Reg 'proc)))))))
 
+
+
 (: make-bootstrapped-primitive-code (Symbol Any -> (Listof Statement)))
+;; Generates the bootstrapped code for some of the primitives.  Note: the source must compile
+;; under #%kernel, or else!
 (define make-bootstrapped-primitive-code
-  (let ([ns (make-base-namespace)])
+  (let ([ns (make-base-empty-namespace)])
+    (parameterize ([current-namespace ns]) (namespace-require ''#%kernel))
     (lambda (name src)
       (parameterize ([current-defined-name name])
         (append
@@ -93,6 +98,50 @@
 
 
 
+(: make-map-src (Symbol Symbol -> Any))
+;; Generates the code for map.
+(define (make-map-src name combiner)
+  `(letrec-values ([(first-tuple) (lambda (lists)
+                                   (if (null? lists)
+                                       '()
+                                       (cons (car (car lists))
+                                             (first-tuple (cdr lists)))))]
+                  [(rest-lists) (lambda (lists)
+                                  (if (null? lists)
+                                      '()
+                                      (cons (cdr (car lists))
+                                            (rest-lists (cdr lists)))))]
+                  [(all-empty?) (lambda (lists)
+                                  (if (null? lists)
+                                      #t
+                                      (if (null? (car lists))
+                                          (all-empty? (cdr lists))
+                                          #f)))]
+                  [(some-empty?) (lambda (lists)
+                                   (if (null? lists)
+                                       #f
+                                       (if (null? (car lists))
+                                           #t
+                                           
+                                           (some-empty? (cdr lists)))))]
+                  [(do-it) (lambda (f lists)
+                             (letrec-values ([(loop) (lambda (lists)
+                                                       (if (all-empty? lists)
+                                                           null
+                                                           (if (some-empty? lists)
+                                                               (error 
+                                                                ',name 
+                                                                "all lists must have the same size")
+                                                               (,combiner (apply f (first-tuple lists))
+                                                                          (loop (rest-lists lists))))))])
+                                            (loop lists)))])
+                 (lambda (f . args)
+                   (do-it f args))))
+
+
+
+
+
 
 (: get-bootstrapping-code (-> (Listof Statement)))
 (define (get-bootstrapping-code)
@@ -103,22 +152,22 @@
    ;; Other primitives
    (make-bootstrapped-primitive-code 
     'map 
-    '(letrec ([map (lambda (f l)
+    (make-map-src 'map 'cons))
-                     (if (null? l)
-                         null
-                         (cons (f (car l))
-                               (map f (cdr l)))))])
-       map))
 
    (make-bootstrapped-primitive-code
     'for-each
-    '(letrec ([for-each (lambda (f l)
+    (make-map-src 'for-each 'begin))
-			  (if (null? l)
-			      null
-			      (begin (f (car l))
-				     (for-each f (cdr l)))))])
-       for-each))
 
+   (make-bootstrapped-primitive-code
+    'andmap
+    (make-map-src 'andmap 'and))
+
+   (make-bootstrapped-primitive-code
+    'ormap
+    (make-map-src 'ormap 'or))
+
+   
+   
    (make-bootstrapped-primitive-code
     'caar
     '(lambda (x)
@@ -127,47 +176,47 @@
 
    (make-bootstrapped-primitive-code
     'memq
-    '(letrec ([memq (lambda (x l)
+    '(letrec-values ([(memq) (lambda (x l)
-		      (if (null? l)
+                               (if (null? l)
-			  #f
+                                   #f
-			  (if (eq? x (car l))
+                                   (if (eq? x (car l))
-			      l
+                                       l
-			      (memq x (cdr l)))))])
+                                       (memq x (cdr l)))))])
-       memq))
+                    memq))
 
    (make-bootstrapped-primitive-code
     'assq
-    '(letrec ([assq (lambda (x l)
+    '(letrec-values ([(assq) (lambda (x l)
-		     (if (null? l)
+                               (if (null? l)
-			 #f
+                                   #f
-			 (if (eq? x (caar l))
+                                   (if (eq? x (caar l))
-			     (car l)
+                                       (car l)
-			     (assq x (cdr l)))))])
+                                       (assq x (cdr l)))))])
-      assq))
+                    assq))
 
    (make-bootstrapped-primitive-code
     'length
-    '(letrec ([length-iter (lambda (l i)
+    '(letrec-values ([(length-iter) (lambda (l i)
-			    (if (null? l)
+                                      (if (null? l)
-				i
+                                          i
-				(length-iter (cdr l) (add1 i))))])
+                                          (length-iter (cdr l) (add1 i))))])
-      (lambda (l) (length-iter l 0))))
+                    (lambda (l) (length-iter l 0))))
-			  
+   
 
    (make-bootstrapped-primitive-code
     'append
-    '(letrec ([append-many (lambda (lsts)
+    '(letrec-values ([(append-many) (lambda (lsts)
-			     (if (null? lsts)
+                                      (if (null? lsts)
-				 null
+                                          null
-				 (if (null? (cdr lsts))
+                                          (if (null? (cdr lsts))
-				     (car lsts)
+                                              (car lsts)
-				     (append-2 (car lsts)
+                                              (append-2 (car lsts)
-					       (append-many (cdr lsts))))))]
+                                                        (append-many (cdr lsts))))))]
-	      [append-2 (lambda (l1 l2)
+                     [(append-2) (lambda (l1 l2)
-			  (if (null? l1) 
+                                   (if (null? l1) 
-			      l2
+                                       l2
-			      (cons (car l1) (append-2 (cdr l1) l2))))])
+                                       (cons (car l1) (append-2 (cdr l1) l2))))])
-       (lambda args (append-many args))))
+                    (lambda args (append-many args))))
 
 
    (make-bootstrapped-primitive-code

js-assembler/runtime-src/baselib-primitives.js

@@ -13,6 +13,12 @@
     // pull from external modules should be listed here, and should otherwise not
     // show up outside this section!
     var isNumber = baselib.numbers.isNumber;
+
+    var isReal = baselib.numbers.isReal;
+    var isComplex = isComplex;
+    var isRational = isRational;
+
+
     var isNatural = baselib.numbers.isNatural;
     var isPair = baselib.lists.isPair;
     var isList = baselib.lists.isList;
@@ -778,7 +784,7 @@
             var s = checkString(MACHINE, 'string=?', 0).toString();
 	    var i;
             for (i = 1; i < MACHINE.argcount; i++) {
-                if (checkString(MACHINE, 'string=?', i).toString() !== s) {
+                if (s !== checkString(MACHINE, 'string=?', i).toString()) {
                     return false;
                 }
             }
@@ -786,6 +792,68 @@
         });
 
 
+    installPrimitiveProcedure(
+        'string<=?',
+        baselib.arity.makeArityAtLeast(1),
+        function (MACHINE) {
+            var s = checkString(MACHINE, 'string<=?', 0).toString();
+	    var i;
+            for (i = 1; i < MACHINE.argcount; i++) {
+                if (! (s <= checkString(MACHINE, 'string<=?', i).toString())) {
+                    return false;
+                }
+            }
+            return true;
+        });
+
+    installPrimitiveProcedure(
+        'string<?',
+        baselib.arity.makeArityAtLeast(1),
+        function (MACHINE) {
+            var s = checkString(MACHINE, 'string<?', 0).toString();
+	    var i;
+            for (i = 1; i < MACHINE.argcount; i++) {
+                if (! (s < checkString(MACHINE, 'string<?', i).toString())) {
+                    return false;
+                }
+            }
+            return true;
+        });
+
+    installPrimitiveProcedure(
+        'string>=?',
+        baselib.arity.makeArityAtLeast(1),
+        function (MACHINE) {
+            var s = checkString(MACHINE, 'string>=?', 0).toString();
+	    var i;
+            for (i = 1; i < MACHINE.argcount; i++) {
+                if (! (s >= checkString(MACHINE, 'string>=?', i).toString())) {
+                    return false;
+                }
+            }
+            return true;
+        });
+
+    installPrimitiveProcedure(
+        'string>?',
+        baselib.arity.makeArityAtLeast(1),
+        function (MACHINE) {
+            var s = checkString(MACHINE, 'string>?', 0).toString();
+	    var i;
+            for (i = 1; i < MACHINE.argcount; i++) {
+                if (! (s > checkString(MACHINE, 'string>?', i).toString())) {
+                    return false;
+                }
+            }
+            return true;
+        });
+
+
+
+
+
+
+
     installPrimitiveProcedure(
         'string-append',
         baselib.arity.makeArityAtLeast(0),
@@ -1085,6 +1153,28 @@
 	    return isNumber(MACHINE.env[MACHINE.env.length - 1]);
 	});
 
+    installPrimitiveProcedure(
+	'real?',
+	1,
+	function(MACHINE) {
+	    return isReal(MACHINE.env[MACHINE.env.length - 1]);
+	});
+    installPrimitiveProcedure(
+	'complex?',
+	1,
+	function(MACHINE) {
+	    return isComplex(MACHINE.env[MACHINE.env.length - 1]);
+	});
+
+    installPrimitiveProcedure(
+	'rational?',
+	1,
+	function(MACHINE) {
+	    return isRational(MACHINE.env[MACHINE.env.length - 1]);
+	});
+
+
+
 
     installPrimitiveProcedure(
         'abs',
@@ -1458,6 +1548,42 @@
         });
 
 
+    installPrimitiveProcedure(
+        'min',
+        baselib.arity.makeArityAtLeast(1),
+        function(MACHINE) {
+            var i;
+            var next;
+            var currentMin = checkReal(MACHINE, 'min', 0);
+            for (i = 1; i < MACHINE.argcount; i++) {
+                next = checkReal(MACHINE, 'min', i);
+                if (baselib.numbers.lessThan(next, currentMin)) {
+                    currentMin = next;
+                }
+            }
+            return currentMin;
+        });
+
+    installPrimitiveProcedure(
+        'max',
+        baselib.arity.makeArityAtLeast(1),
+        function(MACHINE) {
+            var i;
+            var next;
+            var currentMax = checkReal(MACHINE, 'min', 0);
+            for (i = 1; i < MACHINE.argcount; i++) {
+                next = checkReal(MACHINE, 'min', i);
+                if (baselib.numbers.greaterThan(next, currentMax)) {
+                    currentMax = next;
+                }
+            }
+            return currentMax;
+        });
+
+
+
+
+
 
     installPrimitiveProcedure(
         'error',

lang/base.rkt

@@ -11,9 +11,13 @@
                      define-syntax-parameter
                      syntax-parameterize
                      )
-         (all-from-out "private/list.rkt"))
+         (all-from-out "private/list.rkt")
+         (all-from-out "list.rkt")
+         (all-from-out "private/map.rkt"))
          
-(require "private/list.rkt")
+(require "private/list.rkt"
+         "private/map.rkt"
+         "list.rkt")
 
 
 ;; Kludge: This forces modbeg to be compiled and packaged.

lang/kernel.rkt

@@ -11,6 +11,8 @@
                   parameterization-key
                   break-enabled-key))
 
+(require (prefix-in kernel: '#%kernel))
+
 
 (provide exception-handler-key
          parameterization-key
@@ -159,7 +161,9 @@
          eq?
          values
 
-         apply
+         ;; The version of apply in racket/base is doing some stuff that
+         ;; we are not handling yet.  So we expose the raw apply here instead.
+         (rename-out [kernel:apply apply])
          call-with-values
 
          gensym)
@@ -291,9 +295,9 @@ vector?
 ;;  bytes?
 ;;  byte?
 number?
-;;  complex?
+complex?
-;;  real?
+real?
-;;  rational?
+rational?
 integer?
 exact?
 exact-nonnegative-integer?
@@ -330,8 +334,8 @@ exact-nonnegative-integer?
   reverse
   for-each
   map
-;;  andmap
+  andmap
-;;  ormap
+  ormap
 memq
 ;;  memv
   member

lang/list.rkt

@@ -0,0 +1,367 @@
+#lang s-exp "kernel.rkt"
+
+(require (for-syntax racket/base))
+
+(provide first second third fourth fifth sixth seventh eighth ninth tenth
+
+         last-pair last rest
+
+         cons?
+         empty
+         empty?
+
+         make-list
+
+         drop
+         take
+         split-at
+         drop-right
+         take-right
+         split-at-right
+
+         append*
+         flatten
+         add-between
+         ;;remove-duplicates
+         filter-map
+         count
+         partition
+
+         argmin
+         argmax
+
+         ;; convenience
+         append-map
+         filter-not
+         ;;shuffle
+         )
+
+(define (first x)
+  (if (and (pair? x) (list? x))
+    (car x)
+    (raise-type-error 'first "non-empty list" x)))
+
+(define-syntax define-lgetter
+  (syntax-rules ()
+    [(_ name npos)
+     (define (name l0)
+       (if (list? l0)
+         (let loop ([l l0] [pos npos])
+           (if (pair? l)
+             (if (eq? pos 1) (car l) (loop (cdr l) (sub1 pos)))
+             (raise-type-error
+              'name (format "list with ~a or more items" npos) l0)))
+         (raise-type-error 'name "list" l0)))]))
+(define-lgetter second  2)
+(define-lgetter third   3)
+(define-lgetter fourth  4)
+(define-lgetter fifth   5)
+(define-lgetter sixth   6)
+(define-lgetter seventh 7)
+(define-lgetter eighth  8)
+(define-lgetter ninth   9)
+(define-lgetter tenth   10)
+
+(define (last-pair l)
+  (if (pair? l)
+    (let loop ([l l] [x (cdr l)])
+      (if (pair? x)
+        (loop x (cdr x))
+        l))
+    (raise-type-error 'last-pair "pair" l)))
+
+(define (last l)
+  (if (and (pair? l) (list? l))
+    (let loop ([l l] [x (cdr l)])
+      (if (pair? x)
+        (loop x (cdr x))
+        (car l)))
+    (raise-type-error 'last "non-empty list" l)))
+
+(define (rest l)
+  (if (and (pair? l) (list? l))
+    (cdr l)
+    (raise-type-error 'rest "non-empty list" l)))
+
+(define cons? (lambda (l) (pair? l)))
+(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)))))
+(define (too-large who list n)
+  (raise-mismatch-error
+   who
+   (format "index ~e too large for list~a: "
+           n (if (list? list) "" " (not a proper list)"))
+   list))
+
+(define (take list0 n0)
+  (unless (exact-nonnegative-integer? n0)
+    (raise-type-error 'take "non-negative exact integer" 1 list0 n0))
+  (let loop ([list list0] [n n0])
+    (cond [(zero? n) '()]
+          [(pair? list) (cons (car list) (loop (cdr list) (sub1 n)))]
+          [else (too-large 'take list0 n0)])))
+
+(define (split-at list0 n0)
+  (unless (exact-nonnegative-integer? n0)
+    (raise-type-error 'split-at "non-negative exact integer" 1 list0 n0))
+  (let loop ([list list0] [n n0] [pfx '()])
+    (cond [(zero? n) (values (reverse pfx) list)]
+          [(pair? list) (loop (cdr list) (sub1 n) (cons (car list) pfx))]
+          [else (too-large 'split-at list0 n0)])))
+
+(define (drop list n)
+  ;; could be defined as `list-tail', but this is better for errors anyway
+  (unless (exact-nonnegative-integer? n)
+    (raise-type-error 'drop "non-negative exact integer" 1 list n))
+  (or (drop* list n) (too-large 'drop list n)))
+
+;; take/drop-right are originally from srfi-1, uses the same lead-pointer trick
+
+(define (take-right list n)
+  (unless (exact-nonnegative-integer? n)
+    (raise-type-error 'take-right "non-negative exact integer" 1 list n))
+  (let loop ([list list]
+             [lead (or (drop* list n) (too-large 'take-right list n))])
+    ;; could throw an error for non-lists, but be more like `take'
+    (if (pair? lead)
+      (loop (cdr list) (cdr lead))
+      list)))
+
+(define (drop-right list n)
+  (unless (exact-nonnegative-integer? n)
+    (raise-type-error 'drop-right "non-negative exact integer" n))
+  (let loop ([list list]
+             [lead (or (drop* list n) (too-large 'drop-right list n))])
+    ;; could throw an error for non-lists, but be more like `drop'
+    (if (pair? lead)
+      (cons (car list) (loop (cdr list) (cdr lead)))
+      '())))
+
+(define (split-at-right list n)
+  (unless (exact-nonnegative-integer? n)
+    (raise-type-error 'split-at-right "non-negative exact integer" n))
+  (let loop ([list list]
+             [lead (or (drop* list n) (too-large 'split-at-right list n))]
+             [pfx '()])
+    ;; could throw an error for non-lists, but be more like `split-at'
+    (if (pair? lead)
+      (loop (cdr list) (cdr lead) (cons (car list) pfx))
+      (values (reverse pfx) list))))
+
+(define append*
+  (case-lambda [(ls) (apply append ls)] ; optimize common case
+               [(l1 l2) (apply append l1 l2)]
+               [(l1 l2 l3) (apply append l1 l2 l3)]
+               [(l1 l2 l3 l4) (apply append l1 l2 l3 l4)]
+               [(l . lss) (apply apply append l lss)]))
+
+(define (flatten orig-sexp)
+  (let loop ([sexp orig-sexp] [acc null])
+    (cond [(null? sexp) acc]
+          [(pair? sexp) (loop (car sexp) (loop (cdr sexp) acc))]
+          [else (cons sexp acc)])))
+
+;; General note: many non-tail recursive, which are just as fast in mzscheme
+
+(define (add-between l x)
+  (cond [(not (list? l)) (raise-type-error 'add-between "list" 0 l x)]
+        [(null? l) null]
+        [(null? (cdr l)) l]
+        [else (cons (car l)
+                    (let loop ([l (cdr l)])
+                      (if (null? l)
+                        null
+                        (list* x (car l) (loop (cdr l))))))]))
+
+;; This is nice for symmetry, but confusing to use, and we can get it using
+;; something like (append* (add-between l ls)), or even `flatten' for an
+;; arbitrary nesting.
+;; (define (lists-join ls l)
+;;   (cond [(null? ls) ls]
+;;         [(null? l) ls] ; empty separator
+;;         [else (append (car ls)
+;;                       (let loop ([ls (cdr ls)])
+;;                         (if (null? ls)
+;;                           ls
+;;                           (append l (car ls) (loop (cdr ls))))))]))
+
+#;(define (remove-duplicates l [=? equal?] #:key [key #f])
+  ;; `no-key' is used to optimize the case for long lists, it could be done for
+  ;; shorter ones too, but that adds a ton of code to the result (about 2k).
+  (define-syntax-rule (no-key x) x)
+  (unless (list? l) (raise-type-error 'remove-duplicates "list" l))
+  (let* ([len (length l)]
+         [h (cond [(<= len 1) #t]
+                  [(<= len 40) #f]
+                  [(eq? =? eq?) (make-hasheq)]
+                  [(eq? =? equal?) (make-hash)]
+                  [else #f])])
+    (case h
+      [(#t) l]
+      [(#f)
+       ;; plain n^2 list traversal (optimized for common cases) for short lists
+       ;; and for equalities other than `eq?' or `equal?'  The length threshold
+       ;; above (40) was determined by trying it out with lists of length n
+       ;; holding (random n) numbers.
+       (let ([key (or key (lambda (x) x))])
+         (let-syntax ([loop (syntax-rules ()
+                              [(_ search)
+                               (let loop ([l l] [seen null])
+                                 (if (null? l)
+                                   l
+                                   (let* ([x (car l)] [k (key x)] [l (cdr l)])
+                                     (if (search k seen)
+                                       (loop l seen)
+                                       (cons x (loop l (cons k seen)))))))])])
+           (cond [(eq? =? equal?) (loop member)]
+                 [(eq? =? eq?)    (loop memq)]
+                 [(eq? =? eqv?)   (loop memv)]
+                 [else (loop (lambda (x seen)
+                               (ormap (lambda (y) (=? x y)) seen)))])))]
+      [else
+       ;; Use a hash for long lists with simple hash tables.
+       (let-syntax ([loop
+                     (syntax-rules ()
+                       [(_ getkey)
+                        (let loop ([l l])
+                          (if (null? l)
+                            l
+                            (let* ([x (car l)] [k (getkey x)] [l (cdr l)])
+                              (if (hash-ref h k #f)
+                                (loop l)
+                                (begin (hash-set! h k #t)
+                                       (cons x (loop l)))))))])])
+         (if key (loop key) (loop no-key)))])))
+
+(define (filter-map f l . ls)
+  (unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls))))
+    (raise-type-error
+     'filter-map (format "procedure (arity ~a)" (add1 (length ls))) f))
+  (unless (and (list? l) (andmap list? ls))
+    (raise-type-error
+     'filter-map "proper list"
+     (ormap (lambda (x) (and (not (list? x)) x)) (cons l ls))))
+  (if (pair? ls)
+    (let ([len (length l)])
+      (if (andmap (lambda (l) (= len (length l))) ls)
+        (let loop ([l l] [ls ls])
+          (if (null? l)
+            null
+            (let ([x (apply f (car l) (map car ls))])
+              (if x
+                (cons x (loop (cdr l) (map cdr ls)))
+                (loop (cdr l) (map cdr ls))))))
+        (error 'filter-map "all lists must have same size")))
+    (let loop ([l l])
+      (if (null? l)
+        null
+        (let ([x (f (car l))])
+          (if x (cons x (loop (cdr l))) (loop (cdr l))))))))
+
+;; very similar to `filter-map', one more such function will justify some macro
+(define (count f l . ls)
+  (unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls))))
+    (raise-type-error
+     'count (format "procedure (arity ~a)" (add1 (length ls))) f))
+  (unless (and (list? l) (andmap list? ls))
+    (raise-type-error
+     'count "proper list"
+     (ormap (lambda (x) (and (not (list? x)) x)) (cons l ls))))
+  (if (pair? ls)
+    (let ([len (length l)])
+      (if (andmap (lambda (l) (= len (length l))) ls)
+        (let loop ([l l] [ls ls] [c 0])
+          (if (null? l)
+            c
+            (loop (cdr l) (map cdr ls)
+                  (if (apply f (car l) (map car ls)) (add1 c) c))))
+        (error 'count "all lists must have same size")))
+    (let loop ([l l] [c 0])
+      (if (null? l) c (loop (cdr l) (if (f (car l)) (add1 c) c))))))
+
+;; Originally from srfi-1 -- shares common tail with the input when possible
+;; (define (partition f l)
+;;   (unless (and (procedure? f) (procedure-arity-includes? f 1))
+;;     (raise-type-error 'partition "procedure (arity 1)" f))
+;;   (unless (list? l) (raise-type-error 'partition "proper list" l))
+;;   (let loop ([l l])
+;;     (if (null? l)
+;;       (values null null)
+;;       (let* ([x (car l)] [x? (f x)])
+;;         (let-values ([(in out) (loop (cdr l))])
+;;           (if x?
+;;             (values (if (pair? out) (cons x in) l) out)
+;;             (values in (if (pair? in) (cons x out) l))))))))
+
+;; But that one is slower than this, probably due to value packaging
+(define (partition pred l)
+  (unless (and (procedure? pred) (procedure-arity-includes? pred 1))
+    (raise-type-error 'partition "procedure (arity 1)" 0 pred l))
+  (unless (list? l) (raise-type-error 'partition "proper list" 1 pred l))
+  (let loop ([l l] [i '()] [o '()])
+    (if (null? l)
+      (values (reverse i) (reverse o))
+      (let ([x (car l)] [l (cdr l)])
+        (if (pred x) (loop l (cons x i) o) (loop l i (cons x o)))))))
+
+(define append-map
+  (case-lambda [(f l) (apply append (map f l))]
+               [(f l1 l2) (apply append (map f l1 l2))]
+               [(f l . ls) (apply append (apply map f l ls))]))
+
+;; this is an exact copy of `filter' in scheme/private/list, with the
+;; `if' branches swapped.
+(define (filter-not f list)
+  (unless (and (procedure? f)
+               (procedure-arity-includes? f 1))
+    (raise-type-error 'filter-not "procedure (arity 1)" 0 f list))
+  (unless (list? list)
+    (raise-type-error 'filter-not "proper list" 1 f list))
+  ;; accumulating the result and reversing it is currently slightly
+  ;; faster than a plain loop
+  (let loop ([l list] [result null])
+    (if (null? l)
+      (reverse result)
+      (loop (cdr l) (if (f (car l)) result (cons (car l) result))))))
+
+;(define (shuffle l)
+;  (sort l < #:key (lambda (_) (random)) #:cache-keys? #t))
+
+;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X
+(define (mk-min cmp name f xs)
+  (unless (and (procedure? f)
+               (procedure-arity-includes? f 1))
+    (raise-type-error name "procedure (arity 1)" 0 f xs))
+  (unless (and (list? xs)
+               (pair? xs))
+    (raise-type-error name "non-empty list" 1 f xs))
+  (let ([init-min-var (f (car xs))])
+    (unless (real? init-min-var)
+      (raise-type-error name "procedure that returns real numbers" 0 f xs))
+    (let loop ([min (car xs)]
+               [min-var init-min-var]
+               [xs (cdr xs)])
+      (cond
+        [(null? xs) min]
+        [else
+         (let ([new-min (f (car xs))])
+           (unless (real? new-min)
+             (raise-type-error name "procedure that returns real numbers" 0 f xs))
+           (cond
+             [(cmp new-min min-var)
+              (loop (car xs) new-min (cdr xs))]
+             [else
+              (loop min min-var (cdr xs))]))]))))
+
+(define (argmin f xs) (mk-min < 'argmin f xs))
+(define (argmax f xs) (mk-min > 'argmax f xs))

lang/private/map.rkt

@@ -0,0 +1,123 @@
+#lang s-exp "../kernel.rkt"
+(provide (rename-out [map2 map]
+                     [for-each2 for-each]
+                     [andmap2 andmap]
+                     [ormap2 ormap]))
+  
+;; -------------------------------------------------------------------------
+
+(define map2
+  (let ([map
+         (case-lambda
+           [(f l)
+            (if (and (procedure? f)
+                     (procedure-arity-includes? f 1)
+                     (list? l))
+                (let loop ([l l])
+                  (cond
+                   [(null? l) null]
+                   [else (cons (f (car l)) (loop (cdr l)))]))
+                (map f l))]
+           [(f l1 l2)
+            (if (and (procedure? f)
+                     (procedure-arity-includes? f 2)
+                     (list? l1)
+                     (list? l2)
+                     (= (length l1) (length l2)))
+                (let loop ([l1 l1][l2 l2])
+                  (cond
+                   [(null? l1) null]
+                   [else (cons (f (car l1) (car l2)) 
+                               (loop (cdr l1) (cdr l2)))]))
+                (map f l1 l2))]
+           [(f . args) (apply map f args)])])
+    map))
+
+(define for-each2
+  (let ([for-each
+         (case-lambda
+           [(f l)
+            (if (and (procedure? f)
+                     (procedure-arity-includes? f 1)
+                     (list? l))
+                (let loop ([l l])
+                  (cond
+                   [(null? l) (void)]
+                   [else (begin (f (car l)) (loop (cdr l)))]))
+                (for-each f l))]
+           [(f l1 l2)
+            (if (and (procedure? f)
+                     (procedure-arity-includes? f 2)
+                     (list? l1)
+                     (list? l2)
+                     (= (length l1) (length l2)))
+                (let loop ([l1 l1][l2 l2])
+                  (cond
+                   [(null? l1) (void)]
+                   [else (begin (f (car l1) (car l2)) 
+                                (loop (cdr l1) (cdr l2)))]))
+                (for-each f l1 l2))]
+           [(f . args) (apply for-each f args)])])
+    for-each))
+
+(define andmap2
+  (let ([andmap
+         (case-lambda
+           [(f l)
+            (if (and (procedure? f)
+                     (procedure-arity-includes? f 1)
+                     (list? l))
+                (if (null? l)
+                    #t
+                    (let loop ([l l])
+                      (cond
+                       [(null? (cdr l)) (f (car l))]
+                       [else (and (f (car l)) (loop (cdr l)))])))
+                (andmap f l))]
+           [(f l1 l2)
+            (if (and (procedure? f)
+                     (procedure-arity-includes? f 2)
+                     (list? l1)
+                     (list? l2)
+                     (= (length l1) (length l2)))
+                (if (null? l1)
+                    #t
+                    (let loop ([l1 l1][l2 l2])
+                      (cond
+                       [(null? (cdr l1)) (f (car l1) (car l2))]
+                       [else (and (f (car l1) (car l2)) 
+                                  (loop (cdr l1) (cdr l2)))])))
+                (andmap f l1 l2))]
+           [(f . args) (apply andmap f args)])])
+    andmap))
+
+(define ormap2
+  (let ([ormap
+         (case-lambda
+           [(f l)
+            (if (and (procedure? f)
+                     (procedure-arity-includes? f 1)
+                     (list? l))
+                (if (null? l)
+                    #f
+                    (let loop ([l l])
+                      (cond
+                       [(null? (cdr l)) (f (car l))]
+                       [else (or (f (car l)) (loop (cdr l)))])))
+                (ormap f l))]
+           [(f l1 l2)
+            (if (and (procedure? f)
+                     (procedure-arity-includes? f 2)
+                     (list? l1)
+                     (list? l2)
+                     (= (length l1) (length l2)))
+                (if (null? l1)
+                    #f
+                    (let loop ([l1 l1][l2 l2])
+                      (cond
+                       [(null? (cdr l1)) (f (car l1) (car l2))]
+                       [else (or (f (car l1) (car l2)) 
+                                 (loop (cdr l1) (cdr l2)))])))
+                (ormap f l1 l2))]
+           [(f . args) (apply ormap f args)])])
+    ormap))