/[gcl]/gcl/lsp/loop.lsp
ViewVC logotype

Diff of /gcl/lsp/loop.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by camm, Sun Nov 17 21:43:01 2002 UTC revision 1.6 by camm, Wed Nov 27 04:09:41 2002 UTC
# Line 729  a LET-like macro, and a SETQ-like macro, Line 729  a LET-like macro, and a SETQ-like macro,
729  ;;;List of all the value-accumulation descriptor structures in the loop.  ;;;List of all the value-accumulation descriptor structures in the loop.
730  ;;; See loop-get-collection-info.  ;;; See loop-get-collection-info.
731  (defvar *loop-collection-cruft*)                ; for multiple COLLECTs (etc)  (defvar *loop-collection-cruft*)                ; for multiple COLLECTs (etc)
732    
733    ;;;Flag indicating value accumulation without into
734    (defvar *loop-collection-no-into*)
735    
736    
737    
738    
739    
740  ;;;; Code Analysis Stuff  ;;;; Code Analysis Stuff
# Line 1017  collected result will be returned as the Line 1023  collected result will be returned as the
1023          (*loop-when-it-variable* nil)          (*loop-when-it-variable* nil)
1024          (*loop-never-stepped-variable* nil)          (*loop-never-stepped-variable* nil)
1025          (*loop-names* nil)          (*loop-names* nil)
1026            (*loop-collection-no-into* nil)
1027          (*loop-collection-cruft* nil))          (*loop-collection-cruft* nil))
1028      (loop-iteration-driver)      (loop-iteration-driver)
1029      (loop-bind-block)      (loop-bind-block)
# Line 1026  collected result will be returned as the Line 1033  collected result will be returned as the
1033                       ,(nreverse *loop-body*)                       ,(nreverse *loop-body*)
1034                       ,(nreverse *loop-after-body*)                       ,(nreverse *loop-after-body*)
1035                       ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*)))))                       ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*)))))
1036        (do () (nil)  ;      (do () (nil)
1037          (setq answer `(block ,(pop *loop-names*) ,answer))  ;       (setq answer `(block ,(pop *loop-names*) ,answer))
1038          (unless *loop-names* (return nil)))  ;       (unless *loop-names* (return nil)))
1039    ;      (setq answer `(block ,(car *loop-names*) ,answer))
1040        (dolist (entry *loop-bind-stack*)        (dolist (entry *loop-bind-stack*)
1041          (let ((vars (first entry))          (let ((vars (first entry))
1042                (dcls (second entry))                (dcls (second entry))
# Line 1048  collected result will be returned as the Line 1056  collected result will be returned as the
1056                                     `((destructuring-bind ,@crocks                                     `((destructuring-bind ,@crocks
1057                                           ,@forms))                                           ,@forms))
1058                                   forms)))))))                                   forms)))))))
1059          (setq answer `(block ,(car *loop-names*) ,answer))
1060        answer)))        answer)))
1061    
1062    
# Line 1105  collected result will be returned as the Line 1114  collected result will be returned as the
1114  (defun loop-emit-final-value (form)  (defun loop-emit-final-value (form)
1115    (push (loop-construct-return form) *loop-after-epilogue*)    (push (loop-construct-return form) *loop-after-epilogue*)
1116    (when *loop-final-value-culprit*    (when *loop-final-value-culprit*
1117      (loop-warn "LOOP clause is providing a value for the iteration,~@      (if *loop-collection-no-into*
1118            (specific-error :invalid-form "LOOP clause is providing a value for the iteration,~@
1119                    however one was already established by a ~S clause."
1120                            *loop-final-value-culprit*)
1121          (loop-warn "LOOP clause is providing a value for the iteration,~@
1122                  however one was already established by a ~S clause."                  however one was already established by a ~S clause."
1123                 *loop-final-value-culprit*))                   *loop-final-value-culprit*)))
1124    (setq *loop-final-value-culprit* (car *loop-source-context*)))    (setq *loop-final-value-culprit* (car *loop-source-context*)))
1125    
1126    
# Line 1345  collected result will be returned as the Line 1358  collected result will be returned as the
1358    
1359    
1360  (defun loop-get-collection-info (collector class default-type)  (defun loop-get-collection-info (collector class default-type)
1361      (unless (loop-tequal (car *loop-source-code*)'into)
1362        (setq *loop-collection-no-into* t))
1363    (let ((form (loop-get-form))    (let ((form (loop-get-form))
1364          (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))          (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))
1365          (name (when (loop-tequal (car *loop-source-code*) 'into)          (name (when (loop-tequal (car *loop-source-code*) 'into)
# Line 1461  collected result will be returned as the Line 1476  collected result will be returned as the
1476  (defun loop-do-thereis (restrictive)  (defun loop-do-thereis (restrictive)
1477    (when restrictive (loop-disallow-conditional))    (when restrictive (loop-disallow-conditional))
1478    (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form))    (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form))
1479                       ,(loop-construct-return *loop-when-it-variable*))))                       ,(loop-construct-return *loop-when-it-variable*)))
1480      (loop-emit-final-value nil))
1481    
1482    
1483  (defun loop-do-while (negate kwd &aux (form (loop-get-form)))  (defun loop-do-while (negate kwd &aux (form (loop-get-form)))

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26