X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Floop.lisp;h=b3a79aeae850fb2930adb4a4e1cfdcf2515cb4e1;hb=aa61c7571b33b86981301f34d3acdb66666f53a3;hp=9f8ca8a9f0df9e6545b27f856b56208772958b82;hpb=5d18b03968d5fc696790609ae0ac2669473fbfb7;p=sbcl.git diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 9f8ca8a..b3a79ae 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -328,12 +328,6 @@ code to be loaded. ;;;; SETQ hackery -(defvar *loop-destructuring-hooks* - nil - #!+sb-doc - "If not NIL, this must be a list of two things: -a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") - (defun loop-make-psetq (frobs) (and frobs (loop-make-desetq @@ -345,10 +339,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-make-desetq (var-val-pairs) (if (null var-val-pairs) nil - (cons (if *loop-destructuring-hooks* - (cadr *loop-destructuring-hooks*) - 'loop-really-desetq) - var-val-pairs))) + (cons 'loop-really-desetq var-val-pairs))) (defvar *loop-desetq-temporary* (make-symbol "LOOP-DESETQ-TEMP")) @@ -581,26 +572,27 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (when (or *loop-duplicate-code* (not rbefore)) (return-from loop-body (makebody))) ;; This outer loop iterates once for each not-first-time flag test - ;; generated plus once more for the forms that don't need a flag test + ;; generated plus once more for the forms that don't need a flag test. (do ((threshold (loop-code-duplication-threshold env))) (nil) (declare (fixnum threshold)) - ;; Go backwards from the ends of before-loop and after-loop merging all - ;; the equivalent forms into the body. + ;; Go backwards from the ends of before-loop and after-loop + ;; merging all the equivalent forms into the body. (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) (push (pop rbefore) main-body) (pop rafter)) (unless rbefore (return (makebody))) - ;; The first forms in RBEFORE & RAFTER (which are the chronologically - ;; last forms in the list) differ, therefore they cannot be moved - ;; into the main body. If everything that chronologically precedes - ;; them either differs or is equal but is okay to duplicate, we can - ;; just put all of rbefore in the prologue and all of rafter after - ;; the body. Otherwise, there is something that is not okay to - ;; duplicate, so it and everything chronologically after it in - ;; rbefore and rafter must go into the body, with a flag test to - ;; distinguish the first time around the loop from later times. - ;; What chronologically precedes the non-duplicatable form will - ;; be handled the next time around the outer loop. + ;; The first forms in RBEFORE & RAFTER (which are the + ;; chronologically last forms in the list) differ, therefore + ;; they cannot be moved into the main body. If everything that + ;; chronologically precedes them either differs or is equal but + ;; is okay to duplicate, we can just put all of rbefore in the + ;; prologue and all of rafter after the body. Otherwise, there + ;; is something that is not okay to duplicate, so it and + ;; everything chronologically after it in rbefore and rafter + ;; must go into the body, with a flag test to distinguish the + ;; first time around the loop from later times. What + ;; chronologically precedes the non-duplicatable form will be + ;; handled the next time around the outer loop. (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) @@ -639,9 +631,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (if (null expr) 0 (let ((ans (estimate-code-size expr env))) (declare (fixnum ans)) - ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an - ;; alist of optimize quantities back to help quantify how much code we - ;; are willing to duplicate. + ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to + ;; get an alist of optimize quantities back to help quantify + ;; how much code we are willing to duplicate. ans))) (defvar *special-code-sizes* @@ -769,6 +761,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. specified-type required-type))) specified-type))) +(defun loop-build-destructuring-bindings (crocks forms) + (if crocks + `((destructuring-bind ,(car crocks) ,(cadr crocks) + ,@(loop-build-destructuring-bindings (cddr crocks) forms))) + forms)) + (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) @@ -817,16 +815,10 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (let ((forms (list answer))) ;;(when crocks (push crocks forms)) (when dcls (push `(declare ,@dcls) forms)) - (setq answer `(,(cond ((not vars) 'locally) - (*loop-destructuring-hooks* - (first *loop-destructuring-hooks*)) - (t - 'let)) + (setq answer `(,(if vars 'let 'locally) ,vars - ,@(if crocks - `((destructuring-bind ,@crocks - ,@forms)) - forms))))))) + ,@(loop-build-destructuring-bindings crocks + forms))))))) answer))) (defun loop-iteration-driver () @@ -861,17 +853,25 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (pop *loop-source-code*) (loop-error "LOOP source code ran out when another token was expected."))) -(defun loop-get-progn () - (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms)) - (nextform (car *loop-source-code*) (car *loop-source-code*))) - ((atom nextform) - (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) - (defun loop-get-form () (if *loop-source-code* (loop-pop-source) (loop-error "LOOP code ran out where a form was expected."))) +(defun loop-get-compound-form () + (let ((form (loop-get-form))) + (unless (consp form) + (loop-error "A compound form was expected, but ~S found." form)) + form)) + +(defun loop-get-progn () + (do ((forms (list (loop-get-compound-form)) + (cons (loop-get-compound-form) forms)) + (nextform (car *loop-source-code*) + (car *loop-source-code*))) + ((atom nextform) + (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) + (defun loop-construct-return (form) `(return-from ,(car *loop-names*) ,form)) @@ -910,17 +910,18 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (and *loop-source-code* ; Don't get confused by NILs.. (let ((z (car *loop-source-code*))) (cond ((loop-tequal z 'of-type) - ;; This is the syntactically unambigous form in that the form - ;; of the type specifier does not matter. Also, it is assumed - ;; that the type specifier is unambiguously, and without need - ;; of translation, a common lisp type specifier or pattern - ;; (matching the variable) thereof. + ;; This is the syntactically unambigous form in that + ;; the form of the type specifier does not matter. + ;; Also, it is assumed that the type specifier is + ;; unambiguously, and without need of translation, a + ;; common lisp type specifier or pattern (matching the + ;; variable) thereof. (loop-pop-source) (loop-pop-source)) ((symbolp z) - ;; This is the (sort of) "old" syntax, even though we didn't - ;; used to support all of these type symbols. + ;; This is the (sort of) "old" syntax, even though we + ;; didn't used to support all of these type symbols. (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) @@ -931,11 +932,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (loop-pop-source) type-spec))) (t - ;; This is our sort-of old syntax. But this is only valid for - ;; when we are destructuring, so we will be compulsive (should - ;; we really be?) and require that we in fact be doing variable - ;; destructuring here. We must translate the old keyword - ;; pattern typespec into a fully-specified pattern of real type + ;; This is our sort-of old syntax. But this is only + ;; valid for when we are destructuring, so we will be + ;; compulsive (should we really be?) and require that + ;; we in fact be doing variable destructuring here. We + ;; must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type ;; specifiers here. (if (consp variable) (unless (consp z) @@ -1009,14 +1011,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (push (list name (or initialization (loop-typed-init dtype))) *loop-variables*)) (initialization - (cond (*loop-destructuring-hooks* - (loop-declare-variable name dtype) - (push (list name initialization) *loop-variables*)) - (t (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) - (push (list newvar initialization) *loop-variables*) - ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. - (setq *loop-desetq-crocks* - (list* name newvar *loop-desetq-crocks*)))))) + (let ((newvar (gensym "LOOP-DESTRUCTURE-"))) + (loop-declare-variable name dtype) + (push (list newvar initialization) *loop-variables*) + ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. + (setq *loop-desetq-crocks* + (list* name newvar *loop-desetq-crocks*)))) (t (let ((tcar nil) (tcdr nil)) (if (atom dtype) (setq tcar (setq tcdr dtype)) (setq tcar (car dtype) tcdr (cdr dtype))) @@ -1377,11 +1377,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; various FOR/AS subdispatches -;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN -;;; is omitted (other than being more stringent in its placement), and like the -;;; old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first -;;; initialization occurs in the loop body (first-step), not in the variable -;;; binding phase. +;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when +;;; the THEN is omitted (other than being more stringent in its +;;; placement), and like the old "FOR x FIRST y THEN z" when the THEN +;;; is present. I.e., the first initialization occurs in the loop body +;;; (first-step), not in the variable binding phase. (defun loop-ansi-for-equals (var val data-type) (loop-make-iteration-variable var nil data-type) (cond ((loop-tequal (car *loop-source-code*) :then) @@ -1427,9 +1427,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; list iteration (defun loop-list-step (listvar) - ;; We are not equipped to analyze whether 'FOO is the same as #'FOO here in - ;; any sensible fashion, so let's give an obnoxious warning whenever 'FOO is - ;; used as the stepping function. + ;; We are not equipped to analyze whether 'FOO is the same as #'FOO + ;; here in any sensible fashion, so let's give an obnoxious warning + ;; whenever 'FOO is used as the stepping function. ;; ;; While a Discerning Compiler may deal intelligently with ;; (FUNCALL 'FOO ...), not recognizing FOO may defeat some LOOP @@ -1565,8 +1565,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (apply fun var data-type preps user-data)))) (when *loop-named-variables* (loop-error "Unused USING variables: ~S." *loop-named-variables*)) - ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the - ;; system from the user and the user from himself. + ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). + ;; Protect the system from the user and the user from himself. (unless (member (length stuff) '(6 10)) (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." path)) @@ -1640,11 +1640,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; master sequencer function -(defun loop-sequencer (indexv indexv-type indexv-user-specified-p - variable variable-type - sequence-variable sequence-type - step-hack default-top - prep-phrases) +(defun loop-sequencer (indexv indexv-type + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) (let ((endform nil) ; Form (constant or variable) with limit value (sequencep nil) ; T if sequence arg has been provided (testfn nil) ; endtest function @@ -1752,11 +1752,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-for-arithmetic (var val data-type kwd) (loop-sequencer - var (loop-check-data-type data-type 'real) t - nil nil nil nil nil nil - (loop-collect-prepositional-phrases - '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) - nil (list (list kwd val))))) + var (loop-check-data-type data-type 'real) + nil nil nil nil nil nil + (loop-collect-prepositional-phrases + '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) + nil (list (list kwd val))))) (defun loop-sequence-elements-path (variable data-type prep-phrases &key @@ -1764,16 +1764,16 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. size-function sequence-type element-type) - (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) + (multiple-value-bind (indexv) (named-variable 'index) (let ((sequencev (named-variable 'sequence))) (list* nil nil ; dummy bindings and prologue (loop-sequencer - indexv 'fixnum indexv-user-specified-p - variable (or data-type element-type) - sequencev sequence-type - `(,fetch-function ,sequencev ,indexv) - `(,size-function ,sequencev) - prep-phrases))))) + indexv 'fixnum + variable (or data-type element-type) + sequencev sequence-type + `(,fetch-function ,sequencev ,indexv) + `(,size-function ,sequencev) + prep-phrases))))) ;;;; builtin LOOP iteration paths @@ -1785,7 +1785,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ||# (defun loop-hash-table-iteration-path (variable data-type prep-phrases - &key (which (required-argument))) + &key (which (missing-arg))) (declare (type (member :hash-key :hash-value) which)) (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) (loop-error "too many prepositions!")) @@ -1796,12 +1796,14 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (dummy-predicate-var nil) (post-steps nil)) (multiple-value-bind (other-var other-p) - (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) - ;; @@@@ named-variable returns a second value of T if the name was - ;; actually specified, so clever code can throw away the gensym'ed up - ;; variable if it isn't really needed. The following is for those - ;; implementations in which we cannot put dummy NILs into - ;; multiple-value-setq variable lists. + (named-variable (ecase which + (:hash-key 'hash-value) + (:hash-value 'hash-key))) + ;; @@@@ NAMED-VARIABLE returns a second value of T if the name + ;; was actually specified, so clever code can throw away the + ;; GENSYM'ed-up variable if it isn't really needed. The + ;; following is for those implementations in which we cannot put + ;; dummy NILs into MULTIPLE-VALUE-SETQ variable lists. (setq other-p t dummy-predicate-var (loop-when-it-variable)) (let ((key-var nil) @@ -1809,9 +1811,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (bindings `((,variable nil ,data-type) (,ht-var ,(cadar prep-phrases)) ,@(and other-p other-var `((,other-var nil)))))) - (if (eq which 'hash-key) - (setq key-var variable val-var (and other-p other-var)) - (setq key-var (and other-p other-var) val-var variable)) + (ecase which + (:hash-key (setq key-var variable + val-var (and other-p other-var))) + (:hash-value (setq key-var (and other-p other-var) + val-var variable))) (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) (when (consp key-var) (setq post-steps @@ -1899,6 +1903,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (below (loop-for-arithmetic :below)) (to (loop-for-arithmetic :to)) (upto (loop-for-arithmetic :upto)) + (by (loop-for-arithmetic :by)) (being (loop-for-being))) :iteration-keywords '((for (loop-do-for)) (as (loop-do-for)) @@ -1937,7 +1942,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil - :user-data '(:symbol-types (:internal))) + :user-data '(:symbol-types (:internal + :external))) w)) (defparameter *loop-ansi-universe*