From 9a7811f9f122eac13702fd1543f58aa54e03120e Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 31 Aug 2011 15:04:40 -0400 Subject: [PATCH] adding more of the primitives we need for cs19 --- compiler/bootstrapped-primitives.rkt | 139 ++++--- .../runtime-src/baselib-primitives.js | 128 +++++- lang/base.rkt | 8 +- lang/kernel.rkt | 16 +- lang/list.rkt | 367 ++++++++++++++++++ lang/private/map.rkt | 123 ++++++ 6 files changed, 727 insertions(+), 54 deletions(-) create mode 100644 lang/list.rkt create mode 100644 lang/private/map.rkt diff --git a/compiler/bootstrapped-primitives.rkt b/compiler/bootstrapped-primitives.rkt index 3812528..ad81ed7 100644 --- a/compiler/bootstrapped-primitives.rkt +++ b/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) - (if (null? l) - null - (cons (f (car l)) - (map f (cdr l)))))]) - map)) + (make-map-src 'map 'cons)) (make-bootstrapped-primitive-code 'for-each - '(letrec ([for-each (lambda (f l) - (if (null? l) - null - (begin (f (car l)) - (for-each f (cdr l)))))]) - for-each)) + (make-map-src 'for-each 'begin)) + (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) - (if (null? l) - #f - (if (eq? x (car l)) - l - (memq x (cdr l)))))]) - memq)) + '(letrec-values ([(memq) (lambda (x l) + (if (null? l) + #f + (if (eq? x (car l)) + l + (memq x (cdr l)))))]) + memq)) (make-bootstrapped-primitive-code 'assq - '(letrec ([assq (lambda (x l) - (if (null? l) - #f - (if (eq? x (caar l)) - (car l) - (assq x (cdr l)))))]) - assq)) + '(letrec-values ([(assq) (lambda (x l) + (if (null? l) + #f + (if (eq? x (caar l)) + (car l) + (assq x (cdr l)))))]) + assq)) (make-bootstrapped-primitive-code 'length - '(letrec ([length-iter (lambda (l i) - (if (null? l) - i - (length-iter (cdr l) (add1 i))))]) - (lambda (l) (length-iter l 0)))) - + '(letrec-values ([(length-iter) (lambda (l i) + (if (null? l) + i + (length-iter (cdr l) (add1 i))))]) + (lambda (l) (length-iter l 0)))) + (make-bootstrapped-primitive-code 'append - '(letrec ([append-many (lambda (lsts) - (if (null? lsts) - null - (if (null? (cdr lsts)) - (car lsts) - (append-2 (car lsts) - (append-many (cdr lsts))))))] - [append-2 (lambda (l1 l2) - (if (null? l1) - l2 - (cons (car l1) (append-2 (cdr l1) l2))))]) - (lambda args (append-many args)))) + '(letrec-values ([(append-many) (lambda (lsts) + (if (null? lsts) + null + (if (null? (cdr lsts)) + (car lsts) + (append-2 (car lsts) + (append-many (cdr lsts))))))] + [(append-2) (lambda (l1 l2) + (if (null? l1) + l2 + (cons (car l1) (append-2 (cdr l1) l2))))]) + (lambda args (append-many args)))) (make-bootstrapped-primitive-code diff --git a/js-assembler/runtime-src/baselib-primitives.js b/js-assembler/runtime-src/baselib-primitives.js index 92e9a7c..793b7a1 100644 --- a/js-assembler/runtime-src/baselib-primitives.js +++ b/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-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', diff --git a/lang/base.rkt b/lang/base.rkt index 6d100a2..5d0cbdb 100644 --- a/lang/base.rkt +++ b/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. diff --git a/lang/kernel.rkt b/lang/kernel.rkt index 7d00796..57826ab 100644 --- a/lang/kernel.rkt +++ b/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? -;; real? -;; rational? +complex? +real? +rational? integer? exact? exact-nonnegative-integer? @@ -330,8 +334,8 @@ exact-nonnegative-integer? reverse for-each map -;; andmap -;; ormap + andmap + ormap memq ;; memv member diff --git a/lang/list.rkt b/lang/list.rkt new file mode 100644 index 0000000..fb3faf2 --- /dev/null +++ b/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)) diff --git a/lang/private/map.rkt b/lang/private/map.rkt new file mode 100644 index 0000000..1f26367 --- /dev/null +++ b/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))