(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")

(filecreated "24-Mar-88 18:01:18" {eris}<cutting>oss>lyric>oss-lyric-patches.\;1
 2853   

      |changes| |to:|  (vars oss-lyric-patchescoms)

      |previous| |date:| "24-Mar-88 16:56:45" {eris}<cutting>oss>lyric>lyric-do-patch.\;1)


; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.

(prettycomprint oss-lyric-patchescoms)

(rpaqq oss-lyric-patchescoms
 ((* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.") (fns (* |;;| "from CMLSPECIALFORMS") \\do.translate) (functions (* |;;| "from CMLLIST") cl::%mapcar-multiple cl::%fill-slice-from-lists))
)



(* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.")


(defineq

(\\do.translate

(lambda (vars end-test body sequentialp env) (* \; "Edited 24-Mar-88 16:40 by drc:") (let ((vars-and-initial-values (mapcar vars (function (lambda (x) (cond ((nlistp x) (list x nil)) (t (list (car x) (cadr x)))))))) (subsequent-values (mapcar vars (function (lambda (x) (and (listp x) (cddr x) (list (car x) (caddr x))))))) (tag (gensym))) (and (setq subsequent-values (remove nil subsequent-values)) (setq subsequent-values (cons (cond (sequentialp (quote cl:setq)) (t (quote cl:psetq))) (apply (function append) subsequent-values)))) (cl:multiple-value-bind (body decls) (parse-body body env) (bquote ((\\\, (cond (sequentialp (quote prog*)) (t (quote prog)))) (\\\, vars-and-initial-values) (\\\,@ decls) (\\\, tag) (cond ((\\\, (car end-test)) (return (progn (\\\,@ (cdr end-test)))))) (\\\,@ body) (\\\, subsequent-values) (go (\\\, tag)))))))
)
)
(cl:defun cl::%mapcar-multiple (cl::fn cl::lists) (let ((cl::arg-slice (cl:make-list (length cl::lists)))) (cl:do ((cl::result nil) (cl::result-tail nil) (cl::current-slice cl::arg-slice) cl::element) ((null cl::current-slice) cl::result) (cl:setq cl::current-slice (cl::%fill-slice-from-lists cl::lists cl::arg-slice (car cl::arg-tail))) (cond (cl::current-slice (* \; "There is really more work to do.") (cl:setq cl::element (cl:apply cl::fn cl::current-slice)) (cl::%list-collect cl::result cl::result-tail (list cl::element)))))))
(defmacro cl::%fill-slice-from-lists (cl::lists cl::arg-slice cl::arg-tail-form) (bquote (cl:do ((cl::subslice (\\\, cl::arg-slice) (cdr cl::subslice)) (cl::sublist (\\\, cl::lists) (cdr cl::sublist)) (cl::some-list-empty nil) list) ((null cl::sublist) (cond (cl::some-list-empty (* \; "Ran out of entries in a list.") nil) (t (* \; "still work to do; return it.") (\\\, cl::arg-slice)))) (cl:setq list (car cl::sublist)) (cl:setq cl::some-list-empty (or cl::some-list-empty (null list))) (rplaca cl::subslice (prog1 (\\\, (cl:subst (quote list) (quote cl::arg-tail) cl::arg-tail-form)) (rplaca cl::sublist (cdr list)))))))
(putprops oss-lyric-patches copyright ("Xerox Corporation" 1988))
(declare\: dontcopy
  (filemap (nil (723 1605 (\\do.translate 733 . 1603)))))
stop