From: barmar@think.com (Barry Margolin)
Newsgroups: comp.arch,comp.lang.misc
Subject: Re: A challenge to the anti-goto
Date: 5 Nov 1992 22:06:46 GMT
Organization: Thinking Machines Corporation, Cambridge MA, USA
NNTP-Posting-Host: telecaster.think.com

Spurred by Wayne Throop's suggestion that Lisp provides all the necessary
structured control primitives as well as facilities for abstracting these
easily, here's my Common Lisp version of the code.  The overall structure
is based on John Hauser's rewrite of Herman Rubin's code.  As I was
transcribing it I detected some repeated patterns and abstracted them into
macros and inline local functions.  Common Lisp has named exits, so the
goto's have become RETURN-FROMs.  One of them, "goto start", was so common
and expressed a particular idiom, that I abstracted it away into the
(restart) function.

(defvar *b*)

(block top-level
  (let* ((n 0) (m 0) (h 0) (g4 0) (i 0) (j 0) (g16)
	 (b *b*)
	 (g (geometric)))
    (declare (type fixnum n m h g4 i j b g g16)) ; should any be unsigned?
    (loop
      (block outer-loop
	(macrolet ((ashf (variable shift)
		     `(setq ,variable (ash ,variable ,shift)))
		   (or-into (variable value)
		     `(setq ,variable (logior ,variable ,value))))
	  (labels ((restart () (return-from outer-loop)) 
		   ;; I'd give these better names if I knew what they were
		   ;; actually doing.
		   (g-m-thing ()
		     (setq g (geometric))
		     (or-into m (ash b (- g))))
		   (b-m-b-g-m-thing ()
		     (ashf b (- g4))
		     (or-into m b)
		     (ashf b 1)
		     (g-m-thing)))
	    ;; If your implementation doesn't do local inline functions,
	    ;; it's trivial to change the above functions to local macros.
	    (declare (inline restart g-m-thing oddp b-m-b-g-m-thing))
	    (block label4
	      (block label5
		(case g
		  (1 (incf n) (restart))
		  ((3 5 6 9 10 11 12) (restart))
		  (2 (return-from top-level nil))
		  (4 (g-m-thing)
		     (return-from top-level nil))
		  (7 (setq g4 1)
		     (or-into m (ash b -1))
		     (g-m-thing)
		     (return-from top-level nil))
		  (8 (setq h (geometric)
			   g4 (ash h -1))
		     (when (oddp h)
		       (incf g4 2)
		       (ashf b (- g4))
		       (or-into m b)
		       (ashf b 1)
		       (setq g (geometric))
		       (or-into m (ash b g))
		       (return-from top-level nil))
		     (return-from label4))
		  (t (setq g16 (ash (- g 9) -4)
			   g (ldb (byte 2 0) g))
		     (case g
		       (1 (return-from label5))
		       (0 (setq h (geometric)
				g1 (ash (1+ h) -1))
			  (if (oddp h)
			      (setq j 6)
			      (progn
				(setq g (geometric))
				(unless (= (ldb (byte 2 0) h) 2)
				  (restart))
				(setq j 7)
				(loop until (BIT) do
				  (incf j)
				  (setq g (geometric))
				  (unless (oddp
					    (ash 2 (/ (1- g) j)))
				    (restart)))))
			  (loop do
			    (setq i (c j))
			    (ashf b -1)
				while (or (= i j) (zerop i)))
			  (or-into m b)
			  (case i
			    (2 (g-m-thing)
			       (return-from top-level nil))
			    (3 (b-m-b-g-m-thing)
			       (return-from top-level nil))
			    (4 (return-from label4))
			    (5)
			    (t (return-from top-level nil))))
		       (t (restart))))))
	      ;; label5:
	      (ashf b (- g16))
	      (or-into m b)
	      (setq g (geometric))
	      (when (BIT)
		(when (oddp g)
		  (g-m-thing))
		(return))
	      (setq g4 (ash (1+ g) 1))
	      (when (oddp g)
		(b-m-b-g-m-thing)
		(return-from top-level nil)))
	    ;; label4:
	    (setq g (geometric))
	    (when (< g4 g)
	      (or-into m (logior (ash b (- g4)) (ash b (- g))))
	      (return-from top-level nil))
	    (or-into m (ash b (- g)))
	    (unless (BIT)
	      (ashf b (1+ g4))
	      (or-into m b)
	      (g-m-thing)
	      (return-from top-level nil))))))))
-- 
Barry Margolin
System Manager, Thinking Machines Corp.

barmar@think.com          {uunet,harvard}!think!barmar
Xref: sparky comp.arch:10479 comp.lang.misc:3533