\f
;;;; 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
(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"))
(typecase var
(null
(when (consp val)
- ;; don't lose possible side-effects
+ ;; Don't lose possible side-effects.
(if (eq (car val) 'prog1)
- ;; these can come from psetq or desetq below.
- ;; throw away the value, keep the side-effects.
- ;;Special case is for handling an expanded POP.
- (mapcan #'(lambda (x)
- (and (consp x)
- (or (not (eq (car x) 'car))
- (not (symbolp (cadr x)))
- (not (symbolp (setq x (sb!xc:macroexpand x env)))))
- (cons x nil)))
+ ;; These can come from psetq or desetq below.
+ ;; Throw away the value, keep the side-effects.
+ ;; Special case is for handling an expanded POP.
+ (mapcan (lambda (x)
+ (and (consp x)
+ (or (not (eq (car x) 'car))
+ (not (symbolp (cadr x)))
+ (not (symbolp (setq x (sb!xc:macroexpand x env)))))
+ (cons x nil)))
(cdr val))
`(,val))))
(cons
specified-type required-type)))
specified-type)))
\f
+(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*)
(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 ()
(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))
(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)))
(this-group nil nil)
(this-prep nil nil)
(disallowed-prepositions
- (mapcan #'(lambda (x)
- (copy-list
- (find (car x) preposition-groups :test #'in-group-p)))
+ (mapcan (lambda (x)
+ (copy-list
+ (find (car x) preposition-groups :test #'in-group-p)))
initial-phrases))
(used-prepositions (mapcar #'car initial-phrases)))
((null *loop-source-code*) (nreverse prepositional-phrases))
||#
(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!"))
(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))
'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*
projects / sbcl.git / blobdiff