X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=ifstar.lisp;fp=ifstar.lisp;h=b0c85cd1a1c411f6dee26d373a494f7621647614;hb=7c7e6a18fd67e5370fd78690da2642cbe79e4113;hp=0000000000000000000000000000000000000000;hpb=0f12822c9d49849c26424743b3744d26056be4cc;p=kmrcl.git

diff --git a/ifstar.lisp b/ifstar.lisp
new file mode 100644
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)))))
+