1 ;;;; target bootstrapping stuff which needs to be visible on the
2 ;;;; cross-compilation host too
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;; helper function for various macros which expect clauses of a given
18 ;;; KLUDGE: This implementation will hang on circular list structure. Since
19 ;;; this is an error-checking utility, i.e. its job is to deal with screwed-up
20 ;;; input, it'd be good style to fix it so that it can deal with circular list
22 (eval-when (:compile-toplevel :load-toplevel :execute)
23 ;; Return true if X is a proper list whose length is between MIN and
25 (defun proper-list-of-length-p (x min &optional (max min))
32 (proper-list-of-length-p (cdr x)
39 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
41 (eval-when (:compile-toplevel :load-toplevel :execute)
42 (defun do-do-body (varlist endlist decls-and-code bind step name block)
43 (let* ((r-inits nil) ; accumulator for reversed list
44 (r-steps nil) ; accumulator for reversed list
47 ;; Check for illegal old-style DO.
48 (when (or (not (listp varlist)) (atom endlist))
49 (error "Ill-formed ~S -- possibly illegal old style DO?" name))
50 ;; Parse VARLIST to get R-INITS and R-STEPS.
52 (flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be defined
53 ;; in terms of CL:SETF, and CL:SETF can be defined in terms of
54 ;; CL:DO, and CL:DO can be defined in terms of the current
57 (setq r-inits (cons x r-inits)))
58 ;; common error-handling
60 (error "~S is an illegal form for a ~S varlist." v name)))
61 (cond ((symbolp v) (push-on-r-inits v))
63 (unless (symbolp (first v))
64 (error "~S step variable is not a symbol: ~S"
67 (let ((lv (length v)))
68 ;; (We avoid using CL:CASE here so that CL:CASE can be
69 ;; defined in terms of CL:SETF, and CL:SETF can be defined
70 ;; in terms of CL:DO, and CL:DO can be defined in terms of
71 ;; the current function.)
73 (push-on-r-inits (first v)))
77 (push-on-r-inits (list (first v) (second v)))
78 (setq r-steps (list* (third v) (first v) r-steps)))
79 (t (illegal-varlist)))))
80 (t (illegal-varlist)))))
81 ;; Construct the new form.
82 (multiple-value-bind (code decls) (parse-body decls-and-code nil)
84 (,bind ,(nreverse r-inits)
90 (,step ,@(nreverse r-steps))
92 (unless ,(first endlist) (go ,label-1))
93 (return-from ,block (progn ,@(rest endlist))))))))))
95 (defmacro do-anonymous (varlist endlist &rest body)
97 "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
98 Like DO, but has no implicit NIL block. Each Var is initialized in parallel
99 to the value of the specified Init form. On subsequent iterations, the Vars
100 are assigned the value of the Step form (if any) in parallel. The Test is
101 evaluated before each evaluation of the body Forms. When the Test is true,
102 the Exit-Forms are evaluated as a PROGN, with the result being the value
104 (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))