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.
18 ;;; helper function for various macros which expect clauses of a given
21 ;;; KLUDGE: This implementation will hang on circular list structure. Since
22 ;;; this is an error-checking utility, i.e. its job is to deal with screwed-up
23 ;;; input, it'd be good style to fix it so that it can deal with circular list
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26 ;; Return true if X is a proper list whose length is between MIN and
28 (defun proper-list-of-length-p (x min &optional (max min))
35 (proper-list-of-length-p (cdr x)
42 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
44 (eval-when (:compile-toplevel :load-toplevel :execute)
45 (defun do-do-body (varlist endlist decls-and-code bind step name block)
46 (let* ((r-inits nil) ; accumulator for reversed list
47 (r-steps nil) ; accumulator for reversed list
50 ;; Check for illegal old-style DO.
51 (when (or (not (listp varlist)) (atom endlist))
52 (error "Ill-formed ~S -- possibly illegal old style DO?" name))
53 ;; Parse VARLIST to get R-INITS and R-STEPS.
55 (flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be defined
56 ;; in terms of CL:SETF, and CL:SETF can be defined in terms of
57 ;; CL:DO, and CL:DO can be defined in terms of the current
60 (setq r-inits (cons x r-inits)))
61 ;; common error-handling
63 (error "~S is an illegal form for a ~S varlist." v name)))
64 (cond ((symbolp v) (push-on-r-inits v))
66 (unless (symbolp (first v))
67 (error "~S step variable is not a symbol: ~S"
70 (let ((lv (length v)))
71 ;; (We avoid using CL:CASE here so that CL:CASE can be
72 ;; defined in terms of CL:SETF, and CL:SETF can be defined
73 ;; in terms of CL:DO, and CL:DO can be defined in terms of
74 ;; the current function.)
76 (push-on-r-inits (first v)))
80 (push-on-r-inits (list (first v) (second v)))
81 (setq r-steps (list* (third v) (first v) r-steps)))
82 (t (illegal-varlist)))))
83 (t (illegal-varlist)))))
84 ;; Construct the new form.
85 (multiple-value-bind (code decls) (parse-body decls-and-code nil)
87 (,bind ,(nreverse r-inits)
93 (,step ,@(nreverse r-steps))
95 (unless ,(first endlist) (go ,label-1))
96 (return-from ,block (progn ,@(rest endlist))))))))))
98 (defmacro do-anonymous (varlist endlist &rest body)
100 "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
101 Like DO, but has no implicit NIL block. Each Var is initialized in parallel
102 to the value of the specified Init form. On subsequent iterations, the Vars
103 are assigned the value of the Step form (if any) in parallel. The Test is
104 evaluated before each evaluation of the body Forms. When the Test is true,
105 the Exit-Forms are evaluated as a PROGN, with the result being the value
107 (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))