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 ;;; helper function for various macros which expect clauses of a given
  16 ;;; length, etc.
  17 ;;;
  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
  21 ;;; structure.
  22 (eval-when (:compile-toplevel :load-toplevel :execute)
  23   ;; Return true if X is a proper list whose length is between MIN and
  24   ;; MAX (inclusive).
  25   (defun proper-list-of-length-p (x min &optional (max min))
  26     (cond ((minusp max)
  27            nil)
  28           ((null x)
  29            (zerop min))
  30           ((consp x)
  31            (and (plusp max)
  32                 (proper-list-of-length-p (cdr x)
  33                                          (if (plusp (1- min))
  34                                            (1- min)
  35                                            0)
  36                                          (1- max))))
  37           (t nil))))
  38 \f
  39 ;;;; DO-related stuff which needs to be visible on the cross-compilation host
  40
  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
  45            (label-1 (gensym))
  46            (label-2 (gensym)))
  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.
  51       (dolist (v varlist)
  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
  55                ;; function.)
  56                (push-on-r-inits (x)
  57                  (setq r-inits (cons x r-inits)))
  58                ;; common error-handling
  59                (illegal-varlist ()
  60                  (error "~S is an illegal form for a ~S varlist." v name)))
  61           (cond ((symbolp v) (push-on-r-inits v))
  62                 ((listp v)
  63                  (unless (symbolp (first v))
  64                    (error "~S step variable is not a symbol: ~S"
  65                           name
  66                           (first v)))
  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.)
  72                    (cond ((= lv 1)
  73                           (push-on-r-inits (first v)))
  74                          ((= lv 2)
  75                           (push-on-r-inits v))
  76                          ((= lv 3)
  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)
  83         `(block ,block
  84            (,bind ,(nreverse r-inits)
  85                   ,@decls
  86                   (tagbody
  87                    (go ,label-2)
  88                    ,label-1
  89                    ,@code
  90                    (,step ,@(nreverse r-steps))
  91                    ,label-2
  92                    (unless ,(first endlist) (go ,label-1))
  93                    (return-from ,block (progn ,@(rest endlist))))))))))
  94
  95 (defmacro do-anonymous (varlist endlist &rest body)
  96   #!+sb-doc
  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
 103   of the DO."
 104   (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))