Skip to content
Snippets Groups Projects
ir1util.lisp 70 KiB
Newer Older
wlott's avatar
wlott committed
	  ((null current) nil)
	(when (funcall test (funcall key current) element)
	  (return i)))))


;;; Map-In  --  Interface
;;;
(defun map-in (next function list)
  "Map Function over the elements in a null-terminated List linked by the
  accessor function Next, returning a list of the results."
  (collect ((res))
    (do ((current list (funcall next current)))
	((null current))
      (res (funcall function current)))
    (res)))


;;; Deletef-In  --  Interface
;;;
(defmacro deletef-in (next place item &environment env)
  "Deletef-In Next Place Item
  Delete Item from a null-terminated list linked by the accessor function Next
  that is stored in Place.  Item must appear exactly once in the list."
  (multiple-value-bind
      (temps vals stores store access)
      (get-setf-method place env)
wlott's avatar
wlott committed
    (let ((n-item (gensym))
	  (n-place (gensym))
	  (n-current (gensym))
	  (n-prev (gensym)))
      `(let* (,@(mapcar #'list temps vals)
	      (,n-place ,access)
	      (,n-item ,item))
	 (if (eq ,n-place ,n-item)
	     (let ((,(first stores) (,next ,n-place)))
	       ,store)
	     (do ((,n-prev ,n-place ,n-current)
		  (,n-current (,next ,n-place)
			      (,next ,n-current)))
		 ((eq ,n-current ,n-item)
		  (setf (,next ,n-prev)
			(,next ,n-current)))))
	 (undefined-value)))))


;;; Push-In  --  Interface
;;;
(defmacro push-in (next item place &environment env)
  "Push Item onto a list linked by the accessor function Next that is stored in
  Place."
  (multiple-value-bind
      (temps vals stores store access)
      (get-setf-method place env)
wlott's avatar
wlott committed
    `(let (,@(mapcar #'list temps vals)
	   (,(first stores) ,item))
       (setf (,next ,(first stores)) ,access)
       ,store
       (undefined-value))))


;;; Compiler-Constantp  --  Interface
;;;
;;;    We don't want to assume that a variable is a constant just because it is
;;; in the current lisp environment.
;;;
;;; ### For now, just use CONSTANTP to avoid bootstrapping problems with having
;;; to have the INFO database available at meta-compile time.
;;;
(proclaim '(function compiler-constantp (t) boolean))
(defun compiler-constantp (exp)
  "Like constantp, only uses the compilation environment rather than the
  current Lisp environment."
#|
  (if (symbolp exp)
      (eq (info variable kind exp) :constant)
      (constantp exp))
|#
  (constantp exp))