ifstar.lisp

   1 ;;; -*- mode: common-lisp; package: lml2 -*-
   2 ;;;
   3 ;;; $Id: ifstar.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
   4 ;;;
   5 ;;; Public domain code by Franz
   6
   7 (in-package #:lml2)
   8
   9 (eval-when (:compile-toplevel :load-toplevel :execute)
  10   (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
  11
  12 (defmacro if* (&rest args)
  13    (do ((xx (reverse args) (cdr xx))
  14         (state :init)
  15         (elseseen nil)
  16         (totalcol nil)
  17         (lookat nil nil)
  18         (col nil))
  19        ((null xx)
  20         (cond ((eq state :compl)
  21                `(cond ,@totalcol))
  22               (t (error "if*: illegal form ~s" args))))
  23        (cond ((and (symbolp (car xx))
  24                    (member (symbol-name (car xx))
  25                            if*-keyword-list
  26                            :test #'string-equal))
  27               (setq lookat (symbol-name (car xx)))))
  28
  29        (cond ((eq state :init)
  30               (cond (lookat (cond ((string-equal lookat "thenret")
  31                                    (setq col nil
  32                                          state :then))
  33                                   (t (error
  34                                       "if*: bad keyword ~a" lookat))))
  35                     (t (setq state :col
  36                              col nil)
  37                        (push (car xx) col))))
  38              ((eq state :col)
  39               (cond (lookat
  40                      (cond ((string-equal lookat "else")
  41                             (cond (elseseen
  42                                    (error
  43                                     "if*: multiples elses")))
  44                             (setq elseseen t)
  45                             (setq state :init)
  46                             (push `(t ,@col) totalcol))
  47                            ((string-equal lookat "then")
  48                             (setq state :then))
  49                            (t (error "if*: bad keyword ~s"
  50                                               lookat))))
  51                     (t (push (car xx) col))))
  52              ((eq state :then)
  53               (cond (lookat
  54                      (error
  55                       "if*: keyword ~s at the wrong place " (car xx)))
  56                     (t (setq state :compl)
  57                        (push `(,(car xx) ,@col) totalcol))))
  58              ((eq state :compl)
  59               (cond ((not (string-equal lookat "elseif"))
  60                      (error "if*: missing elseif clause ")))
  61               (setq state :init)))))