home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #26 / NN_1992_26.iso / spool / comp / arch / 10425 < prev    next >
Encoding:
Text File  |  1992-11-06  |  4.0 KB  |  134 lines
  1. Xref: sparky comp.arch:10425 comp.lang.misc:3503
  2. Path: sparky!uunet!caen!sdd.hp.com!think.com!barmar
  3. From: barmar@think.com (Barry Margolin)
  4. Newsgroups: comp.arch,comp.lang.misc
  5. Subject: Re: A challenge to the anti-goto
  6. Date: 5 Nov 1992 22:06:46 GMT
  7. Organization: Thinking Machines Corporation, Cambridge MA, USA
  8. Lines: 121
  9. Message-ID: <1dc5tmINNhus@early-bird.think.com>
  10. References: <Bwznzx.Dr1@mentor.cc.purdue.edu> <Bx0BuG.s4@mentor.cc.purdue.edu> <1cvoctINNmhs@agate.berkeley.edu>
  11. NNTP-Posting-Host: telecaster.think.com
  12.  
  13. Spurred by Wayne Throop's suggestion that Lisp provides all the necessary
  14. structured control primitives as well as facilities for abstracting these
  15. easily, here's my Common Lisp version of the code.  The overall structure
  16. is based on John Hauser's rewrite of Herman Rubin's code.  As I was
  17. transcribing it I detected some repeated patterns and abstracted them into
  18. macros and inline local functions.  Common Lisp has named exits, so the
  19. goto's have become RETURN-FROMs.  One of them, "goto start", was so common
  20. and expressed a particular idiom, that I abstracted it away into the
  21. (restart) function.
  22.  
  23. (defvar *b*)
  24.  
  25. (block top-level
  26.   (let* ((n 0) (m 0) (h 0) (g4 0) (i 0) (j 0) (g16)
  27.      (b *b*)
  28.      (g (geometric)))
  29.     (declare (type fixnum n m h g4 i j b g g16)) ; should any be unsigned?
  30.     (loop
  31.       (block outer-loop
  32.     (macrolet ((ashf (variable shift)
  33.              `(setq ,variable (ash ,variable ,shift)))
  34.            (or-into (variable value)
  35.              `(setq ,variable (logior ,variable ,value))))
  36.       (labels ((restart () (return-from outer-loop)) 
  37.            ;; I'd give these better names if I knew what they were
  38.            ;; actually doing.
  39.            (g-m-thing ()
  40.              (setq g (geometric))
  41.              (or-into m (ash b (- g))))
  42.            (b-m-b-g-m-thing ()
  43.              (ashf b (- g4))
  44.              (or-into m b)
  45.              (ashf b 1)
  46.              (g-m-thing)))
  47.         ;; If your implementation doesn't do local inline functions,
  48.         ;; it's trivial to change the above functions to local macros.
  49.         (declare (inline restart g-m-thing oddp b-m-b-g-m-thing))
  50.         (block label4
  51.           (block label5
  52.         (case g
  53.           (1 (incf n) (restart))
  54.           ((3 5 6 9 10 11 12) (restart))
  55.           (2 (return-from top-level nil))
  56.           (4 (g-m-thing)
  57.              (return-from top-level nil))
  58.           (7 (setq g4 1)
  59.              (or-into m (ash b -1))
  60.              (g-m-thing)
  61.              (return-from top-level nil))
  62.           (8 (setq h (geometric)
  63.                g4 (ash h -1))
  64.              (when (oddp h)
  65.                (incf g4 2)
  66.                (ashf b (- g4))
  67.                (or-into m b)
  68.                (ashf b 1)
  69.                (setq g (geometric))
  70.                (or-into m (ash b g))
  71.                (return-from top-level nil))
  72.              (return-from label4))
  73.           (t (setq g16 (ash (- g 9) -4)
  74.                g (ldb (byte 2 0) g))
  75.              (case g
  76.                (1 (return-from label5))
  77.                (0 (setq h (geometric)
  78.                 g1 (ash (1+ h) -1))
  79.               (if (oddp h)
  80.                   (setq j 6)
  81.                   (progn
  82.                 (setq g (geometric))
  83.                 (unless (= (ldb (byte 2 0) h) 2)
  84.                   (restart))
  85.                 (setq j 7)
  86.                 (loop until (BIT) do
  87.                   (incf j)
  88.                   (setq g (geometric))
  89.                   (unless (oddp
  90.                         (ash 2 (/ (1- g) j)))
  91.                     (restart)))))
  92.               (loop do
  93.                 (setq i (c j))
  94.                 (ashf b -1)
  95.                 while (or (= i j) (zerop i)))
  96.               (or-into m b)
  97.               (case i
  98.                 (2 (g-m-thing)
  99.                    (return-from top-level nil))
  100.                 (3 (b-m-b-g-m-thing)
  101.                    (return-from top-level nil))
  102.                 (4 (return-from label4))
  103.                 (5)
  104.                 (t (return-from top-level nil))))
  105.                (t (restart))))))
  106.           ;; label5:
  107.           (ashf b (- g16))
  108.           (or-into m b)
  109.           (setq g (geometric))
  110.           (when (BIT)
  111.         (when (oddp g)
  112.           (g-m-thing))
  113.         (return))
  114.           (setq g4 (ash (1+ g) 1))
  115.           (when (oddp g)
  116.         (b-m-b-g-m-thing)
  117.         (return-from top-level nil)))
  118.         ;; label4:
  119.         (setq g (geometric))
  120.         (when (< g4 g)
  121.           (or-into m (logior (ash b (- g4)) (ash b (- g))))
  122.           (return-from top-level nil))
  123.         (or-into m (ash b (- g)))
  124.         (unless (BIT)
  125.           (ashf b (1+ g4))
  126.           (or-into m b)
  127.           (g-m-thing)
  128.           (return-from top-level nil))))))))
  129. -- 
  130. Barry Margolin
  131. System Manager, Thinking Machines Corp.
  132.  
  133. barmar@think.com          {uunet,harvard}!think!barmar
  134.