--- a/s-code.lisp
+++ b/s-code.lisp
@@ -9,20 +9,35 @@
 ;;;; above web site now to obtain the latest version.
 ;;;; NO PATCHES TO OTHER BUT THE LATEST VERSION WILL BE ACCEPTED.
 ;;;;
-;;;; $Id: s-code.lisp,v 1.67 2000/03/18 19:27:35 matomira Exp $
+;;;; $Id: s-code.lisp,v 1.68 2000/03/21 18:19:24 matomira Exp $
 ;;;;
 ;;;; This is Richard C. Waters' Series package.
 ;;;; This started from his November 26, 1991 version.
 ;;;;
 ;;;; $Log: s-code.lisp,v $
-;;;; Revision 1.67  2000/03/18 19:27:35  matomira
-;;;; Uses LOCALLY for `uninitialized' variables.
-;;;; MERGE-FRAGS no longer depends on frag component order.
-;;;; purity component of frag is now just a symbol.
-;;;; Abstracted use of prolog component of frags.
-;;;; Full letification works.
-;;;; Improved merging when letified.
-;;;; Last version withiout series library definitions requiring letification.
+;;;; Revision 1.68  2000/03/21 18:19:24  matomira
+;;;; - Reinstated plain generation support.
+;;;; - Fixed letified merge-frags bug.
+;;;; - Adapted handle-dflow and non-series-merge for letification.
+;;;; - Spawned list->frag1 from list->frag.
+;;;; - define-optimizable-series-function uses list->frag1 to
+;;;;   support letification.
+;;;; - Still can't handle all initial fragL bindings because off-line handling
+;;;;   seems to move prologs into TAGBODYs.
+;;;;
+;;;; Revision 1.79  2000/03/21 17:18:56  matomira
+;;;; Reinstated plain generation support.
+;;;;
+;;;; Revision 1.78  2000/03/21 15:26:12  matomira
+;;;; Fixed letified merge-frags bug.
+;;;; Adapted handle-dflow and non-series-merge for letification.
+;;;; Spawned list->frag1 from list->frag.
+;;;; define-optimizable-series-function uses list->frag1 to support letification.
+;;;; Still can't handle all initial bindings because off-line handling seems to
+;;;; move prologs into TAGBODYs.
+;;;;
+;;;; Revision 1.75  2000/03/18 20:12:52  matomira
+;;;; Improved code generated by compute-series-macform-2 when trigger is t.
 ;;;;
 ;;;; Revision 1.74  2000/03/18 19:14:45  matomira
 ;;;; Improved merging when letified.
@@ -503,17 +518,43 @@
     x))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  (deftype nonnegative-fixnum () `(mod ,most-positive-fixnum))
+  (deftype nonnegative-integer () `(integer 0))
+  (deftype positive-integer () `(integer 1))
+  (deftype integer+ (m n &optional (over 1)) `(integer ,m ,(+ n over)))
+  (deftype mod+ (n &optional (over 1)) `(mod ,(+ n over)))
   (deftype null-or (&rest types) `(or null ,@types))
   (deftype uninitialized (typ) `(null-or ,typ))
   (deftype defaulted (typ) `(null-or ,typ))
   
 #-:extensions
+(progn
 (defmacro when-bind ((symbol predicate) &body body)
   "Binds the symbol to predicate and executes body only if predicate
    is non-nil."
   `(cl:let ((,symbol ,predicate))
      (when ,symbol
        ,@body)))
+
+(defmacro bind-if ((symbol predicate) then &optional else)
+  "Binds the symbol to predicate and executes body only if predicate
+   is non-nil."
+  `(cl:let ((,symbol ,predicate))
+     (if ,symbol
+	 ,then
+       ,@(when else `(,else)))))
+
+(defmacro bind-if* ((symbol predicate) then &body else)
+  "Binds the symbol to predicate and executes body only if predicate
+   is non-nil."
+  `(cl:let ((,symbol ,predicate))
+     (if ,symbol
+	 ,then
+       ,@(when else
+	   `(,(if (cdr else)
+		  `(progn ,@else)
+		else))))))
+) ; end of progn
 
 ;; DEBUG
   (defmacro definline (&rest args) `(cl:defun ,@args))
@@ -868,6 +909,20 @@
     (if binds
 	(destarrify-1 base binds decls localdecls prologs forms wrapper t wrapped-prologs-p)
       (prognize (prologize prologs forms wrapped-prologs-p t) t)))
+
+(cl:defun lister-p (expr)
+  (when-bind (a (and (consp expr) (car expr)))
+    (case a
+      ((list cons copy-list make-list) expr)
+      (quote (when (consp (cadr expr)) expr))
+      (t nil))))
+
+(cl:defun matching-scan-p (expr pred)
+  (cl:let (a)
+    (and (eq-car expr 'scan)
+	 (or (and (setq a (cadr expr))  (not (caddr expr)) (cl:funcall pred a))
+	     (and (setq a (caddr expr)) (cl:funcall pred a))))))
+
 ) ; end of eval-when
 
 (cl:defun extract-declarations (forms)
@@ -1044,7 +1099,8 @@
                   *call*                ;bound to whole form when running optimizer
                   *being-setqed*        ;T if in the assignment part of a setq
                   *fn*                  ;FN being scanned over code
-                  *type*))              ;Communicates types to frag instantiations
+                  *type*                ;Communicates types to frag instantiations
+                  *limit*))             ;Communicates limits to frag instantiations
 
 ;; DEBUG
 ;;
@@ -1167,8 +1223,6 @@
 (cl:defun epilog-wrapper-p (w)
   (eq (wrapper-type w) :epilog))
 
