;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:ZL -*-

;;Date: Wed, 3 Dec 86 14:37 EST
;;From: Steve Goldhaber <goldy@Think.COM>
;;Subject: lambda compiler bug

;;; Here is the compiler bug that I found.

(defun case-1 ()

  (cdl-string-per-word "foo bar baz lsdf asdfa" " ")) ; works fine.

(defun case-2 ()
  (cdl-string-per-word "foo bar baz lsdf asdfa"))	   ; crashes

;; If you evaluate the function, it works fine.
;; If you change the names of the variables (stop from answer-list to) in
;; the first let, it still crashes, but differently.

(defun cdl-string-per-word (string &optional (divider #\space))
  "Divides long string with spaces into a list of strings broken at spaces, or
   at any of the characters in the divider string"
  (if (stringp divider)
      (let ((stop (string-length string))
	    (from (string-search-not-set divider string))
	    (answer-list nil))
	(do ((to (cond (from (string-search-set divider string from stop)))
		 (cond (from (string-search-set divider string from stop)))))
	    ((or (null from)(= from stop)))
	  (cond (to (push (substring string from to) answer-list)
		    (setq from (string-search-not-set divider string to)))
		((string-search-not-set divider string from)
		 (push (substring string from stop) answer-list)
		 (setq from stop))))
	(apply #'list (nreverse answer-list)))
      ;;this is for when there is only one divider character
    (let ((stop (string-length string))
	  (from (string-search-not-char divider string))
	  (answer-list nil))
      (print answer-list)
      (do ((to (cond (from (%string-search-char divider string from stop)))
	       (cond (from (%string-search-char divider string from stop)))))
	  ((or (null from)(= from stop)))
	(cond (to (push (substring string from to) answer-list)
		  (setq from (string-search-not-char divider string to)))
	      ((string-search-not-char divider string from)
	       (push (substring string from stop) answer-list)
	       (setq from stop)))
	(print (list from stop answer-list))
	)
	(print answer-list)
	(apply #'list (nreverse answer-list)))))





(defmacro valspy (&rest vals)
  `(*valspy ',vals ,@vals))

(defun *valspy (vars &rest vals)
  (format t "~&")
  (do ((v vars (cdr v))
       (l vals (cdr l)))
      ((null v) (terpri))
    (format t "~S = ~S" (car v) (car l))
    (or (null (cdr v)) (princ " "))))

;; (bug-1 "foo") bombs
;; (bug-2 "foo") is ok.
;; i think that %string-search-char is leaving too many things on the stack.

(defun bug-1 (string)
  (let ((divider #\space))
    (let ((stop (string-length string))
	  (from (string-search-not-char divider string))
	  (answer-list nil))
      (valspy stop from)
      (do ((to (cond (from (%string-search-char divider string from stop)))
	       (cond (from (%string-search-char divider string from stop)))))
	  ((or (null from)(= from stop)))
	(valspy to from stop)
	(cond (to (push (substring string from to) answer-list)
		  (setq from (string-search-not-char divider string to)))
	      ((string-search-not-char divider string from)
	       (push (substring string from stop) answer-list)
	       (setq from stop)))
	(valspy to from stop)	
	)
      (valspy answer-list)
      (valspy answer-list)
      (apply #'list (nreverse answer-list)))))


(defun bug-2 (string)
  (let ((divider #\space))
    (let ((stop (string-length string))
	  (from (string-search-not-char divider string))
	  (answer-list nil))
      (valspy stop from)
      (do ((to (cond (from (my-%string-search-char divider string from stop)))
	       (cond (from (my-%string-search-char divider string from stop)))))
	  ((or (null from)(= from stop)))
	(valspy to from stop)
	(cond (to (push (substring string from to) answer-list)
		  (setq from (string-search-not-char divider string to)))
	      ((string-search-not-char divider string from)
	       (push (substring string from stop) answer-list)
	       (setq from stop)))
	(valspy to from stop)
	
	)
      (valspy answer-list)
      (valspy answer-list)
      (apply #'list (nreverse answer-list)))))


(defun my-%string-search-char (char string start end)
  (%string-search-char char string start end))