src/code/early-defboot.lisp

   1 ;;;; target bootstrapping stuff which needs to be visible on the
   2 ;;;; cross-compilation host too
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   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.
  12
  13 (in-package "SB!EXT")
  14
  15 (file-comment
  16   "$Header$")
  17
  18 ;;; helper function for various macros which expect clauses of a given
  19 ;;; length, etc.
  20 ;;;
  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
  24 ;;; structure.
  25 (eval-when (:compile-toplevel :load-toplevel :execute)
  26   ;; Return true if X is a proper list whose length is between MIN and
  27   ;; MAX (inclusive).
  28   (defun proper-list-of-length-p (x min &optional (max min))
  29     (cond ((minusp max)
  30            nil)
  31           ((null x)
  32            (zerop min))
  33           ((consp x)
  34            (and (plusp max)
  35                 (proper-list-of-length-p (cdr x)
  36                                          (if (plusp (1- min))
  37                                            (1- min)
  38                                            0)
  39                                          (1- max))))
  40           (t nil))))
  41 \f
  42 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
  43
  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
  48            (label-1 (gensym))
  49            (label-2 (gensym)))
  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.
  54       (dolist (v varlist)
  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
  58                ;; function.)
  59                (push-on-r-inits (x)
  60                  (setq r-inits (cons x r-inits)))
  61                ;; common error-handling
  62                (illegal-varlist ()
  63                  (error "~S is an illegal form for a ~S varlist." v name)))
  64           (cond ((symbolp v) (push-on-r-inits v))
  65                 ((listp v)
  66                  (unless (symbolp (first v))
  67                    (error "~S step variable is not a symbol: ~S"
  68                           name
  69                           (first v)))
  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.)
  75                    (cond ((= lv 1)
  76                           (push-on-r-inits (first v)))
  77                          ((= lv 2)
  78                           (push-on-r-inits v))
  79                          ((= lv 3)
  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)
  86         `(block ,block
  87            (,bind ,(nreverse r-inits)
  88                   ,@decls
  89                   (tagbody
  90                    (go ,label-2)
  91                    ,label-1
  92                    ,@code
  93                    (,step ,@(nreverse r-steps))
  94                    ,label-2
  95                    (unless ,(first endlist) (go ,label-1))
  96                    (return-from ,block (progn ,@(rest endlist))))))))))
  97
  98 (defmacro do-anonymous (varlist endlist &rest body)
  99   #!+sb-doc
 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
 106   of the DO."
 107   (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))