-;;; Local variable handling
-
 #-:series-letify
 (progn
 
@@ -1218,6 +1272,10 @@
   (cl:defun delete-last-prolog (prologs)
     (nbutlast prologs))
 
+  (declaim (inline delete-prolog-if))
+  (cl:defun delete-prolog-if (p prologs)
+    (delete-if p prologs))
+
   (declaim (inline remove-prolog-if))
   (cl:defun remove-prolog-if (p prologs)
     (remove-if p prologs))
@@ -1268,6 +1326,10 @@
   (declaim (inline delete-aux))
   (cl:defun delete-aux (var auxs)
     (delete var auxs :key #'car))
+
+  (declaim (inline delete-aux-if))
+  (cl:defun delete-aux-if (p auxs)
+    (delete-if p auxs))
 
   (declaim (inline remove-aux-if))
   (cl:defun remove-aux-if (p auxs)
@@ -1282,7 +1344,6 @@
 
 #+:series-letify
 (progn
-
   ;;; Prologs
   
   (defmacro doprolog ((v prologs) &body body)
@@ -1366,8 +1427,8 @@
     (mapcar #'(lambda (b) (remove-if p b)) prologs))
 
 
-  ;;; Auxs
-  
+  ;;; Local variable handling (Auxs)
+
   (defmacro doaux ((v auxs) &body body)
     (cl:let ((b (gensym)))
       `(dolist (,b ,auxs)
@@ -1421,9 +1482,25 @@
   (cl:defun delete-aux (var auxs)
     (mapcar #'(lambda (b) (delete var b :key #'car)) auxs))
 
+  (declaim (inline delete-aux-if))
+  (cl:defun delete-aux-if (p auxs)
+    (mapcar #'(lambda (b) (delete-if p b)) auxs))
+
+  (declaim (inline delete-aux-if-not))
+  (cl:defun delete-aux-if-not (p auxs)
+    (mapcar #'(lambda (b) (delete-if-not p b)) auxs))
+
   (declaim (inline remove-aux-if))
   (cl:defun remove-aux-if (p auxs)
-    (mapcar #'(lambda (b) (remove-if p b)) auxs))	  
+    (mapcar #'(lambda (b) (remove-if p b)) auxs))
+
+  (declaim (inline remove-aux-if-not))
+  (cl:defun remove-aux-if (p auxs)
+    (mapcar #'(lambda (b) (remove-if-not p b)) auxs))
+
+  (declaim (inline segregate-aux))
+  (cl:defun segregate-aux (p auxs)
+    (2mapcar #'(lambda (b) (values (remove-if-not p b) (remove-if p b))) auxs))
 
   )
 
@@ -1448,7 +1525,8 @@
   (add-aux frag var typ val))
 
 (cl:defun add-nonliteral-aux (frag var typ val)
-  (add-aux frag var typ)	  
+  (add-aux frag var typ #+:series-letify val)
+  #-:series-letify 
   (push `(setq ,var ,val) (prolog frag)))
 
 ;;; There cannot be any redundancy in or between the args and aux.
@@ -1670,26 +1748,35 @@
 ;; This takes a series frag all of whose inputs and outputs are
 ;; non-series things and makes it into a non-series frag.
 (cl:defun maybe-de-series (frag &optional (prologize t))
-  (when (and (non-series-p frag) (or (body frag) (epilog frag)))
-    (when (not (active-terminator-p frag))
-      (wrs 29 nil "~%Non-terminating series expression:~%" (code frag)))
-    (cl:let* ((lab (new-var 'll))
-	      (loop `(tagbody ,lab ,@(body frag) (go ,lab)
-			      ,@(when (branches-to END (body frag)) `(,END))
-			      ))
-	      (wrps (wrappers frag)))	     
-      (when wrps 	      
-        (setq loop (apply-wrappers wrps loop #'loop-wrapper-p))
-        (setf (wrappers frag) (delete-if #'loop-wrapper-p wrps)))
-      (cl:let ((ending (append (list loop) (epilog frag))))
-        (if prologize
-	    (progn
-	      (append-prolog frag ending)
-	      (setf (body frag) nil))
-	  (setf (body frag) ending)))
-      (setf (epilog frag) nil) 
-      (clean-labs frag (cdr loop))))
+  (when (non-series-p frag)
+    (cl:let ((bod (body frag)))
+      (when (or bod (epilog frag))
+	(cl:let ((loop nil)
+		 (wrps (wrappers frag)))
+	  (when bod
+	    (when (not (active-terminator-p frag))
+	      (wrs 29 nil "~%Non-terminating series expression:~%" (code frag)))
+	    (cl:let ((lab (new-var 'll)))
+	      (setq loop `(tagbody ,lab ,@bod (go ,lab)
+				  ,@(when (branches-to END bod) `(,END))
+				  ))
+		     
+	     (when wrps 	      
+	       (setq loop (apply-wrappers wrps loop #'loop-wrapper-p)))))
+	  (when wrps
+	    (setf (wrappers frag) (delete-if #'loop-wrapper-p wrps)))
+	  (cl:let ((ending (if loop
+			       (append (list loop) (epilog frag))
+			     (epilog frag))))
+	    (if prologize
+		(progn
+		  (append-prolog frag ending)
+		  (setf (body frag) nil))
+	      (setf (body frag) ending)))
+	  (setf (epilog frag) nil) 
+	  (clean-labs frag (cdr loop))))))
   frag)
+
 
 ;; hacking marks
 
@@ -1744,41 +1831,44 @@
 	   (a2 (aux frag2))
 	   (p1 (prolog frag1))
 	   (p2 (prolog frag2)))
-    (if	(some #'(lambda (i)
+    (if (some #'(lambda (i)
 		  (some #'(lambda (o)
 			    (member i (nxts o)))
 			(rets frag1)))
 	      (args frag2))
 	(progn
-	  (setf (prolog frag2)
-		(nconc (if a1
-			   (or p1 (list nil))
-			 p1)
-		       (if a2
-			   (or p2 (list nil))
-			 p2)))
-	  (setf (aux frag2)
-		(nconc (if p1
-			   (or a1 (list nil))
-			 a1)
-		       (if p2
-			   (or a2 (list nil))
-			 a2))))
+	  (when (or p1 p2)
+	    (setf (prolog frag2)
+		  (nconc (if a1
+			     (or p1 (make-list (length a1)))
+			   p1)
+			 (if a2
+			     (or p2 (make-list (length a2)))
+			   p2))))
+
+	  (when (or a1 a2)	
+	    (setf (aux frag2)
+		  (nconc (if p1
+			     (or a1 (make-list (length p1)))
+			   a1)
+			 (if p2
+			     (or a2 (make-list (length p2)))
+			   a2)))))
       (progn
 	  (setf (prolog frag2)
 		(noverlap 1 (if a1
-				    (or p1 (list nil))
-				  p1)
-			(if a2
-			    (or p2 (list nil))
-			  p2)))
+				(or p1 (make-list (length a1)))
+			      p1)
+			  (if a2
+			      (or p2 (make-list (length a2)))
+			    p2)))
 	  (setf (aux frag2)
 		(noverlap 1 (if p1
-				    (or a1 (list nil))
-				  a1)
-			(if p2
-			    (or a2 (list nil))
-			  a2))))))
+				(or a1 (make-list (length p1)))
+			      a1)
+			  (if p2
+			      (or a2 (make-list (length p2)))
+			    a2))))))
 
   (mapc #'(lambda (s) (setf (fr s) frag2)) (rets frag1))
   (mapc #'(lambda (s) (setf (fr s) frag2)) (args frag1))
@@ -1820,8 +1910,6 @@
   (setq frag (copy-list frag))
   (setf (rets frag) (copy-tree (mapcar #'cddr (rets frag))))
   (setf (args frag) (copy-tree (mapcar #'cddr (args frag))))
-  #+:series-letify (setf (aux frag) (flatten-aux (aux frag)))
-  #+:series-letify (setf (prolog frag) (flatten-prolog (prolog frag)))
   (cl:let ((gensyms (find-gensyms frag)))
     (sublis (mapcar #'(lambda (v) (cons v (new-var (root v)))) gensyms)
       (cons gensyms (iterative-copy-tree (cddddr frag))))))
@@ -1841,14 +1929,18 @@
     (setf (fr s) frag)
     s))
 
-(cl:defun list->frag (list)
+(cl:defun list->frag1 (list)
   (cl:let* ((alist (mapcar #'(lambda (v) (cons v (gensym (root v)))) (pop list)))
               (frag (list* 'frag :|| 0 nil
                            (nsublis alist (iterative-copy-tree list)))))
     (setf (args frag) (mapcar #'(lambda (s) (list->sym s frag)) (args frag)))
     (setf (rets frag) (mapcar #'(lambda (s) (list->sym s frag)) (rets frag)))
-    #+:series-letify (setf (aux frag) (makeaux (aux frag)))
-    #+:series-letify (setf (prolog frag) (makeprolog (prolog frag)))
+    (values frag alist)))
+
+(cl:defun list->frag (list)
+  (cl:multiple-value-bind (frag alist) (list->frag1 list)
+    (setf (aux frag)    (makeaux (aux frag)))
+    (setf (prolog frag) (makeprolog (prolog frag)))
     (values frag alist)))
 
 ;; Special form for defining series functions directly in the internal
@@ -1876,6 +1968,10 @@
 	(rplacd l (cddr l))
 	(return list)))))
 
+(cl:defun pusharg (arg frag)
+  (setf (fr arg) frag)
+  (setf (args frag) (cons arg (args frag))))
+
 (cl:defun +arg (arg frag)
   (setf (fr arg) frag)
   (setf (args frag) (nconc (args frag) (list arg)))) ;needed by cotruncate
@@ -1886,6 +1982,9 @@
 (cl:defun +ret (ret frag)
   (setf (fr ret) frag)
   (setf (rets frag) (nconc (rets frag) (list ret)))) ;needed by coerce-to-type
+
+(cl:defun delete-ret (ret frag)
+  (delete1 ret (rets frag)))
 
 (cl:defun -ret (ret)
   (delete1 ret (rets (fr ret))))
@@ -2128,113 +2227,6 @@
 		    (or template *expr-template*) 
 		  *eval-all-template*))))))
 
-;; The following are the fns allowed in templates.
-
-(cl:defun Q   (code) code)
-(cl:defun E   (code) (m-&-r1 code))
-(cl:defun EX  (code)
-  (cl:let* ((*not-straight-line-code* *in-series-expr*)
-              (*in-series-expr* nil))
-    (m-&-r2 code *expr-template*)))
-(cl:defun EL  (code)
-  (cl:let* ((*not-straight-line-code* *in-series-expr*)
-              (*in-series-expr* nil))
-    (m-&-r1 code)))
-(cl:defun ELM  (code)
-  (if *series-implicit-map*
-      (m-&-r1 code)
-    (EL code)))
-(cl:defun S   (code) (cl:let ((*being-setqed* T)) (m-&-r1 code)))
-(cl:defun B   (code) (bind-list code nil))
-(cl:defun B*  (code) (bind-list code T))
-(cl:defun A   (code) (arg-list code))
-(cl:defun LAB (code) (if (symbolp code) code (EL code)))
-(cl:defun FUN (code) (if (not (consp code)) code (process-fn code)))
-
-;; This handles binding lists for LET.
-
-(cl:defun bind-list (args sequential &aux (pending nil))
-  (prog1 (mapcar #'(lambda (arg)
-                     (cl:let* ((val-p (and (consp arg) (cdr arg)))
-			       (new-val (when val-p
-					  (m-&-r1 (cadr arg))))
-			       (var (if (consp arg)
-					(car arg)
-				      arg)))
-                       (if sequential
-			   (push (list var) *renames*)
-			 (push (list var) pending))
-                       (if val-p
-			   (list (car arg) new-val)
-			 arg)))
-                 args)
-    (setq *renames* (append pending *renames*))))
-
-(cl:defun arg-list (args)
-  (mapcar #'(lambda (arg)
-              (cl:let* ((vars (vars-of arg))
-			(val-p (and (consp arg) (cdr arg)))
-			(new-val (when val-p
-				   (m-&-r1 (cadr arg)))))
-                (setq *renames* (append (mapcar #'list vars) *renames*))
-                (if val-p
-		    (list* (car arg) new-val (cddr arg))
-		  arg)))
-          args))
-
-(cl:defun compiler-let-template (form)
-  (cl:let ((symbols (mapcar #'(lambda (p) (if (consp p) (car p) p)) (cadr form)))
-	   (values (mapcar #'(lambda (p) (when (consp p) (eval (cadr p)))) (cadr form)))
-	   (body (cddr form)))
-    (progv symbols values
-      (E (if (null (cdr body))
-	     (car body)
-	   (list* 'let nil body))))))
-
-(setf (get 'compiler-let 'scan-template) #'compiler-let-template)
-
-;; FRAGMENTATION
-(cl:defun fragify (code type)
-  (cl:let* ((expansion (my-macroexpand code))
-	    (ret (when (symbolp expansion)
-		   (cdr (assoc expansion *renames*))))
-	    (types (decode-type-arg type T)))
-    (coerce-to-types types
-                     (cond ((frag-p expansion) expansion) ;must always make a new frag
-                           ((sym-p ret) (annotate code (pass-through-frag (list ret))))
-                           ((eq-car expansion 'the)
-                            (fragify (caddr expansion) (cadr expansion)))
-                           ((eq-car expansion 'values)
-                            ;; It used to map over the cdr of CODE here, which is
-                            ;; obviously not right -- for instance in the case where
-                            ;; (NTH-VALUE 0 x) --> (VALUES x) but it maps over (0 x)
-                            ;; and then thinks there is more than one value.  However
-                            ;; I'm not sure it's right to just blithly map over the
-                            ;; expansion either...
-                            (cl:let ((rets (mapcar #'(lambda (form)
-                                                         (car (rets (fragify form T))))
-                                                     (cdr expansion))))
-                              (when (and (cdr rets) (some #'series-var-p rets))
-                                (rrs 7 "~%VALUES returns multiple series:~%" code))
-                              (annotate code (pass-through-frag rets))))
-                           (T (annotate code (isolate-non-series
-                                              (if (listp types)
-						  (length types)
-						1)
-                                              expansion)))))))
-
-;; Have to be careful not to macroexpand things twice. If you did, you
-;; could get two copies of some frags on *graph*. Note that a type of
-;; '* means any number of arguments.
-(cl:defun retify (code &optional (type T))
-  (if (sym-p code)
-      code ;might have been retified/fragified before.
-    (cl:let* ((expansion (my-macroexpand code))
-	      (ret (when (symbolp expansion)
-		     (cdr (assoc expansion *renames*)))))
-      (if (sym-p ret)
-	  ret
-	(car (rets (fragify expansion type)))))))
 
 ;; This macro-expands everything in the code making sure that all free
 ;; variables (that are not free in the whole series expression) are
@@ -2290,145 +2282,6 @@
     (values code (mapcar #'cdr free-ins) (mapcar #'cdr free-outs)
             setqed (list free-ins free-outs))))
 
-;;; What the following is doing with the free variables may not be
-;;; quite right.  All in all, it is pretty scary if you refer to local
-;;; lexical vars in a fn in a series expression.  HERE Note that for
-;;; the moment, Series does not realize that you have used a variable
-;;; if this is the only way you use it.
-(cl:defun process-fn (code)
-  (cl:let ((*in-series-expr* nil) (*not-straight-line-code* nil)
-	   (*user-names* nil) (*renames* *renames*))
-    (cl:multiple-value-bind (fn free-ins free-outs)
-        (handle-non-series-stuff code)
-      (dolist (f free-ins)
-        (setq fn (nsubst (var (cdr f)) (car f) fn)))
-      (dolist (f free-outs)
-        (setq fn (nsubst (cdr f) (car f) fn)))
-      fn)))
-
-;;; templates for special forms.  Note that the following are not
-;;; handled
-;;;
-;;;   COMPILER-LET FLET LABELS MACROLET but must not macroexpand.
-;;;
-;;; FLET and DECLARE in particular are macros in lucid and messed
-;;; things up by expanding at the wrong time.
-
-(deft                block (Q Q)  (EL))
-(deft                catch (Q E)  (EL))
-(deft              declare (Q)    (EX))  ;needed by Xerox CL
-(deft            eval-when (Q Q)  (E))
-(deft             function (Q FUN)())
-(deft                   go (Q Q)  ())
-(deft                   if (Q E)  (ELM))
-(deft               cl:let (Q B)  (E))
-(deft              cl:let* (Q B*) (E))
-(deft  multiple-value-call (Q)    (E))
-(deft multiple-value-prog1 (Q)    (E))
-(deft                progn (Q)    (E))
-(deft                progv (Q)    (E))
-(deft                quote (Q Q)  ())
-(deft          return-from (Q Q)  (E))
-(deft                 setq (Q)    (S E))
-(deft              tagbody (Q)    (Lab))
-(deft                  the (Q Q)  (E))
-(deft                throw (Q)    (E))
-(deft       unwind-protect (Q)    (EL))
-
-(deft               lambda (Q A)  (E))
-
-(deft                 flet (Q)    (E))
-(deft         compiler-let (Q)    (E))
-(deft             macrolet (Q)    (E))
-(deft               labels (Q)    (E))
-(deft                 type (Q Q)  (E))
-
-(deft                  setf (Q)    (E))   ;fixes weird interaction with lispm setf 
-
-#+symbolics
-(cl:eval-when (eval load)
-  (cl:defun WSLB (list)
-    (prog1 (EX list) (push (list (car list)) *renames*)))
-  (deft                LET-IF (Q E B) (E))
-  (deft   scl:WITH-STACK-LIST (Q WSLB) (E))
-  (deft  scl:WITH-STACK-LIST* (Q WSLB) (E)))
-
-
-;;;                        ---- TYPE HANDLING ----
-
-;; TYPING
-(cl:defun some-series-type-p (type)
-  (cl:flet ((s-car-p (typ)
-              (eq-car typ 'series)))
-    (declare (dynamic-extent #'s-car-p))
-    (or (s-car-p type)
-        (and (or (eq-car type 'or)
-                 (eq-car type 'and))
-             (some #'s-car-p (cdr type))))))
-
-;; TYPING
-(cl:defun deserialize-type (type)
-  (cl:let ((cartyp (car type)))
-    (cl:flet ((upgrade-type (typ)
-                  (if (eq-car typ 'series)
-                      (cadr typ)
-                    typ)))
-      (declare (dynamic-extent #'upgrade-type))
-      (if (eq cartyp 'series)
-          (cadr type)
-        (if (or (eq cartyp 'or) 
-                (eq cartyp 'and))
-            (cons cartyp (mapcar #'upgrade-type (cdr type)))
-          type)))))
-
-;; TYPING
-(cl:defun truefy-type (type)
-  (cl:flet ((star2t (typ)
-                (if (eq typ '*)
-                    t
-                  typ)))
-      (declare (dynamic-extent #'star2t))
-      (typecase type
-        (list (cl:let ((cartyp (car type)))
-                (if (or (eq cartyp 'or) 
-                        (eq cartyp 'and))
-                    (cons cartyp (mapcar #'star2t (cdr type)))
-                  type)))
-        (t (star2t type)))))
-
-;; TYPING
-;; this is also used by PROTECT-FROM-SETQ in an odd way.
-(cl:defun coerce-to-type (type ret)
-  (when (eq type 'series) 
-    (setq type '(series T)))
-  (when (not (eq type T))
-    (when (and (not (some-series-type-p type))
-               (series-var-p ret))
-      (wrs 30 t "~%Series encountered where not expected."))
-    (when (some-series-type-p type)
-      (when (not (series-var-p ret))
-	(wrs 31 t "~%Non-series value encountered where series expected."))
-      (setq type (deserialize-type type))
-      (setq type (truefy-type type)))
-    (cl:let ((aux (find-aux (var ret) (aux (fr ret)))))
-      (when (and aux (not (subtypep (cadr aux) type)))
-	(setf (cadr aux) type)))))
-
-;; This is only used by fragify
-(cl:defun coerce-to-types (types frag)
-  (when (not (eq types '*))
-    (cl:let ((n (length types))
-	     (current-n (length (rets frag))))
-      (cond ((= n current-n))
-            ((< n current-n)
-             (mapc #'(lambda (r) (when (not (free-out r)) (kill-ret r)))
-                   (nthcdr n (rets frag))))
-            (T (dolist (v (n-gensyms (- n current-n) "XTRA-"))
-                 (+ret (make-sym :var v) frag)
-		 (add-literal-aux frag v T nil))))
-      (mapc #'coerce-to-type types (rets frag))))
-  frag)
-
 
 ;;;            ---- TURNING EXPRESSIONS INTO FRAGS (FRAGMENTATION) ----
 
@@ -2538,6 +2391,256 @@
           (+ret new frag)
           (rplacd (assoc v *renames*) new)))
       (+frag frag))))
+
+;; FRAGMENTATION
+(cl:defun fragify (code type)
+  (cl:let* ((expansion (my-macroexpand code))
+	    (ret (when (symbolp expansion)
+		   (cdr (assoc expansion *renames*))))
+	    (types (decode-type-arg type T)))
+    (coerce-to-types types
+                     (cond ((frag-p expansion) expansion) ;must always make a new frag
+                           ((sym-p ret) (annotate code (pass-through-frag (list ret))))
+                           ((eq-car expansion 'the)
+                            (fragify (caddr expansion) (cadr expansion)))
+                           ((eq-car expansion 'values)
+                            ;; It used to map over the cdr of CODE here, which is
+                            ;; obviously not right -- for instance in the case where
+                            ;; (NTH-VALUE 0 x) --> (VALUES x) but it maps over (0 x)
+                            ;; and then thinks there is more than one value.  However
+                            ;; I'm not sure it's right to just blithly map over the
+                            ;; expansion either...
+                            (cl:let ((rets (mapcar #'(lambda (form)
+                                                         (car (rets (fragify form T))))
+                                                     (cdr expansion))))
+                              (when (and (cdr rets) (some #'series-var-p rets))
+                                (rrs 7 "~%VALUES returns multiple series:~%" code))
+                              (annotate code (pass-through-frag rets))))
+                           (T (annotate code (isolate-non-series
+                                              (if (listp types)
+						  (length types)
+						1)
+                                              expansion)))))))
+
+;; Have to be careful not to macroexpand things twice. If you did, you
+;; could get two copies of some frags on *graph*. Note that a type of
+;; '* means any number of arguments.
+(cl:defun retify (code &optional (type T))
+  (if (sym-p code)
+      code ;might have been retified/fragified before.
+    (cl:let* ((expansion (my-macroexpand code))
+	      (ret (when (symbolp expansion)
+		     (cdr (assoc expansion *renames*)))))
+      (if (sym-p ret)
+	  ret
+	(car (rets (fragify expansion type)))))))
+
+;;; What the following is doing with the free variables may not be
+;;; quite right.  All in all, it is pretty scary if you refer to local
+;;; lexical vars in a fn in a series expression.  HERE Note that for
+;;; the moment, Series does not realize that you have used a variable
+;;; if this is the only way you use it.
+(cl:defun process-fn (code)
+  (cl:let ((*in-series-expr* nil) (*not-straight-line-code* nil)
+	   (*user-names* nil) (*renames* *renames*))
+    (cl:multiple-value-bind (fn free-ins free-outs)
+        (handle-non-series-stuff code)
+      (dolist (f free-ins)
+        (setq fn (nsubst (var (cdr f)) (car f) fn)))
+      (dolist (f free-outs)
+        (setq fn (nsubst (cdr f) (car f) fn)))
+      fn)))
+
+
+;;;                        ---- MACROEXPANSION TEMPLATES ----
+
+;; The following are the fns allowed in templates.
+
+(cl:defun Q   (code) code)
+(cl:defun E   (code) (m-&-r1 code))
+(cl:defun EX  (code)
+  (cl:let* ((*not-straight-line-code* *in-series-expr*)
+              (*in-series-expr* nil))
+    (m-&-r2 code *expr-template*)))
+(cl:defun EL  (code)
+  (cl:let* ((*not-straight-line-code* *in-series-expr*)
+              (*in-series-expr* nil))
+    (m-&-r1 code)))
+(cl:defun ELM  (code)
+  (if *series-implicit-map*
+      (m-&-r1 code)
+    (EL code)))
+(cl:defun S   (code) (cl:let ((*being-setqed* T)) (m-&-r1 code)))
+(cl:defun B   (code) (bind-list code nil))
+(cl:defun B*  (code) (bind-list code T))
+(cl:defun A   (code) (arg-list code))
+(cl:defun LAB (code) (if (symbolp code) code (EL code)))
+(cl:defun FUN (code) (if (not (consp code)) code (process-fn code)))
+
+;; This handles binding lists for LET.
+
+(cl:defun bind-list (args sequential &aux (pending nil))
+  (prog1 (mapcar #'(lambda (arg)
+                     (cl:let* ((val-p (and (consp arg) (cdr arg)))
+			       (new-val (when val-p
+					  (m-&-r1 (cadr arg))))
+			       (var (if (consp arg)
+					(car arg)
+				      arg)))
+                       (if sequential
+			   (push (list var) *renames*)
+			 (push (list var) pending))
+                       (if val-p
+			   (list (car arg) new-val)
+			 arg)))
+                 args)
+    (setq *renames* (append pending *renames*))))
+
+(cl:defun arg-list (args)
+  (mapcar #'(lambda (arg)
+              (cl:let* ((vars (vars-of arg))
+			(val-p (and (consp arg) (cdr arg)))
+			(new-val (when val-p
+				   (m-&-r1 (cadr arg)))))
+                (setq *renames* (append (mapcar #'list vars) *renames*))
+                (if val-p
+		    (list* (car arg) new-val (cddr arg))
+		  arg)))
+          args))
+
+(cl:defun compiler-let-template (form)
+  (cl:let ((symbols (mapcar #'(lambda (p) (if (consp p) (car p) p)) (cadr form)))
+	   (values (mapcar #'(lambda (p) (when (consp p) (eval (cadr p)))) (cadr form)))
+	   (body (cddr form)))
+    (progv symbols values
+      (E (if (null (cdr body))
+	     (car body)
+	   (list* 'let nil body))))))
+
+(setf (get 'compiler-let 'scan-template) #'compiler-let-template)
+
+;;; templates for special forms.  Note that the following are not
+;;; handled
+;;;
+;;;   COMPILER-LET FLET LABELS MACROLET but must not macroexpand.
+;;;
+;;; FLET and DECLARE in particular are macros in lucid and messed
+;;; things up by expanding at the wrong time.
+
+(deft                block (Q Q)  (EL))
+(deft                catch (Q E)  (EL))
+(deft              declare (Q)    (EX))  ;needed by Xerox CL
+(deft            eval-when (Q Q)  (E))
+(deft             function (Q FUN)())
+(deft                   go (Q Q)  ())
+(deft                   if (Q E)  (ELM))
+(deft               cl:let (Q B)  (E))
+(deft              cl:let* (Q B*) (E))
+(deft  multiple-value-call (Q)    (E))
+(deft multiple-value-prog1 (Q)    (E))
+(deft                progn (Q)    (E))
+(deft                progv (Q)    (E))
+(deft                quote (Q Q)  ())
+(deft          return-from (Q Q)  (E))
+(deft                 setq (Q)    (S E))
+(deft              tagbody (Q)    (Lab))
+(deft                  the (Q Q)  (E))
+(deft                throw (Q)    (E))
+(deft       unwind-protect (Q)    (EL))
+
+(deft               lambda (Q A)  (E))
+
+(deft                 flet (Q)    (E))
+(deft         compiler-let (Q)    (E))
+(deft             macrolet (Q)    (E))
+(deft               labels (Q)    (E))
+(deft                 type (Q Q)  (E))
+
+(deft                  setf (Q)    (E))   ;fixes weird interaction with lispm setf 
+
+#+symbolics
+(cl:eval-when (eval load)
+  (cl:defun WSLB (list)
+    (prog1 (EX list) (push (list (car list)) *renames*)))
+  (deft                LET-IF (Q E B) (E))
+  (deft   scl:WITH-STACK-LIST (Q WSLB) (E))
+  (deft  scl:WITH-STACK-LIST* (Q WSLB) (E)))
+
+;;;                        ---- TYPE HANDLING ----
+
+;; TYPING
+(cl:defun some-series-type-p (type)
+  (cl:flet ((s-car-p (typ)
+              (eq-car typ 'series)))
+    (declare (dynamic-extent #'s-car-p))
+    (or (s-car-p type)
+        (and (or (eq-car type 'or)
+                 (eq-car type 'and))
+             (some #'s-car-p (cdr type))))))
+
+;; TYPING
+(cl:defun deserialize-type (type)
+  (cl:let ((cartyp (car type)))
+    (cl:flet ((upgrade-type (typ)
+                  (if (eq-car typ 'series)
+                      (cadr typ)
+                    typ)))
+      (declare (dynamic-extent #'upgrade-type))
+      (if (eq cartyp 'series)
+          (cadr type)
+        (if (or (eq cartyp 'or) 
+                (eq cartyp 'and))
+            (cons cartyp (mapcar #'upgrade-type (cdr type)))
+          type)))))
+
+;; TYPING
+(cl:defun truefy-type (type)
+  (cl:flet ((star2t (typ)
+                (if (eq typ '*)
+                    t
+                  typ)))
+      (declare (dynamic-extent #'star2t))
+      (typecase type
+        (list (cl:let ((cartyp (car type)))
+                (if (or (eq cartyp 'or) 
+                        (eq cartyp 'and))
+                    (cons cartyp (mapcar #'star2t (cdr type)))
+                  type)))
+        (t (star2t type)))))
+
+;; TYPING
+;; this is also used by PROTECT-FROM-SETQ in an odd way.
+(cl:defun coerce-to-type (type ret)
+  (when (eq type 'series) 
+    (setq type '(series T)))
+  (when (not (eq type T))
+    (when (and (not (some-series-type-p type))
+               (series-var-p ret))
+      (wrs 30 t "~%Series encountered where not expected."))
+    (when (some-series-type-p type)
+      (when (not (series-var-p ret))
+	(wrs 31 t "~%Non-series value encountered where series expected."))
+      (setq type (deserialize-type type))
+      (setq type (truefy-type type)))
+    (cl:let ((aux (find-aux (var ret) (aux (fr ret)))))
+      (when (and aux (not (subtypep (cadr aux) type)))
+	(setf (cadr aux) type)))))
+
+;; This is only used by fragify
+(cl:defun coerce-to-types (types frag)
+  (when (not (eq types '*))
+    (cl:let ((n (length types))
+	     (current-n (length (rets frag))))
+      (cond ((= n current-n))
+            ((< n current-n)
+             (mapc #'(lambda (r) (when (not (free-out r)) (kill-ret r)))
+                   (nthcdr n (rets frag))))
+            (T (dolist (v (n-gensyms (- n current-n) "XTRA-"))
+                 (+ret (make-sym :var v) frag)
+		 (add-literal-aux frag v T nil))))
+      (mapc #'coerce-to-type types (rets frag))))
+  frag)
+
 
 ;;;; ---- PHYSICAL REPRESENTATIONS FOR SERIES AND GENERATORS ----
 
@@ -2959,6 +3062,84 @@
 ;;; guarantee that the restrictions will be satisfied after implicit
 ;;; mapping is applied.
 
+
+;;;                        UTILITIES
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  
+  (cl:defun do-alter-prop (value gen)
+    (if (alter-fn (gen-base gen))
+        (cons value (current-alter-info gen))
+       value))
+
+  ;; alter-info has priority
+  (cl:defun out-value (ret alter-prop flag-off-line?)
+    (cl:let* ((var (var ret))
+              (alter-info (cdr (assoc var (alterable (fr ret))))))
+      (values (cond (alter-info `(list ,var ,@ (cdr alter-info)))
+                    (alter-prop `(do-alter-prop ,var ,(cdr alter-prop)))
+                    ((and flag-off-line? (off-line-spot ret)) `(list ,var))
+                    (T var))
+              (cond (alter-info
+                     (cl:let ((alter (new-var 'alter)))
+                       `#'(lambda (,alter ,@(cdr alter-info))
+                            ,(subst alter '*alt* (car alter-info)))))
+                    (alter-prop `(alter-fn ,(car alter-prop)))))))
+
+  ;; This is used to allow a fragment to accept a physical series in
+  ;; lieu of one computed be another frag.
+  (cl:defun add-physical-interface (arg)
+    (cl:let ((frag (fr arg))
+             (var (var arg))
+             (off-line-spot (off-line-spot arg))
+             (off-line-exit (off-line-exit arg))
+             (series (new-var 'series))
+             (generator (new-var 'generator)))
+      (setf (var arg) series)
+      (setf (series-var-p arg) nil)
+      (setf (off-line-spot arg) nil)
+      (setf (off-line-exit arg) nil)
+      (add-aux frag var t)
+      (add-nonliteral-aux frag generator 'generator `(generator ,series))
+      (if (not off-line-spot)
+          (push `(setq ,var (next-in ,generator (go ,END))) (body frag))
+        (setf (body frag)
+              (nsubst-inline
+               `((setq ,var (next-in ,generator
+                                     (go ,(cond (off-line-exit) (T END))))))
+               off-line-spot (body frag))))
+      generator))
+
+
+  ;; This turns a series output into a non-series output returning a
+  ;; physical series. (Note this assumes that if alterability is being
+  ;; propogated, the corresponding input has already been changed
+  ;; using add-physical-interface.  Alter-prop is a cons of the new
+  ;; input var (a physical series) and the var holding the generator.)
+
+  (cl:defun add-physical-out-interface (ret alter-prop)
+    (cl:let* ((frag (fr ret))
+              (off-line-spot (off-line-spot ret))
+              (new-list (new-var 'list))
+              (new-out (new-var 'out)))
+      (cl:multiple-value-bind (out-value alterer) (out-value ret alter-prop nil)
+        (cl:let* ((new-body-code `((push ,out-value ,new-list)))
+                  (new-epilog-code
+                   `(setq ,new-out (make-phys :data-list (nreverse ,new-list)
+                                              :alter-fn ,alterer))))
+          (setf (var ret) new-out)
+          (setf (series-var-p ret) nil)
+          (setf (off-line-spot ret) nil)
+	  (add-literal-aux frag new-list 'list '())
+ 	  (add-aux frag new-out 'series)
+          (if (not off-line-spot)
+              (setf (body frag) (nconc (body frag) new-body-code))
+            (setf (body frag)
+                  (nsubst-inline new-body-code off-line-spot (body frag))))
+          (push new-epilog-code (epilog frag))
+          frag))))
+) ; end of eval-when
+
 ;;;;               (1) CHECK-FOR SERIES/NON-SERIES CONFLICTS.
 
 ;; This is only called from do-coercion
@@ -3016,6 +3197,21 @@
 ;;;;                     (2) DO SUBSTITUTIONS
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
+
+(cl:defun not-contained (items &rest things)
+  (cl:let ((found-once nil))
+    (cl:labels ((look-at (tree)
+                 (cond ((symbolp tree)
+			(when-bind (found (car (member tree items)))
+			  (push found found-once)))
+                       (T (do ((tt tree (cdr tt)))
+			      ((not (consp tt)) nil)
+			    (look-at (car tt)))))))
+      (declare (dynamic-extent #'look-at))
+      (dolist (thing things)
+        (look-at thing)))
+    (set-difference items found-once)))
+
 (cl:defun not-contained-twice (items &rest things)
   (cl:let ((found-once nil) (found-twice nil))
     (cl:labels ((look-at (tree)
@@ -3211,17 +3407,29 @@
 ;; outputs of the whole top level expression) or if there is a dflow
 ;; to a frag that is not currently being dealt with.  The functional
 ;; argument specifies which dflow are which.
-(cl:defun handle-dflow (source handle-this-dflow)
-  (dolist (ret (rets source))
-    (cl:let ((ret-killable (not (null (nxts ret)))))
-      (dolist (arg (nxts ret))
-        (cond ((not (cl:funcall handle-this-dflow ret arg))
-               (setq ret-killable nil))
-              (T (nsubst (var ret) (var arg) (fr arg))
-                 (-dflow ret arg)
-                 (-arg arg))))
-      (when ret-killable
-	(-ret ret)))))
+
+(cl:defun handle-dflow (source handle-this-dflow &optional (kill-dflow t))
+  (cl:let ((killable nil)
+	   (deadargs nil)
+	   (deadflows nil))	  
+    (dolist (ret (rets source))
+      (cl:let ((ret-killable (not (null (nxts ret)))))
+        (dolist (arg (nxts ret))
+	  (cond ((not (cl:funcall handle-this-dflow ret arg))
+		 (setq ret-killable nil))
+		(T (nsubst (var ret) (var arg) (fr arg))
+		   (if kill-dflow
+		       (-dflow ret arg)
+		     (push (cons ret arg) deadflows))
+		   (-arg arg)
+		   (push arg deadargs)
+		   )))
+	(when ret-killable 
+          (if kill-dflow
+	      (-ret ret))
+	  (push ret killable))))
+    (values killable deadargs deadflows)))
+
 
 ;; This is only called from non-series-merge
 (cl:defun implicit-epilog (frag)
@@ -3252,13 +3460,24 @@
 
 ;; This is only called from non-series-merge-list
 (cl:defun non-series-merge (ret-frag arg-frag)
-  (handle-dflow ret-frag
-    #'(lambda (r a) (declare (ignore r)) (eq (fr a) arg-frag)))
-  (when (not (non-series-p ret-frag))
-    (if (non-series-p arg-frag)
-        (implicit-epilog arg-frag)
-      (eval-on-first-cycle ret-frag arg-frag)))
-  (merge-frags ret-frag arg-frag))
+  (cl:multiple-value-bind (killable deadargs deadflows)
+	    (handle-dflow ret-frag
+			  #'(lambda (r a) (declare (ignore r)) (eq (fr a) arg-frag))
+			  nil) ; We'll kill rets after merging
+    (when (not (non-series-p ret-frag))
+      (if (non-series-p arg-frag)
+	  (implicit-epilog arg-frag)
+	(eval-on-first-cycle ret-frag arg-frag)))
+    (dolist (a deadargs)
+      (pusharg a (fr a)))
+    (cl:let ((result (merge-frags ret-frag arg-frag)))
+      (dolist (r killable)
+        (-ret r))
+      (dolist (f deadflows)
+	(-dflow (car f) (cdr f)))
+      (dolist (a deadargs)
+	(-arg a))
+      result)))
 
 (cl:defun non-series-merge-list (&rest frags)
   (declare (dynamic-extent frags))	  
@@ -4089,87 +4308,88 @@
 ;;; sequence (or NIL if not known) and the element type of the
 ;;; sequence (or T if not known).
 (cl:defun decode-seq-type (type)
-  (cond ((not (and (eq-car type 'quote)
-                   (setq type (cadr type))))
-         (values 'sequence nil T))
-        ((and (symbolp type)
-              (string= (string type) "BAG"))
-         (values 'bag nil T))
-        ((and (consp type)
-              (symbolp (car type))
-              (string= (string (car type)) "BAG"))
-         (values 'bag nil (cadr type)))
-        (t
-         ;; Hmm, should we use subtypep to handle these?  Might be easier.
-         (cond ((eq type 'list)
-                (values 'list nil T))
-               ((eq-car type 'list)
-                (values 'list nil (cadr type)))
-               ((eq type 'sequence)
-                (values 'sequence nil T))
-               ;; A STRING is canonicalized to (VECTOR CHARACTER)
-               ((eq type 'string)
-                (values 'vector nil 'character))
-               ((eq-car type 'string)
-                (values 'vector
-			(when (numberp (cadr type))
-			  (cadr type))
-			'character))
-               ;; But SIMPLE-STRING's are really (SIMPLE-ARRAY CHARACTER (*))
-               ((or (eq type 'simple-string)
-                    (eq type 'simple-base-string))
-                (values 'simple-array nil 'character))
-               ((or (eq-car type 'simple-string)
-                    (eq-car type 'simple-base-string))
-                (values 'simple-array
-                        (when (numberp (cadr type))
-			  (cadr type))
-                        'character))
-               ;; A BIT-VECTOR is (vector bit)
-               ((eq type 'bit-vector)
-                (values 'vector nil 'bit))
-               ((eq-car type 'bit-vector)
-                (values 'vector (if (numberp (cadr type)) (cadr type)) 'bit))
-               ;; But a SIMPLE-BIT-VECTOR is really a (SIMPLE-ARRAY BIT (*))
-               ((eq type 'simple-bit-vector)
-                (values 'simple-array nil 'bit))
-               ((eq-car type 'simple-bit-vector)
-                (values 'simple-array
-                        (when (numberp (cadr type))
-			  (cadr type))
-                        'bit))
-               ;; A VECTOR is just a VECTOR
-               ((eq type 'vector)
-                (values 'vector nil T))
-               ((eq-car type 'vector)
-                (values 'vector (if (numberp (caddr type)) (caddr type))
-                        (if (not (eq (cadr type) '*))
-			    (cadr type)
-			  T)))
-               ;; And a SIMPLE-VECTOR is just a SIMPLE-VECTOR
-               ((eq type 'simple-vector)
-                (values 'simple-vector nil T))
-               ((eq-car type 'simple-vector)
-                (values 'simple-vector (if (numberp (cadr type)) (cadr type)) T))
-               ;; A SIMPLE-ARRAY is a SIMPLE-ARRAY.  This assumes you
-               ;; specified a one-dimensional simple-array.  Results
-               ;; are undefined if it's not a one-dimensional array.
-               ((eq type 'simple-array)
-                (values 'simple-array nil T))
-               ((eq-car type 'simple-array)
-                (values 'simple-array
-                        (when (not (eq (caaddr type) '*))
-			  (caaddr type))
-                        (if (not (eq (cadr type) '*))
-                            (cadr type)
-			  T)))
-               ;; We don't need to handle anything else like arrays
-               ;; because series only handles 1-dimensional
-               ;; sequences.
-
-               ;; Everything else is a sequence
-               (T
-                (values 'sequence nil T))))))
+  (when (eq-car type 'quote)
+    (setq type (cadr type)))
+  (if type
+      (cond ((and (symbolp type)
+		  (string= (string type) "BAG"))
+	     (values 'bag nil T))
+	    ((and (consp type)
+		  (symbolp (car type))
+		  (string= (string (car type)) "BAG"))
+	     (values 'bag nil (cadr type)))
+	    (t
+	     ;; Hmm, should we use subtypep to handle these?  Might be easier.
+	     (cond ((eq type 'list)
+		    (values 'list nil T))
+		   ((eq-car type 'list)
+		    (values 'list nil (cadr type)))
+		   ((eq type 'sequence)
+		    (values 'sequence nil T))
+		   ;; A STRING is canonicalized to (VECTOR CHARACTER)
+		   ((eq type 'string)
+		    (values 'vector nil 'character))
+		   ((eq-car type 'string)
+		    (values 'vector
+			    (when (numberp (cadr type))
+			      (cadr type))
+			    'character))
+		   ;; But SIMPLE-STRING's are really (SIMPLE-ARRAY CHARACTER (*))
+		   ((or (eq type 'simple-string)
+			(eq type 'simple-base-string))
+		    (values 'simple-array nil 'character))
+		   ((or (eq-car type 'simple-string)
+			(eq-car type 'simple-base-string))
+		    (values 'simple-array
+			    (when (numberp (cadr type))
+			      (cadr type))
+			    'character))
+		   ;; A BIT-VECTOR is (vector bit)
+		   ((eq type 'bit-vector)
+		    (values 'vector nil 'bit))
+		   ((eq-car type 'bit-vector)
+		    (values 'vector (if (numberp (cadr type)) (cadr type)) 'bit))
+		   ;; But a SIMPLE-BIT-VECTOR is really a (SIMPLE-ARRAY BIT (*))
+		   ((eq type 'simple-bit-vector)
+		    (values 'simple-array nil 'bit))
+		   ((eq-car type 'simple-bit-vector)
+		    (values 'simple-array
+			    (when (numberp (cadr type))
+			      (cadr type))
+			    'bit))
+		   ;; A VECTOR is just a VECTOR
+		   ((eq type 'vector)
+		    (values 'vector nil T))
+		   ((eq-car type 'vector)
+		    (values 'vector (if (numberp (caddr type)) (caddr type))
+			    (if (not (eq (cadr type) '*))
+				(cadr type)
+			      T)))
+		   ;; And a SIMPLE-VECTOR is just a SIMPLE-VECTOR
+		   ((eq type 'simple-vector)
+		    (values 'simple-vector nil T))
+		   ((eq-car type 'simple-vector)
+		    (values 'simple-vector (if (numberp (cadr type)) (cadr type)) T))
+		   ;; A SIMPLE-ARRAY is a SIMPLE-ARRAY.  This assumes you
+		   ;; specified a one-dimensional simple-array.  Results
+		   ;; are undefined if it's not a one-dimensional array.
+		   ((eq type 'simple-array)
+		    (values 'simple-array nil T))
+		   ((eq-car type 'simple-array)
+		    (values 'simple-array
+			    (when (not (eq (caaddr type) '*))
+			      (caaddr type))
+			    (if (not (eq (cadr type) '*))
+				(cadr type)
+			      T)))
+		   ;; We don't need to handle anything else like arrays
+		   ;; because series only handles 1-dimensional
+		   ;; sequences.
+
+		   ;; Everything else is a sequence
+		   (T
+		    (values 'sequence nil T)))))
+    (values 'sequence nil T)))
 
 ;;; This tries to get a correct init in situations where NIL won't do.
 
@@ -4274,7 +4494,8 @@
 		  R (when (setq var (car (member (setq-p code) suspicious)))
 		      (push var dead)
 		      (rplaca parent (setq code (caddr code)))
-		      (when (or (symbolp code) (constantp code))
+		      (when (or (symbolp code) ; Symbol macros should have already expanded
+				(constantp code))
 			(cond ((consp (cdr parent))
 			       (rplaca parent (cadr parent))
 			       (rplacd parent (cddr parent))
@@ -4282,7 +4503,7 @@
 			       (go R))	;do would skip the next element
 			      (prev-parent (pop (cdr prev-parent)))))))
 		 (when (consp code)
-		   (clean-code2 nil code (car code))
+		   (clean-code2 nil code (car code)) 
 		   (do ((tt code (cdr tt)))
 		       ((not (and (consp tt) (consp (cdr tt)))) nil)
 		     (clean-code2 tt (cdr tt) (cadr tt))))))
@@ -4296,9 +4517,30 @@
       dead)))
 
 (cl:defun clean-code (aux prologs code)
+  #-:series-letify
   (cl:let* ((suspicious (not-contained-twice (mapaux #'car aux) prologs code))
 	    (dead-aux (clean-code1 suspicious prologs code)))
-    (values (remove-aux-if #'(lambda (v) (member (car v) dead-aux)) aux) prologs code)))
+    (values (remove-aux-if #'(lambda (v) (member (car v) dead-aux)) aux) prologs code))	  
+  #+:series-letify
+  (do ((unfinished t))
+      ((not unfinished) (values aux prologs code))
+    (cl:multiple-value-bind (bound unbound) (segregate-aux #'cddr aux)
+      (setq unbound (delete nil unbound))
+      (cl:let ((suspicious (delete-aux-if-not #'(lambda (v)
+						  (cl:let ((val (caddr v)))
+						    (or (symbolp val) ; Symbol macros should have already expanded
+							(constantp val))))
+					      bound)))
+        (setq suspicious (not-contained (mapaux #'car suspicious)
+					(mapaux #'caddr bound) prologs code))
+	(setq unfinished suspicious)
+	(setq aux (delete-aux-if #'(lambda (v) (member (car v) suspicious)) aux))
+	(setq suspicious (not-contained-twice (mapaux #'car unbound)
+					      (mapaux #'caddr aux) prologs code))
+	(setq suspicious (clean-code1 suspicious prologs code))
+	(when suspicious
+	  (setq unfinished suspicious)
+	  (setq aux (delete-aux-if #'(lambda (v) (member (car v) suspicious)) aux)))))))
 
 (cl:defun propagate-types (expr aux &optional (input-info nil))
   (do ((tt expr (cdr tt)))
@@ -4358,7 +4600,8 @@
 	  (if wrapped-p
 	      (prognize body)
 	    body)))
-      #+:series-letify (destarrify 'cl:let binds decls localdecls prologs code #'identity t)
+      #+:series-letify
+      (destarrify 'cl:let binds decls localdecls prologs code #'identity t)
     ))
     
 
@@ -4397,7 +4640,6 @@
     #-:series-letify
     (when wrps
       (setq code (wrap-code wrps code)))
-    #+:series-letify
     (cl:let ((last-form (car (last (if code code (last-prolog-block prologs))))))
       (if (and rets (null (cdr rets)))
 	  (cl:let ((r (car rets)))
@@ -4423,80 +4665,6 @@
 ); end of eval-when
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  
-  (cl:defun do-alter-prop (value gen)
-    (if (alter-fn (gen-base gen))
-        (cons value (current-alter-info gen))
-       value))
-
-  ;; alter-info has priority
-  (cl:defun out-value (ret alter-prop flag-off-line?)
-    (cl:let* ((var (var ret))
-              (alter-info (cdr (assoc var (alterable (fr ret))))))
-      (values (cond (alter-info `(list ,var ,@ (cdr alter-info)))
-                    (alter-prop `(do-alter-prop ,var ,(cdr alter-prop)))
-                    ((and flag-off-line? (off-line-spot ret)) `(list ,var))
-                    (T var))
-              (cond (alter-info
-                     (cl:let ((alter (new-var 'alter)))
-                       `#'(lambda (,alter ,@(cdr alter-info))
-                            ,(subst alter '*alt* (car alter-info)))))
-                    (alter-prop `(alter-fn ,(car alter-prop)))))))
-
-  ;; This is used to allow a fragment to accept a physical series in
-  ;; lieu of one computed be another frag.
-  (cl:defun add-physical-interface (arg)
-    (cl:let ((frag (fr arg))
-             (var (var arg))
-             (off-line-spot (off-line-spot arg))
-             (off-line-exit (off-line-exit arg))
-             (series (new-var 'series))
-             (generator (new-var 'generator)))
-      (setf (var arg) series)
-      (setf (series-var-p arg) nil)
-      (setf (off-line-spot arg) nil)
-      (setf (off-line-exit arg) nil)
-      (add-aux frag var t)
-      (add-aux frag generator 'generator)
-      (add-prolog frag `(setq ,generator (generator ,series)))
-      (if (not off-line-spot)
-          (push `(setq ,var (next-in ,generator (go ,END))) (body frag))
-        (setf (body frag)
-              (nsubst-inline
-               `((setq ,var (next-in ,generator
-                                     (go ,(cond (off-line-exit) (T END))))))
-               off-line-spot (body frag))))
-      generator))
-
-
-  ;; This turns a series output into a non-series output returning a
-  ;; physical series. (Note this assumes that if alterability is being
-  ;; propogated, the corresponding input has already been changed
-  ;; using add-physical-interface.  Alter-prop is a cons of the new
-  ;; input var (a physical series) and the var holding the generator.)
-
-  (cl:defun add-physical-out-interface (ret alter-prop)
-    (cl:let* ((frag (fr ret))
-              (off-line-spot (off-line-spot ret))
-              (new-list (new-var 'list))
-              (new-out (new-var 'out)))
-      (cl:multiple-value-bind (out-value alterer) (out-value ret alter-prop nil)
-        (cl:let* ((new-body-code `((push ,out-value ,new-list)))
-                  (new-epilog-code
-                   `(setq ,new-out (make-phys :data-list (nreverse ,new-list)
-                                              :alter-fn ,alterer))))
-          (setf (var ret) new-out)
-          (setf (series-var-p ret) nil)
-          (setf (off-line-spot ret) nil)
-	  (add-literal-aux frag new-list 'list '())
- 	  (add-aux frag new-out 'series)
-          (if (not off-line-spot)
-              (setf (body frag) (nconc (body frag) new-body-code))
-            (setf (body frag)
-                  (nsubst-inline new-body-code off-line-spot (body frag))))
-          (push new-epilog-code (epilog frag))
-          frag))))
-
   ;; This is used when optimization is not possible.
   ;;
   ;; It makes one main physical frag that computes the series returned
@@ -4744,7 +4912,7 @@
                ,(if (not dcls) doc (cons doc `(declare . ,dcls)))
                ,(frag->physical frag used-vars)
                :optimizer
-               (funcall-frag (list->frag ',frag-list) (list ,@ used-vars))
+               (funcall-frag (list->frag1 ',frag-list) (list ,@ used-vars))
                :trigger ,(not series-p)))))
       (cl:multiple-value-bind (forms decls doc)
           (decode-dcls expr-list '(no-complaints doc opts))
@@ -4813,7 +4981,9 @@
 	#+:symbolics (declare (zl:arglist ,@(copy-list arglist)))
 	,@(when doc (list doc))
 	,(if trigger
-	   `(if (and *optimize-series-expressions* ,trigger)
+	   `(if ,(if (eq trigger t)
+		     '*optimize-series-expressions*
+		   `(and *optimize-series-expressions* ,trigger))
 		,(if local-p
 		     (cl:let ((retprop (gensym))
 			      (optprop (gensym))
@@ -4946,8 +5116,12 @@
 (cl:defun *fragL-1 (stuff)
   (if *optimize-series-expressions*
       (opt-fragl (if (not (contains-p '*type* stuff))
-		     `(quote ,stuff)
-		   `(subst *type* '*type* ',stuff))
+		     (if (not (contains-p '*limit* stuff))
+		         `(quote ,stuff)
+		       `(subst *limit* '*limit* ',stuff))
+		   (if (not (contains-p '*limit* stuff))
+		       `(subst *type* '*type* ',stuff)
+		     `(subst *type* '*type* (subst *limit* '*limit* ',stuff))))
 		 (mapcar #'car (car stuff)))
     (unopt-fragl (list* (car stuff)
 		   (cadr stuff)
@@ -4956,7 +5130,7 @@
 				       (eq-car (cadr data)
 					       'series-element-type))
 				   (list* (car data) T (cddr data))
-				 data))
+				 (list* (car data) (subst most-positive-fixnum '*limit* (cadr data))  (cddr data))))
 			   (caddr stuff))
 		   (cdddr stuff)))))
 
@@ -4997,25 +5171,28 @@
     (multiple-value-setq (*type* limit el-type)
       (decode-seq-type (non-optq seq-type)))
     (cond ((eq *type* 'list)
-           (fragL ((items T)) ((lst))
-		  ((lastcons cons (list nil))
-		   (lst list))
-		  ()
-		  ((setq lst lastcons))
-		  ((setq lastcons (setf (cdr lastcons) (cons items nil))))
-                  ((setq lst (cdr lst)))
-		  ()
-		  nil
-		  ))
+	   (or (matching-scan-p items #'lister-p)
+	       (fragL ((items T)) ((lst))
+		      ((lastcons cons)
+		       (lst list))
+		      ()
+		      ((setq lastcons (list nil))
+		       (setq lst lastcons))
+		      ((setq lastcons (setf (cdr lastcons) (cons items nil))))
+		      ((setq lst (cdr lst)))
+		      ()
+		      nil
+		      )))
           ((eq *type* 'bag)
-           (fragL ((items T)) ((lst))
-		  ((lst list nil))
-		  ()
-                  ()
-                  ((setq lst (cons items lst)))
-		  ()
-		  ()
-		  nil))
+	   (or (matching-scan-p items #'lister-p)
+	       (fragL ((items T)) ((lst))
+		      ((lst list nil))
+		      ()
+		      ()
+		      ((setq lst (cons items lst)))
+		      ()
+		      ()
+		      nil)))
           (limit
            ;; It's good to have the type exactly right so CMUCL can
            ;; optimize better.
@@ -5025,7 +5202,7 @@
 	   (*fragL
 	       ((seq-type) (items T) (limit)) ((seq))
 	       ((seq *type*)
-		(index fixnum 0))
+		(index nonnegative-fixnum 0))
 	       ()              
 	       (#-:cmu
 		(setq seq (make-sequence seq-type limit))
@@ -5044,25 +5221,43 @@
 	       nil
 	       ))
           ((not (eq *type* 'sequence)) ;some kind of vector with no length
-           ;; It's good to have the type exactly right so CMUCL can
-           ;; optimize better.
-	   (setq *type* (make-nullable (if (eq *type* 'simple-array)
-					   (list *type* el-type '(*))
-					 (list *type* el-type))))
-           (*fragL ((seq-type) (items T)) ((seq)) 
-		   ((seq *type* nil)
-		    (lst list))
-		   ()
-		   ()
-		   ((setq lst (cons items lst)))
-		   ((cl:let ((num (length lst)))
-		      (setq seq (make-sequence seq-type num))
-		      (do ((i (1- num) (1- i))) ((minusp i))
-			(setf (aref seq i) (pop lst)))))
-		   ()
-		   nil
-		   ))
-          (T (fragL ((seq-type) (items T)) ((seq))
+            ;; It's good to have the type exactly right so CMUCL can
+	   ;; optimize better.
+	   (setq *type* (if (eq *type* 'simple-array)
+			    (list *type* el-type '(*))
+			  (list *type* el-type)))
+	   (bind-if* (l (matching-scan-p items #'lister-p))
+		     (funcall-literal-frag
+		       `((() ((seq)) 
+			  ((seq (null-or ,*type*)))
+			  ()
+			  ()
+			  ()
+			  ((cl:let* ((lst ,l)
+				     (num (length lst)))
+			     (setq seq (make-sequence ,seq-type num))
+			     (do ((i (1- num) (1- i))) ((minusp i))
+			       (setf (aref seq i) (pop lst)))))
+			  ()
+			  nil
+			  )
+			 ))
+             (setq *type* (make-nullable *type*))
+	     (*fragL ((seq-type) (items T)) ((seq)) 
+		     ((seq *type* nil)
+		      (lst list))
+		     ()
+		     ()
+		     ((setq lst (cons items lst)))
+		     ((cl:let ((num (length lst)))
+			(setq seq (make-sequence seq-type num))
+			(do ((i (1- num) (1- i))) ((minusp i))
+			  (setf (aref seq i) (pop lst)))))
+		     ()
+		     nil
+		     )))
+          (T
+	     (fragL ((seq-type) (items T)) ((seq))
                     ((seq T) (limit (null-or fixnum) nil) (lst list nil))
 		    ()
                     ((cl:multiple-value-bind (x y)
@@ -5159,26 +5354,20 @@
 			   var-collector-pairs))
 	    (stuff (mapcar #'gathererify frags))
 	    (fns (mapcar #'(lambda (p s) (cons (car p) (cl:funcall bindifier
-								   (cl:let ((f (or (nth 4 s) (nth 3 s))))
+								   (cl:let ((f (car (last s))))
 								     (if (and (listp f)
 									      (eq (car f) 'locally))
-									 (or (nth 3 f) (nth 2 f))
+									 (car (last f))
 								       f)))))
 			 var-collector-pairs stuff))
 	    (fullbody `(,binder ,fns ,@decls ,@body)))
     (dolist (s (reverse stuff))
-      (cl:let* ((tri  (nth 3 s))
-		(quat (nth 4 s))
-		(f (or quat tri)))
-        (setq fullbody `(cl:let ,(nth 1 s)
-			  ,(nth 2 s)
-			  ,@(when quat (list tri))
-			  ,(if (and (listp f)
-				    (eq (car f) 'locally))
-			       `(locally ,(cadr f)
-				  ,@(when (nth 3 f) (list (nth 2 f)))
-				  ,fullbody)
-			     fullbody)))))
+      (cl:let ((f (car (last s))))
+        (setq fullbody (nconc (butlast s)
+			      (list (if (and (listp f)
+					     (eq (car f) 'locally))
+					(nconc (butlast f) (list fullbody))
+				      fullbody))))))
     (cl:let ((wrps (mapcan #'(lambda (f)
 			       (prog1 (frag-wrappers f) (setf (wrappers f) nil)))
 			   frags)))
@@ -5268,7 +5457,7 @@
 	    (frag (fragify value type)))
     (dolist (out (rets frag))
       (cl:let* ((v (pop vars))
-                  (entry (assoc v *renames*)))
+		(entry (assoc v *renames*)))
         (cond (entry
                (rplacd entry out)
                (setf (free-out out) v)
@@ -5570,9 +5759,9 @@
     (cond ((= n 1)
            (fragL ((function) (args)) ((items T))
                   ((items T)
-		   (list-of-generators list))
+		   (list-of-generators list #+:series-letify (mapcar #'generator args)))
 		  ()
-		  ((setq list-of-generators (mapcar #'generator args)))
+		  (#-:series-letify (setq list-of-generators (mapcar #'generator args)))
                   ((setq items (apply function (list-of-next #'(lambda () (go end))
                                               list-of-generators))))
 		  ()
@@ -5607,11 +5796,11 @@
 (cl:defun scan-fn-opt (wrap-fn inclusive-p type init step
                                  &optional (test nil test-p))
   (cl:let* ((types (decode-type-arg (must-be-quoted type)))
-              (params nil)
-              (frag (make-frag :impure :fun))
-              (state-vars (n-gensyms (length types) "STATE-"))
-              (out-vars (n-gensyms (length types) "ITEMS-"))
-              (*state* nil))
+	    (params nil)
+	    (frag (make-frag :impure :fun))
+	    (state-vars (n-gensyms (length types) "STATE-"))
+	    (out-vars (n-gensyms (length types) "ITEMS-"))
+	    (*state* nil))
     (when wrap-fn
       (add-wrapper frag wrap-fn))
     (dolist (var out-vars)
@@ -5669,6 +5858,21 @@
           (handle-fn-call frag out-vars function (append out-vars in-vars) t))
     (funcall-frag frag params)))
 
+;; needed because collect is a macro
+(cl:defun basic-collect-list (items)
+  (compiler-let ((*optimize-series-expressions* nil))
+    (fragL ((items T)) ((lst))
+	   ((lastcons cons)
+	    (lst list))
+	   ()
+	   ((setq lastcons (list nil))
+	    (setq lst lastcons))
+	   ((setq lastcons (setf (cdr lastcons) (cons items nil))))	   
+           ((setq lst (cdr lst)))
+	   ()
+	   nil
+	   )))
+
 (defmacro encapsulated-macro (encapsulating-fn scanner-or-collector)
   (when (not (eq-car encapsulating-fn 'function))
     (ers 68 "~%First ENCAPSULATING arg " encapsulating-fn
@@ -5720,31 +5924,16 @@
 	(declare (indefinite-extent #'new-init #'new-step #'new-test))
         (cl:funcall fn T #'new-init #'new-step #'new-test)))))
 
-;; needed because collect is a macro
-(cl:defun basic-collect-list (items)
-  (compiler-let ((*optimize-series-expressions* nil))
-    (fragL ((items T)) ((lst))
-	   ((lastcons cons (list nil))
-	    (lst list))
-	   ()
-	   ((setq lst lastcons))
-	   ((setq lastcons (setf (cdr lastcons) (cons items nil))))	   
-           ((setq lst (cdr lst)))
-	   ()
-	   nil
-	   )))
-
 ;;needed because collect-fn is macro
 (cl:defun basic-collect-fn (inits function &rest args)
   (declare (dynamic-extent args))	  
   (declare (type list args))
   (compiler-let ((*optimize-series-expressions* nil))
     (fragL ((inits) (function) (args)) ((result))
-           ((result t)
-	    (list-of-generators list))
+           ((result t (cl:funcall inits))
+	    (list-of-generators list #+:series-letify (mapcar #'generator args)))
 	   ()
-	   ((setq result (cl:funcall inits)
-	          list-of-generators (mapcar #'generator args)))
+	   (#-:series-letify (setq list-of-generators (mapcar #'generator args)))
            ((cl:let ((vals (list-of-next #'(lambda () (go end))
                                            list-of-generators)))
               (setq result (apply function result vals))))
@@ -5781,11 +5970,11 @@
     (setq args (copy-list args))
     (cond ((= n 1)
            (fragL ((inits) (function) (args)) ((result T))
-                  ((result T)
-		   (list-of-generators list))
+                  ((result T #+:series-letify (cl:funcall inits))
+		   (list-of-generators list #+:series-letify (mapcar #'generator args)))
 		  ()
-                  ((setq result (cl:funcall inits)
-			 list-of-generators (mapcar #'generator args)))
+		  (#-:series-letify (setq result (cl:funcall inits))
+		   #-:series-letify (setq list-of-generators (mapcar #'generator args)))
                   ((cl:let ((vals (list-of-next #'(lambda () (go end))
                                                   list-of-generators)))
                      (setq result (apply function result vals))))
@@ -5831,10 +6020,10 @@
       (setq test #'never))
     (cond ((= n 1)
            (fragL ((init) (step) (test)) ((prior-state T))
-                  ((state T)
+                  ((state T #+:series-letify (cl:funcall init))
 		   (prior-state T))
 		  ()
-                  ((setq state (cl:funcall init)))
+                  (#-:series-letify (setq state (cl:funcall init)))
                   ((if (cl:funcall test state) (go END))
                    (prog1 (setq prior-state state)
                      (setq state (cl:funcall step state))))
@@ -5856,9 +6045,10 @@
   (cl:let ((n (length (decode-type-arg type))))
     (cond ((= n 1)
            (fragL ((init) (step) (test)) ((prior-state T))
-                  ((state T) (prior-state T) (done T nil))
+                  ((state T #+:series-letify (cl:funcall init))
+		   (prior-state T) (done T nil))
 		  ()
-                  ((setq state (cl:funcall init)))
+                  (#-:series-letify (setq state (cl:funcall init)))
                   ((if done (go END))
                    (setq done (cl:funcall test state))
                    (prog1 (setq prior-state state)
@@ -5974,13 +6164,14 @@
   (cl:let ((frag (fr in))
 	   (var (var in))
 	   (new (new-var 'in)))
-    (add-aux (fr in) var type) 
     (coerce-to-type type in) ;why am I doing this?
-    (cond ((not (series-var-p in))
-           (add-prolog frag `(setq ,var ,new)))
-          ((not (off-line-spot in))
-           (push `(setq ,var ,new) (body frag)))
-          (T (nsubst-inline `((setq ,var ,new)) (off-line-spot in) (body frag) T)))
+    (if (not (series-var-p in))
+	(add-nonliteral-aux (fr in) var type new)
+      (progn
+	(add-aux (fr in) var type)
+	(if (not (off-line-spot in))
+	    (push `(setq ,var ,new) (body frag))
+	  (nsubst-inline `((setq ,var ,new)) (off-line-spot in) (body frag) T))))
     (setf (var in) new)))
 
 ;; CHECKER
@@ -6272,10 +6463,10 @@
 (defS alter (destinations items)
   "Alters the values in DESTINATIONS to be ITEMS."
   (fragL ((destinations) (items T)) ((result))
-         ((gen generator)
+         ((gen generator #+:series-letify (generator destinations))
           (result null nil))
 	 ()
-         ((setq gen (generator destinations)))
+         (#-:series-letify (setq gen (generator destinations)))
          ((do-next-in gen #'(lambda () (go END)) items))
 	 ()
 	 ()
@@ -6347,9 +6538,10 @@
                         (opt-non-opt `(list ,expr ,@ expr-list)
                                      (cons expr (copy-list expr-list)))))
              (fragL ((full-expr-list)) ((items T))
-		    ((items T) (lst list))
+		    ((items T)
+		     (lst list #+:series-letify (copy-list full-expr-list)))
 		    ()
-                    ((setq lst (copy-list full-expr-list))
+                    (#-:series-letify (setq lst (copy-list full-expr-list))
 		     (setq lst (nconc lst lst)))
                     ((setq items (car lst)) (setq lst (cdr lst)))
 		    ()
@@ -6416,32 +6608,39 @@
       (ers 77 "~%Too many keywords specified in a call on SCAN-RANGE."))
     (cond (upto
            (*fragL ((from) (upto) (by)) ((numbers T))
-		   ((numbers *type*)) ()
-		   ((setq numbers (coerce (- from by) '*type*)))
+		   ((numbers *type* #+:series-letify (coerce (- from by) '*type*)))
+		   ()
+		   (#-:series-letify (setq numbers (coerce (- from by) '*type*)))
 		   ((setq numbers (+ numbers (coerce by '*type*)))
 		    (if (> numbers upto) (go END)))
 		   ()
 		   ()
 		   :args))
           (below
-           (*fragL ((from) (below) (by)) ((numbers T)) ((numbers *type*)) ()
-		   ((setq numbers (coerce (- from by) '*type*)))
+           (*fragL ((from) (below) (by)) ((numbers T))
+		   ((numbers *type* #+:series-letify (coerce (- from by) '*type*)))
+		   ()
+		   (#-:series-letify (setq numbers (coerce (- from by) '*type*)))
 		   ((setq numbers (+ numbers (coerce by '*type*)))
 		    (if (not (< numbers below)) (go END)))
 		   ()
 		   ()
 		   :args))
           (downto
-           (*fragL ((from) (downto) (by)) ((numbers T)) ((numbers *type*)) ()
-		   ((setq numbers (coerce (- from by) '*type*)))
+           (*fragL ((from) (downto) (by)) ((numbers T))
+		   ((numbers *type* #+:series-letify (coerce (- from by) '*type*)))
+		   ()
+		   (#-:series-letify (setq numbers (coerce (- from by) '*type*)))
 		   ((setq numbers (+ numbers (coerce by '*type*)))
 		    (if (< numbers downto) (go END)))
 		   ()
 		   ()
 		   :args))
           (above
-           (*fragL ((from) (above) (by)) ((numbers T)) ((numbers *type*)) ()
-		   ((setq numbers (coerce (- from by) '*type*)))
+           (*fragL ((from) (above) (by)) ((numbers T))
+		   ((numbers *type* #+:series-letify (coerce (- from by) '*type*)))
+		   ()
+		   (#-:series-letify (setq numbers (coerce (- from by) '*type*)))
 		   ((setq numbers (+ numbers (coerce by '*type*)))
 		    (if (not (> numbers above)) (go END)))
 		   ()
@@ -6449,17 +6648,21 @@
 		   :args))
           (length
            (*fragL ((from) (length) (by)) ((numbers T))
-		   ((numbers *type*) (counter fixnum)) ()
-		   ((setq numbers (coerce (- from by) '*type*))
-		    (setq counter length))
+		   ((numbers *type* #+:series-letify (coerce (- from by) '*type*))
+		    (counter fixnum #+:series-letify length))
+		   ()
+		   (#-:series-letify (setq numbers (coerce (- from by) '*type*))
+		    #-:series-letify (setq counter length))		     
 		   ((setq numbers (+ numbers (coerce by '*type*)))
 		    (if (not (plusp counter)) (go END))
 		    (decf counter))
 		   ()
 		   ()
 		   :args))
-          (T (*fragL ((from) (by)) ((numbers T)) ((numbers *type*)) ()
-		     ((setq numbers (coerce (- from by) '*type*)))
+          (T (*fragL ((from) (by)) ((numbers T))
+		     ((numbers *type* #+:series-letify (coerce (- from by) '*type*)))
+		     ()
+		     (#-:series-letify (setq numbers (coerce (- from by) '*type*)))
 		     ((setq numbers (+ numbers (coerce by '*type*))))
 		     ()
 		     ()
@@ -6480,32 +6683,40 @@
     (when (> (length (delete nil (list upto below downto above length))) 1)
       (ers 77 "~%Too many keywords specified in a call on SCAN-RANGE."))
     (cond (upto
-           (*fragL ((from) (upto) (by)) ((numbers T)) ((numbers *type*)) ()
-		   ((setq numbers (- from by)))
+           (*fragL ((from) (upto) (by)) ((numbers T))
+		   ((numbers *type* #+:series-letify (- from by)))
+		   ()
+		   (#-:series-letify (setq numbers (- from by)))
 		   ((setq numbers (+ numbers by))
 		    (if (> numbers upto) (go END)))
 		   ()
 		   ()
 		   :args))
           (below
-           (*fragL ((from) (below) (by)) ((numbers T)) ((numbers *type*)) ()
-		   ((setq numbers (- from by)))
+           (*fragL ((from) (below) (by)) ((numbers T))
+		   ((numbers *type* #+:series-letify (- from by)))
+		   ()
+		   (#-:series-letify (setq numbers (- from by)))
 		   ((setq numbers (+ numbers by))
 		    (if (not (< numbers below)) (go END)))
 		   ()
 		   ()
 		   :args))
           (downto
-           (*fragL ((from) (downto) (by)) ((numbers T)) ((numbers *type*)) ()
-		   ((setq numbers (- from by)))
+           (*fragL ((from) (downto) (by)) ((numbers T))
+		   ((numbers *type* #+:series-letify (- from by)))
+		   ()
+		   (#-:series-letify (setq numbers (- from by)))
 		   ((setq numbers (+ numbers by))
 		    (if (< numbers downto) (go END)))
 		   ()
 		   ()
 		   :args))
           (above
-           (*fragL ((from) (above) (by)) ((numbers T)) ((numbers *type*)) ()
-		   ((setq numbers (- from by)))
+           (*fragL ((from) (above) (by)) ((numbers T))
+		   ((numbers *type* #+:series-letify (- from by)))
+		   ()
+		   (#-:series-letify (setq numbers (- from by)))
 		   ((setq numbers (+ numbers by))
 		    (if (not (> numbers above)) (go END)))
 		   ()
@@ -6513,16 +6724,21 @@
 		   :args))
           (length
            (*fragL ((from) (length) (by)) ((numbers T))
-		   ((numbers *type*) (counter fixnum)) ()
-		   ((setq numbers (- from by)) (setq counter length))
+		   ((numbers *type* #+:series-letify (- from by))
+		    (counter fixnum #+:series-letify length))
+		   ()
+		   (#-:series-letify (setq numbers (- from by))
+		    #-:series-letify (setq counter length))	
 		   ((setq numbers (+ numbers by))
 		    (if (not (plusp counter)) (go END))
 		    (decf counter))
 		   ()
 		   ()
 		   :args))
-          (T (*fragL ((from) (by)) ((numbers T)) ((numbers *type*)) ()
-		     ((setq numbers (- from by)))
+          (T (*fragL ((from) (by)) ((numbers T))
+		     ((numbers *type* #+:series-letify (- from by)))
+		     ()
+		     (#-:series-letify (setq numbers (- from by)))
 		     ((setq numbers (+ numbers by)))
 		     ()
 		     ()
@@ -6531,7 +6747,7 @@
 ;; API
 (defS scan (seq-type &optional (seq nil seq-p))
     "Enumerates a series of the values in a sequence"
-  (cl:let (type limit *type*)
+  (cl:let (type limit *limit* *type*)
     (when (not seq-p) ;it is actually seq-type that is optional
       (setq seq seq-type)
       (setq seq-type (optq 'list)))
@@ -6539,7 +6755,8 @@
     (cond ((member type '(list bag))
            (*fragL ((seq)) ((elements T))
 		   ((elements *type*)
-		    (listptr list) (parent list))
+		    (listptr list)
+		    (parent list))
 		   ((elements (the *type* (setf (car parent) *alt*)) parent))
 		   ((setq listptr seq))
 		   ((if (endp listptr) (go END))
@@ -6550,42 +6767,62 @@
 		   ()
 		   :mutable))
           (limit
-           (*fragL ((seq) (limit)) ((elements T))
-		   ((elements *type*)
-		    (temp T) 
-		    (index fixnum -1))
-		   ((elements (the *type* (setf (aref temp index) *alt*)) temp index))
-		   ((setq temp seq))
-		   ((incf index)
-		    (if (not (< index limit)) (go END))
-		    (setq elements (the *type* (aref seq index))))
-		   ()
-		   ()
-		   :mutable))
+	   (setq *limit* limit)
+	   (if *optimize-series-expressions*
+	       (*fragL ((seq)) ((elements T))
+		       ((elements *type*)
+			(temp T) 
+			(index (integer+ -1 *limit*) -1))
+		       ((elements (the *type* (setf (aref temp (the nonnegative-fixnum #+:ignore (mod+ *limit*)
+								    index)) *alt*)) temp index))
+		       ((setq temp seq))
+		       ((incf index)
+			(if (>= index *limit*) (go END))
+			(setq elements (the *type* (aref seq (the nonnegative-fixnum #+:ignore (mod+ *limit*)
+								  index)))))
+		       ()
+		       ()
+		       :mutable)
+	     (*fragL ((seq) (limit)) ((elements T))
+		     ((elements *type*)
+		      (temp T) 
+		      (index (integer+ -1 *limit*) -1))
+		     ((elements (the *type* (setf (aref temp (the nonnegative-fixnum #+:ignore (mod+ *limit*)
+								  index)) *alt*)) temp index))
+		     ((setq temp seq))
+		     ((incf index)
+		      (if (>= index limit) (go END))
+		      (setq elements (the *type* (aref seq (the nonnegative-fixnum #+:ignore (mod+ *limit*)
+								index)))))
+		     ()
+		     ()
+		     :mutable)))
           ((not (eq type 'sequence))	;some kind of vector
            (*fragL ((seq)) ((elements T))
 		   ((elements *type*)
-		    (limit fixnum)
-		    (temp T) 
+		    (temp T)
+		    (limit nonnegative-fixnum)
 		    (index fixnum -1))
-		   ((elements (the *type* (setf (aref temp index) *alt*)) temp index))
-		   ((setq limit (length seq)) (setq temp seq))
+		   ((elements (the *type* (setf (aref temp (the nonnegative-fixnum index)) *alt*)) temp index))
+		   ((setq temp seq)
+		    (setq limit (length seq)))
 		   ((incf index)
-		    (if (not (< index limit)) (go END))
-		    (setq elements (the *type* (aref seq index))))
+		    (if (>= index limit) (go END))
+		    (setq elements (the *type* (aref seq (the nonnegative-fixnum index)))))
 		   ()
 		   ()
 		   :mutable))
           (T (*fragL ((seq-type) (seq)) ((elements T)) ;dummy type input avoids warn
 		     ((elements *type*)
-		      (limit fixnum)
-		      (temp T) 
+		      (temp T)
+		      (limit nonnegative-fixnum)
 		      (index fixnum -1))
-		     ((elements (the *type* (setf (elt temp index) *alt*)) temp index))
-		     ((setq limit (length seq)) (setq temp seq))
+		     ((elements (the *type* (setf (elt temp (the nonnegative-fixnum index)) *alt*)) temp index))
+		     ((setq temp seq)
+		      (setq limit (length seq)))
 		     ((incf index)
-		      (if (not (< index limit)) (go END))
-		      (setq elements (the *type* (elt seq index))))
+		      (if (>= index limit) (go END))
+		      (setq elements (the *type* (elt seq (the nonnegative-fixnum index)))))
 		     ()
 		     ()
 		     :mutable)))))
@@ -6607,8 +6844,8 @@
                 (mapcar #'alter-fn items-list))
  :optimizer
   (cl:let* ((args (copy-list items-list))
-              (vars (n-gensyms (length args) "COTRUNC-"))
-              (ports (mapcar #'(lambda (v) (list v t)) vars)))
+	    (vars (n-gensyms (length args) "COTRUNC-"))
+	    (ports (mapcar #'(lambda (v) (list v t)) vars)))
     (funcall-frag
       (literal-frag `(,ports ,(copy-list ports) nil nil nil nil nil nil nil))
       args)))
@@ -6622,9 +6859,10 @@
     (cond ((member type '(list bag))
            (*fragL ((seq)) ((elements T))
 		   ((elements *type*)
-		    (listptr list) (parent list))
+		    (listptr list seq)
+		    (parent list))
 		   ((elements (the *type* (setf (car parent) *alt*)) parent))
-		   ((setq listptr seq))
+		   ()
 		   ((setq parent listptr)
 		    (setq elements (the *type* (car listptr)))
 		    (setq listptr (cdr listptr)))
@@ -6634,21 +6872,23 @@
           ((not (eq type 'sequence))	;some kind of vector
            (*fragL ((seq)) ((elements T))
 		   ((elements *type*)
-		    (temp T) (index fixnum))
+		    (temp T seq)
+		    (index nonnegative-fixnum 0))
 		   ((elements (the *type* (setf (aref temp index) *alt*)) temp index))
-		   ((setq index -1) (setq temp seq))
-		   ((incf index)
-		    (setq elements (the *type* (aref seq index))))
+		   ()
+		   ((setq elements (the *type* (aref seq index)))
+		    (incf index))
 		   ()
 		   ()
 		   :mutable))
           (T (*fragL ((seq-type) (seq)) ((elements T)) ;dummy type input avoids warn
 		     ((elements *type*)
-		      (temp T) (index fixnum))
+		      (temp T seq)
+		      (index nonnegative-fixnum 0))
 		     ((elements (the *type* (setf (elt temp index) *alt*)) temp index))
-		     ((setq index -1) (setq temp seq))
-		     ((incf index)
-		      (setq elements (the *type* (elt seq index))))
+		     ()
+		     ((setq elements (the *type* (elt seq index)))
+		      (incf index))
 		     ()
 		     ()
 		     :mutable)))))
@@ -6680,8 +6920,11 @@
 ;; API
 (defS scan-sublists (lst)
     "Creates a series of the sublists in a list."
-  (fragL ((lst)) ((sublists T)) ((sublists list) (lstptr list)) ()
-         ((setq lstptr lst))
+  (fragL ((lst)) ((sublists T))
+	 ((sublists list)
+	  (lstptr list #+:series-letify lst))
+	 ()
+         (#-:series-letify (setq lstptr lst))
          ((if (endp lstptr) (go END))
           (setq sublists lstptr)
           (setq lstptr (cdr lstptr)))
@@ -6693,7 +6936,8 @@
 (defS scan-alist (alist &optional (test #'eq))
     "Creates two series containing the keys and values in an alist."
   (fragL ((alist) (test)) ((keys T) (values T))
-         ((alistptr list) (keys t) (values t) (parent list))
+         ((alistptr list)
+	  (keys t) (values t) (parent list))
          ((keys (setf (car parent) *alt*) parent)
           (values (setf (cdr parent) *alt*) parent))
          ((setq alistptr alist))
@@ -6713,7 +6957,9 @@
 (defS scan-plist (plist)
     "Creates two series containing the indicators and values in a plist."
   (fragL ((plist)) ((indicators T) (values T))
-         ((indicators t) (values t) (plistptr list) (parent list))
+         ((indicators t) (values t)
+	  (plistptr list)
+	  (parent list))
          ((indicators (setf (car parent) *alt*) parent)
           (values (setf (cadr parent) *alt*) parent))
          ((setq plistptr plist))
@@ -6734,7 +6980,10 @@
 (defS scan-lists-of-lists (tree &optional (test #'atom test-p))
     "Creates a series of the nodes in a tree."
   (if test-p
-      (fragL ((tree) (test)) ((nodes T)) ((nodes T) (state list)) ()
+      (fragL ((tree) (test)) ((nodes T))
+	     ((nodes T)
+	      (state list))
+	     ()
              ((setq state (list tree)))
              ((if (null state) (go END))
               (setq nodes (car state))
@@ -6747,7 +6996,10 @@
 	     ()
 	     ()
 	     :mutable)
-    (fragL ((tree)) ((nodes T)) ((nodes T) (state list)) ()
+    (fragL ((tree)) ((nodes T))
+	   ((nodes T)
+	    (state list))
+	   ()
 	   ((setq state (list tree)))
 	   ((if (null state) (go END))
 	    (setq nodes (car state))
@@ -6766,7 +7018,8 @@
     "Creates a series of the leaves of a tree."
   (if test-p
       (fragL ((tree) (test)) ((leaves T))
-             ((leaves T) (parent list) (state list))
+             ((leaves T) (parent list)
+	      (state list))
              ((leaves (setf (car parent) *alt*) parent))
              ((setq state (list (list tree))))
              (L (if (null state) (go END))
@@ -6783,7 +7036,8 @@
 	     ()
 	     :mutable)
     (fragL ((tree)) ((leaves T))
-	   ((leaves T) (parent list) (state list))
+	   ((leaves T) (parent list)
+	    (state list))
 	   ((leaves (setf (car parent) *alt*) parent))
 	   ((setq state (list (list tree))))
 	   (L (if (null state) (go END))
@@ -6805,7 +7059,8 @@
 (defS scan-symbols (&optional (package nil))
     "Creates a series of the symbols in PACKAGE."
   (fragL ((package)) ((symbols T))
-	 ((symbols symbol) (lst list nil)) ()
+	 ((symbols symbol) (lst list nil))
+	 ()
          ((do-symbols (s (or package *package*)) (push s lst)))
          ((if (null lst) (go END))
           (setq symbols (car lst))
@@ -6838,10 +7093,11 @@
 read from the file."
   (fragL ((name) (reader)) ((items T))
 	 ((items T)
-	  (lastcons cons (list nil))
-	  (lst list nil))
+	  (lastcons cons)
+	  (lst list))
 	 ()
-         ((setq lst lastcons)
+         ((setq lastcons (list nil))
+	  (setq lst lastcons)
 	  (with-open-file (f name :direction :input)
             (cl:let ((done (list nil)))
               (loop              
@@ -6881,10 +7137,11 @@
 SCAN-FILE, except we read from an existing stream."
   (fragL ((name) (reader)) ((items T))
 	 ((items T)
-	  (lastcons cons (list nil))
+	  (lastcons cons)
 	  (lst list))
 	 ()
-         ((setq lst lastcons)
+         ((setq lastcons (list nil))
+	  (setq lst lastcons)
 	  (cl:let ((done (list nil)))
             (loop                
                 (cl:let ((item (cl:funcall reader name nil done)))
@@ -6960,18 +7217,20 @@
   (cond ((eql amount 1)
          (fragL ((items T) (default)) ((shifted-items T))
                 ((shifted-items (series-element-type items))
-                 (state (series-element-type items)))
+                 (state (series-element-type items) #+:series-letify default))
 		()
-                ((setq state default))
+                (#-:series-letify (setq state default))
                 ((setq shifted-items state) (setq state items))
 		()
 		()
 		nil ; series dataflow constraint takes care
 		))
         (T (fragL ((items T) (default) (amount)) ((shifted-items T))
-                  ((shifted-items (series-element-type items)) (ring list)) ()
-                  ((setq ring (make-list (1+ amount) :initial-element default))
-                   (nconc ring ring))
+                  ((shifted-items (series-element-type items))
+		   (ring list #+:series-letify (make-list (1+ amount) :initial-element default)))
+		  ()
+                  (#-:series-letify (setq ring (make-list (1+ amount) :initial-element default))
+		   (nconc ring ring))
                   ((rplaca ring items)
 		   (setq ring (cdr ring))
                    (setq shifted-items (car ring)))
@@ -6991,8 +7250,11 @@
 	   (setq post-p T))
          (cond (after
                 (fragL ((items T) (after) (pre) (pre-p) (post) (post-p))
-                       ((masked-items T)) ((masked-items T) (state fixnum)) ()
-                       ((setq state after))
+                       ((masked-items T))
+		       ((masked-items T)
+			(state fixnum #+:series-letify after))
+		       ()
+                       (#-:series-letify (setq state after))
                        ((cond ((plusp state) (if items (decf state))
                                (setq masked-items (if pre-p pre items)))
                               (T (setq masked-items (if post-p post items)))))()
@@ -7001,8 +7263,10 @@
 			      ))
                (T (fragL ((items T) (before) (pre) (pre-p) (post) (post-p))
                          ((masked-items T))
-                         ((masked-items T) (state fixnum)) ()
-                         ((setq state before))
+                         ((masked-items T)
+			  (state fixnum #+:series-letify before))
+			 ()
+                         (#-:series-letify (setq state before))
                          ((cond ((and (plusp state)
                                       (or (null items)
                                           (not (zerop (setq state (1- state))))))
@@ -7017,7 +7281,8 @@
 (defS until1 (bools items)
     "Returns ITEMS up to, but not including, the first non-null element of BOOLS."
   (fragL ((bools T) (items T)) ((items T)) () ()
-         () ((if bools (go END)))
+         ()
+	 ((if bools (go END)))
 	 ()
 	 ()
 	 nil
@@ -7117,7 +7382,9 @@
 (defS expand (bools items &optional (default nil))
     "Spreads the elements of ITEMS out into the indicated positions."
   (fragL ((bools T) (items T -X-) (default)) ((expanded T))
-         ((expanded (series-element-type items))) () ()
+         ((expanded (series-element-type items)))
+	 ()
+	 ()
          ((when (not bools) (setq expanded default) (go F))
           -X- (setq expanded items)
           F)
@@ -7149,8 +7416,10 @@
                     (if (not (< index below)) (go END))
                     (if (< index start) (go LP)))
 		() () nil))
-        (T (fragL ((items T -X-) (start)) ((items T)) ((index fixnum)) ()
-                  ((setq index (- -1 start)))
+        (T (fragL ((items T -X-) (start)) ((items T))
+		  ((index fixnum #+:series-letify (- -1 start)))
+		  ()
+                  (#-:series-letify (setq index (- -1 start)))
                   (LP -X-
                       (incf index)
                       (if (minusp index) (go LP)))
@@ -7162,8 +7431,9 @@
   (fragL ((items1 T -X1- F1) (items2 T -X2- F2) (comparator)) ((items T))
          ((items (or (series-element-type items1)
                      (series-element-type items2)))
-          (need1 fixnum) (need2 fixnum)) ()
-         ((setq need1 1 need2 1))
+          (need1 fixnum 1) (need2 fixnum 1))
+	 ()
+         ()
          ((if (not (plusp need1)) (go F1))
           (setq need1 -1)
           -X1-
@@ -7279,8 +7549,10 @@
 ;; API
 (defS every-nth (m n items)
     "Returns a series of every Nth element of ITEMS, after skipping M elements."
-  (fragL ((m) (n) (items T -X-)) ((items T)) ((count fixnum)) ()
-         ((setq count (1- m)))
+  (fragL ((m) (n) (items T -X-)) ((items T))
+	 ((count fixnum #+:series-letify (1- m)))
+	 ()
+         (#-:series-letify (setq count (1- m)))
          (L -X- (cond ((plusp count) (decf count) (go L))
                       (T (setq count (1- n))))) () () :args))
 
@@ -7291,9 +7563,9 @@
     (when (not items-p)        ;it is actually n that is optional
       (setq items n)
       (setq n 1))
-    (cond ((not (and (integerp m) (plusp m)))
+    (cond ((not (typep m 'positive-integer))
            (ers 63 "~%M argument " m " to CHUNK fails to be a positive integer."))
-          ((not (and (integerp n) (plusp n)))
+          ((not (typep n 'positive-integer))
            (ers 64 "~%N argument " n " to CHUNK fails to be a positive integer."))
           (T (values-list
                (mapcar #'(lambda (i)
@@ -7307,9 +7579,9 @@
    (when (not items-p)        ;it is actually n that is optional
      (setq items n)
      (setq n 1))
-   (cond ((not (and (integerp m) (plusp m)))
+   (cond ((not (typep m 'positive-integer))
           (rrs 3 "~%M argument " m " to CHUNK fails to be a positive integer."))
-         ((not (and (integerp n) (plusp n)))
+         ((not (typep n 'positive-integer))
           (rrs 4 "~%N argument " n " to CHUNK fails to be a positive integer."))
          (T (cl:let* ((vars (n-gensyms m "CHUNK-"))
                         (outs (mapcar #'(lambda (v) (list v t)) vars))
@@ -7373,8 +7645,11 @@
 ;; API
 (defS collect-hash (keys values &rest option-plist)
    "Combines a series of keys and a series of values together into a hash table."
-  (fragL ((keys T) (values T) (option-plist)) ((table)) ((table T)) ()
-         ((setq table (apply #'make-hash-table option-plist)))
+  (fragL ((keys T) (values T) (option-plist))
+	 ((table))
+	 ((table T #+:series-letify (apply #'make-hash-table option-plist)))
+	 ()
+         (#-:series-letify (setq table (apply #'make-hash-table option-plist)))
          ((setf (gethash keys table) values)) () () nil)
  :optimizer
   (funcall-literal-frag
@@ -7388,10 +7663,11 @@
     "Prints the elements of ITEMS into a file."
   (fragL ((name) (items T) (printer)) ((out)) 
          ((out boolean T)
-	  (lastcons cons (list nil))
+	  (lastcons cons)
 	  (lst list))
 	 ()
-         ((setq lst lastcons))
+         ((setq lastcons (list nil))
+	  (setq lst lastcons))
 	 ((setq lastcons (setf (cdr lastcons) (cons items nil))))
          ((with-open-file (f name :direction :output)
             (dolist (item (cdr lst))
@@ -7419,10 +7695,11 @@
 (defS collect-stream (name items &optional (printer #'print))
     "Prints the elements of ITEMS onto the stream NAME."
   (fragL ((name) (items T) (printer)) (())
-	 ((lastcons cons (list nil))
+	 ((lastcons cons)
 	  (lst list))
 	 ()
-         ((setq lst lastcons))
+         ((setq lastcons (list nil))
+	  (setq lst lastcons))
 	 ((setq lastcons (setf (cdr lastcons) (cons items nil))))
          ((dolist (item (cdr lst))
             (cl:funcall printer item name)))
@@ -7468,27 +7745,33 @@
 (defS collect-last (items &optional (default nil))
     "Returns the last element of ITEMS."
   (fragL ((items T) (default)) ((item))
-         ((item (null-or (series-element-type items)))) ()
-         ((setq item default))
-         ((setq item items)) () () nil)
+         ((item (null-or (series-element-type items)) #+:series-letify default))
+	 ()
+         (#-:series-letify (setq item default))
+         ((setq item items))
+	 () () nil)
  :trigger T)
 
 ;; API
 (defS collect-first (items &optional (default nil))
     "Returns the first element of ITEMS."
   (fragL ((items T) (default)) ((item))
-	 ((item (null-or (series-element-type items)))) ()
-         ((setq item default))
-         ((setq item items) (go END)) () () nil)
+	 ((item (null-or (series-element-type items)) #+:series-letify default))
+	 ()
+         (#-:series-letify (setq item default))
+         ((setq item items) (go END))
+	 () () nil)
  :trigger T)
 
 ;; API
 (defS collect-nth (n items &optional (default nil))
     "Returns the nth element of ITEMS."
   (fragL ((n) (items T) (default)) ((item))
-         ((counter fixnum)
-          (item (null-or (series-element-type items)))) ()
-         ((setq item default) (setq counter n))
+         ((counter fixnum #+:series-letify n)
+          (item (null-or (series-element-type items)) #+:series-letify default))
+	 ()
+         (#-:series-letify (setq counter n)
+	  #-:series-letify (setq item default))
          ((when (zerop counter) (setq item items) (go END))
           (decf counter)) () () nil)
  :trigger T)
@@ -7525,9 +7808,10 @@
 ;; API
 (defS collect-sum (numbers &optional (type 'number))
     "Computes the sum of the elements in NUMBERS."
-  (fragL ((numbers T) (type)) ((sum)) ((sum T))
+  (fragL ((numbers T) (type)) ((sum))
+	 ((sum T #+:series-letify (coerce 0 type)))
 	 ()
-	 ((setq sum (coerce 0 type)))
+	 (#-:series-letify (setq sum (coerce 0 type)))
          ((setq sum (+ sum numbers)))
 	 () () nil)
  :optimizer
@@ -7543,17 +7827,18 @@
 (defS collect-product (numbers &optional (type 'number))
   "Computes the product of the elements in NUMBERS."
   (fragL ((numbers T)
-          (type)) ((res)) ((res T))
+          (type)) ((mul))
+	  ((mul T #+:series-letify (coerce 1 type)))
 	  ()
-          ((setq res (coerce 1 type)))
-          ((setq res (* res numbers)))
+          (#-:series-letify (setq mul (coerce 1 type)))
+          ((setq mul (* mul numbers)))
 	  () () nil)
   :optimizer
   (funcall-literal-frag
-   `((((numbers T)) ((res))
-      ((res ,(must-be-quoted type) ,(coerce 1 (must-be-quoted type)))) ()
+   `((((numbers T)) ((mul))
+      ((mul ,(must-be-quoted type) ,(coerce 1 (must-be-quoted type)))) ()
       ()
-      ((setq res (* res numbers))) () () nil)
+      ((setq mul (* mul numbers))) () () nil)
      ,numbers))
   :trigger T)