(t
(give-up-ir1-transform))))
-;;; FIXME: Why is this code commented out? (Why *was* it commented
-;;; out? We inherited this situation from cmucl-2.4.8, with no
-;;; explanation.) Should we just delete this code?
-#|
-;;; This is a frob whose job it is to make it easier to pass around
-;;; the arguments to IR1 transforms. It bundles together the name of
-;;; the argument (which should be referenced in any expansion), and
-;;; the continuation for that argument (or NIL if unsupplied.)
-(defstruct (arg (:constructor %make-arg (name cont))
- (:copier nil))
- (name nil :type symbol)
- (cont nil :type (or continuation null)))
-(defmacro make-arg (name)
- `(%make-arg ',name ,name))
-
-;;; If Arg is null or its CONT is null, then return Default, otherwise
-;;; return Arg's NAME.
-(defun default-arg (arg default)
- (declare (type (or arg null) arg))
- (if (and arg (arg-cont arg))
- (arg-name arg)
- default))
-
-;;; If Arg is null or has no CONT, return the default. Otherwise, Arg's
-;;; CONT must be a constant continuation whose value we return. If not, we
-;;; give up.
-(defun arg-constant-value (arg default)
- (declare (type (or arg null) arg))
- (if (and arg (arg-cont arg))
- (let ((cont (arg-cont arg)))
- (unless (constant-continuation-p cont)
- (give-up-ir1-transform "Argument is not constant: ~S."
- (arg-name arg)))
- (continuation-value from-end))
- default))
-
-;;; If Arg is a constant and is EQL to X, then return T, otherwise NIL. If
-;;; Arg is NIL or its CONT is NIL, then compare to the default.
-(defun arg-eql (arg default x)
- (declare (type (or arg null) x))
- (if (and arg (arg-cont arg))
- (let ((cont (arg-cont arg)))
- (and (constant-continuation-p cont)
- (eql (continuation-value cont) x)))
- (eql default x)))
-
-(defstruct (iterator (:copier nil))
- ;; The kind of iterator.
- (kind nil (member :normal :result))
- ;; A list of LET* bindings to create the initial state.
- (binds nil :type list)
- ;; A list of declarations for Binds.
- (decls nil :type list)
- ;; A form that returns the current value. This may be set with SETF to set
- ;; the current value.
- (current (error "Must specify CURRENT."))
- ;; In a :NORMAL iterator, a form that tests whether there is a current value.
- (done nil)
- ;; In a :RESULT iterator, a form that truncates the result at the current
- ;; position and returns it.
- (result nil)
- ;; A form that returns the initial total number of values. The result is
- ;; undefined after NEXT has been evaluated.
- (length (error "Must specify LENGTH."))
- ;; A form that advances the state to the next value. It is an error to call
- ;; this when the iterator is Done.
- (next (error "Must specify NEXT.")))
-
-;;; Type of an index var that can go negative (in the from-end case.)
-(deftype neg-index ()
- `(integer -1 ,most-positive-fixnum))
-
-;;; Return an ITERATOR structure describing how to iterate over an arbitrary
-;;; sequence. Sequence is a variable bound to the sequence, and Type is the
-;;; type of the sequence. If true, INDEX is a variable that should be bound to
-;;; the index of the current element in the sequence.
-;;;
-;;; If we can't tell whether the sequence is a list or a vector, or whether
-;;; the iteration is forward or backward, then GIVE-UP.
-(defun make-sequence-iterator (sequence type &key start end from-end index)
- (declare (symbol sequence) (type ctype type)
- (type (or arg null) start end from-end)
- (type (or symbol null) index))
- (let ((from-end (arg-constant-value from-end nil)))
- (cond ((csubtypep type (specifier-type 'vector))
- (let* ((n-stop (gensym))
- (n-idx (or index (gensym)))
- (start (default-arg 0 start))
- (end (default-arg `(length ,sequence) end)))
- (make-iterator
- :kind :normal
- :binds `((,n-idx ,(if from-end `(1- ,end) ,start))
- (,n-stop ,(if from-end `(1- ,start) ,end)))
- :decls `((type neg-index ,n-idx ,n-stop))
- :current `(aref ,sequence ,n-idx)
- :done `(,(if from-end '<= '>=) ,n-idx ,n-stop)
- :next `(setq ,n-idx
- ,(if from-end `(1- ,n-idx) `(1+ ,n-idx)))
- :length (if from-end
- `(- ,n-idx ,n-stop)
- `(- ,n-stop ,n-idx)))))
- ((csubtypep type (specifier-type 'list))
- (let* ((n-stop (if (and end (not from-end)) (gensym) nil))
- (n-current (gensym))
- (start-p (not (arg-eql start 0 0)))
- (end-p (not (arg-eql end nil nil)))
- (start (default-arg start 0))
- (end (default-arg end nil)))
- (make-iterator
- :binds `((,n-current
- ,(if from-end
- (if (or start-p end-p)
- `(nreverse (subseq ,sequence ,start
- ,@(when end `(,end))))
- `(reverse ,sequence))
- (if start-p
- `(nthcdr ,start ,sequence)
- sequence)))
- ,@(when n-stop
- `((,n-stop (nthcdr (the index
- (- ,end ,start))
- ,n-current))))
- ,@(when index
- `((,index ,(if from-end `(1- ,end) start)))))
- :kind :normal
- :decls `((list ,n-current ,n-end)
- ,@(when index `((type neg-index ,index))))
- :current `(car ,n-current)
- :done `(eq ,n-current ,n-stop)
- :length `(- ,(or end `(length ,sequence)) ,start)
- :next `(progn
- (setq ,n-current (cdr ,n-current))
- ,@(when index
- `((setq ,n-idx
- ,(if from-end
- `(1- ,index)
- `(1+ ,index)))))))))
- (t
- (give-up-ir1-transform
- "can't tell whether sequence is a list or a vector")))))
-
-;;; Make an iterator used for constructing result sequences. Name is a
-;;; variable to be bound to the result sequence. Type is the type of result
-;;; sequence to make. Length is an expression to be evaluated to get the
-;;; maximum length of the result (not evaluated in list case.)
-(defun make-result-sequence-iterator (name type length)
- (declare (symbol name) (type ctype type))
-
-;;; Define each NAME as a local macro that will call the value of the
-;;; function arg with the given arguments. If the argument isn't known to be a
-;;; function, give them an efficiency note and reference a coerced version.
-(defmacro coerce-funs (specs &body body)
- #!+sb-doc
- "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*"
- (collect ((binds)
- (defs))
- (dolist (spec specs)
- `(let ((body (progn ,@body))
- (n-fun (arg-name ,(second spec)))
- (fun-cont (arg-cont ,(second spec))))
- (cond ((not fun-cont)
- `(macrolet ((,',(first spec) (&rest args)
- `(,',',(third spec) ,@args)))
- ,body))
- ((not (csubtypep (continuation-type fun-cont)
- (specifier-type 'function)))
- (when (policy *compiler-error-context*
- (> speed inhibit-warnings))
- (compiler-notify
- "~S may not be a function, so must coerce at run-time."
- n-fun))
- (once-only ((n-fun `(if (functionp ,n-fun)
- ,n-fun
- (symbol-function ,n-fun))))
- `(macrolet ((,',(first spec) (&rest args)
- `(funcall ,',n-fun ,@args)))
- ,body)))
- (t
- `(macrolet ((,',(first spec) (&rest args)
- `(funcall ,',n-fun ,@args)))
- ,body)))))))
-
-;;; Wrap code around the result of the body to define Name as a local macro
-;;; that returns true when its arguments satisfy the test according to the Args
-;;; Test and Test-Not. If both Test and Test-Not are supplied, abort the
-;;; transform.
-(defmacro with-sequence-test ((name test test-not) &body body)
- `(let ((not-p (arg-cont ,test-not)))
- (when (and (arg-cont ,test) not-p)
- (abort-ir1-transform "Both ~S and ~S were supplied."
- (arg-name ,test)
- (arg-name ,test-not)))
- (coerce-funs ((,name (if not-p ,test-not ,test) eql))
- ,@body)))
-|#
-\f
+
;;;; hairy sequence transforms
;;; FIXME: no hairy sequence transforms in SBCL?
+;;;
+;;; There used to be a bunch of commented out code about here,
+;;; containing the (apparent) beginning of hairy sequence transform
+;;; infrastructure. People interested in implementing better sequence
+;;; transforms might want to look at it for inspiration, even though
+;;; the actual code is ancient CMUCL -- and hence bitrotted. The code
+;;; was deleted in 1.0.7.23.
\f
;;;; string operations
projects / sbcl.git / commitdiff