r5167: *** empty log message ***

[kmrcl.git] / ifstar.lisp

diff --git a/ifstar.lisp b/ifstar.lisp
new file mode 100644 (file)
index 0000000..b0c85cd
--- /dev/null
+++ b/ifstar.lisp
@@ -0,0 +1,61 @@
+;; the if* macro used in Allegro:
+;;
+;; This is in the public domain... please feel free to put this definition
+;; in your code or distribute it with your version of lisp.
+
+(in-package #:kmrcl)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
+
+(defmacro if* (&rest args)
+   (do ((xx (reverse args) (cdr xx))
+       (state :init)
+       (elseseen nil)
+       (totalcol nil)
+       (lookat nil nil)
+       (col nil))
+       ((null xx)
+       (cond ((eq state :compl)
+              `(cond ,@totalcol))
+             (t (error "if*: illegal form ~s" args))))
+       (cond ((and (symbolp (car xx))
+                  (member (symbol-name (car xx))
+                          if*-keyword-list
+                          :test #'string-equal))
+             (setq lookat (symbol-name (car xx)))))
+
+       (cond ((eq state :init)
+             (cond (lookat (cond ((string-equal lookat "thenret")
+                                  (setq col nil
+                                        state :then))
+                                 (t (error
+                                     "if*: bad keyword ~a" lookat))))
+                   (t (setq state :col
+                            col nil)
+                      (push (car xx) col))))
+            ((eq state :col)
+             (cond (lookat
+                    (cond ((string-equal lookat "else")
+                           (cond (elseseen
+                                  (error
+                                   "if*: multiples elses")))
+                           (setq elseseen t)
+                           (setq state :init)
+                           (push `(t ,@col) totalcol))
+                          ((string-equal lookat "then")
+                           (setq state :then))
+                          (t (error "if*: bad keyword ~s"
+                                             lookat))))
+                   (t (push (car xx) col))))
+            ((eq state :then)
+             (cond (lookat
+                    (error
+                     "if*: keyword ~s at the wrong place " (car xx)))
+                   (t (setq state :compl)
+                      (push `(,(car xx) ,@col) totalcol))))
+            ((eq state :compl)
+             (cond ((not (string-equal lookat "elseif"))
+                    (error "if*: missing elseif clause ")))
+             (setq state :init)))))
+