Added:

- recieve
- call-with-values
- map (accepting multiple list arguments)

scheme/base.sld

@@ -13,6 +13,7 @@
     ;  make-setter
     ;  slot-set!
     ;  type-slot-offset
+    receive
     abs
     max
     min
@@ -468,13 +469,13 @@
             (cons (cons 'multiple 'values) args)))) 
     ;; TODO: just need something good enough for bootstrapping (for now)
     ;; does not have to be perfect (this is not, does not handle call/cc or exceptions)
-;    (define call-with-values
+    (define call-with-values
-;      (lambda (producer consumer)
+      (lambda (producer consumer)
-;        (let ((x (producer)))
+        (let ((x (producer)))
-;          (if ;(magic? x)
+          (if ;(magic? x)
-;              (and (pair? x) (equal? (car x) (cons 'multiple 'values)))
+              (and (pair? x) (equal? (car x) (cons 'multiple 'values)))
-;              (apply consumer (cdr x))
+              (apply consumer (cdr x))
-;              (consumer x)))))
+              (consumer x)))))
 
     (define (dynamic-wind before thunk after)
       (before)
@@ -605,54 +606,63 @@
       (make k x)))
     (define (list-copy lst)
       (foldr (lambda (x y) (cons x y)) '() lst))
-    (define (map func lst)
+;    (define (map func lst)
-      (foldr (lambda (x y) (cons (func x) y)) '() lst))
+;      (foldr (lambda (x y) (cons (func x) y)) '() lst))
     (define (for-each f lst)
       (cond
        ((null? lst) #t)
        (else
          (f (car lst))
          (for-each f (cdr lst)))))
-;; TODO:
+    ;; Implementation of receive from SRFI 8
-;;; SRFI 8
+    (define-syntax receive
-;;; Reference implementation from: http://srfi.schemers.org/srfi-8/srfi-8.html
+      (er-macro-transformer
-;;;
+       (lambda (expr rename compare)
-;;; FUTURE: This may be moved into its own file
+        ;(if (or (not (pair? expr))
-;;;
+        ;        (< (length expr) 3))
-;;(define-syntax receive
+        ;    (syntax-error "Invalid syntax for receive" expr))
-;;    (syntax-rules ()
+        (let ((formals (cadr expr))
-;;        ((receive formals expression body ...)
+              (val-expr (caddr expr))
-;;         (call-with-values (lambda () expression)
+              (body (cdddr expr)))
-;;             (lambda formals body ...)))))
+          `(call-with-values 
-;;; END SRFI 8
+             (lambda () ,val-expr)
-;;
+             (lambda ,formals ,@body))))))
-;;; Added the following support functions from SRFI 1
+;
-;;(define (car+cdr pair) (values (car pair) (cdr pair)))
+; for example:
-;;(define (%cars+cdrs lists)
+; (call-with-values (lambda () (values 1 2)) (lambda (x y) (write `(,x ,y))))
-;;  (call-with-current-continuation
+; ==>(1 2)
-;;    (lambda (abort)
+;
-;;      (let recur ((lists lists))
+;(receive (x y) (values 1 2) (write `(,x ,y)))
-;;        (if (pair? lists)
+; ==>(1 2)
-;;	    (receive (list other-lists) (car+cdr lists)
+;
-;;	      (if (null? list) (abort '() '()) ; LIST is empty -- bail out
+
-;;		  (receive (a d) (car+cdr list)
+; Added the following support functions from SRFI 1
-;;		    (receive (cars cdrs) (recur other-lists)
+(define (car+cdr pair) (values (car pair) (cdr pair)))
-;;		      (values (cons a cars) (cons d cdrs))))))
+(define (%cars+cdrs lists)
-;;	    (values '() '()))))))
+  (call-with-current-continuation
-;;; END support functions
+    (lambda (abort)
-;;
+      (let recur ((lists lists))
-;;(define (map f lis1 . lists)
+        (if (pair? lists)
-;;;  (check-arg procedure? f map-in-order)
+          (receive (list other-lists) (car+cdr lists)
-;;  (if (pair? lists)
+            (if (null? list) (abort '() '()) ; LIST is empty -- bail out
-;;      (let recur ((lists (cons lis1 lists)))
+              (receive (a d) (car+cdr list)
-;;        (receive (cars cdrs) (%cars+cdrs lists)
+                (receive (cars cdrs) (recur other-lists)
-;;          (if (pair? cars)
+                  (values (cons a cars) (cons d cdrs))))))
-;;              (let ((x (apply f cars)))		; Do head first,
+          (values '() '()))))))
-;;                (cons x (recur cdrs)))		; then tail.
+; END support functions
-;;              '())))
+
-;;      ;; Fast path.
+(define (map f lis1 . lists)
-;;     (foldr (lambda (x y) (cons (f x) y)) '() lis1)))
+;  (check-arg procedure? f map-in-order)
-;;
+  (if (pair? lists)
+      (let recur ((lists (cons lis1 lists)))
+        (receive (cars cdrs) (%cars+cdrs lists)
+          (if (pair? cars)
+              (let ((x (apply f cars)))		; Do head first,
+                (cons x (recur cdrs)))		; then tail.
+              '())))
+      ;; Fast path.
+     (foldr (lambda (x y) (cons (f x) y)) '() lis1)))
+
 ;;(define (for-each f lis1 . lists)
 ;;  (if (not (null? lis1))
 ;;    (if (pair? lists)