lib/sicl-conditionals.lisp

   1 (in-package #:avm2-compiler)
   2
   3 ;;; pieces of sicl/conditionals.lisp that work so far
   4
   5 (let ((*symbol-table* *cl-symbol-table*))
   6
   7   (defun proper-list-p (object)
   8     (if (null object)
   9         t
  10         (if (consp object)
  11             (proper-list-p (cdr object))
  12             nil)))
  13
  14
  15
  16   (swf-defmacro or (&rest forms)
  17     (if (null forms)
  18         nil
  19         (if (not (consp forms))
  20             (error 'malformed-body :body forms)
  21             (if (null (cdr forms))
  22                 (car forms)
  23                 (let ((temp-var (gensym)))
  24                   `(let ((,temp-var ,(car forms)))
  25                      (if ,temp-var
  26                          ,temp-var
  27                          (or ,@(cdr forms)))))))))
  28
  29   (swf-defmacro and (&rest forms)
  30     (if (null forms)
  31         t
  32         (if (not (consp forms))
  33             (error 'malformed-body :body forms)
  34             (if (null (cdr forms))
  35                 (car forms)
  36                 `(if ,(car forms)
  37                      (and ,@(cdr forms))
  38                      nil)))))
  39
  40
  41   (swf-defmacro when (form &body body)
  42     (if (not (proper-list-p body))
  43         (error 'malformed-body :body body)
  44         `(if ,form
  45              (progn ,@body)
  46              nil)))
  47
  48   (swf-defmacro unless (form &body body)
  49     (if (not (proper-list-p body))
  50         (error 'malformed-body :body body)
  51         `(if ,form
  52              nil
  53              (progn ,@body))))
  54
  55
  56   (swf-defmacro cond (&rest clauses)
  57     (if (not (proper-list-p clauses))
  58         (error 'malformed-cond-clauses :clauses clauses)
  59         (if (null clauses)
  60             nil
  61             (let ((clause (car clauses)))
  62               (if (not (and (proper-list-p clause)
  63                             (not (null clause))))
  64                   (error 'malformed-cond-clause
  65                          :clause clause)
  66                   (if (null (cdr clause))
  67                       `(or ,(car clause)
  68                            (cond ,@(cdr clauses)))
  69                       `(if ,(car clause)
  70                            (progn ,@(cdr clause))
  71                            (cond ,@(cdr clauses)))))))))
  72
  73   (defun eql-ify (keys variable)
  74     (if (null keys)
  75         '()
  76         (cons `(eql ,variable ,(car keys))
  77               (eql-ify (cdr keys) variable))))
  78
  79 ;;; This function turns a list of CASE clauses into nested IFs.  It
  80 ;;; checks that the list of clauses is a proper list and that each
  81 ;;; clause is also a proper list.  It also checks that, if there is an
  82 ;;; otherwise clause, it is the last one.
  83   (defun expand-case-clauses (clauses variable)
  84   (if (null clauses)
  85       'nil
  86       (if (not (consp clauses))
  87           (error 'malformed-case-clauses
  88                  :clauses clauses)
  89           (let ((clause (car clauses)))
  90             (unless (and (proper-list-p clause)
  91                          (not (null clause)))
  92               (error 'malformed-case-clause
  93                      :clause clause))
  94             (if (or (eq (car clause) 'otherwise)
  95                     (eq (car clause) t))
  96                 (if (null (cdr clauses))
  97                     `(progn ,@(cdr clause))
  98                     (error 'otherwise-clause-not-last
  99                            :clauses (cdr clauses)))
 100                 ;; it is a normal clause
 101                 (let ((keys (car clause))
 102                       (forms (cdr clause)))
 103                   (if (and (atom keys)
 104                            (not (null keys)))
 105                       `(if (eql ,variable ,keys)
 106                            (progn ,@forms)
 107                            ,(expand-case-clauses (cdr clauses) variable))
 108                       (if (not (proper-list-p keys))
 109                           (error 'malformed-keys
 110                                  :keys keys)
 111                           `(if (or ,@(eql-ify keys variable))
 112                                (progn ,@forms)
 113                                ,(expand-case-clauses (cdr clauses) variable))))))))))
 114
 115   (swf-defmacro case (keyform &rest clauses)
 116     (let ((variable (gensym "CASE-VAR-")))
 117       `(let ((,variable ,keyform))
 118          ,(expand-case-clauses clauses variable))))
 119
 120 ;;; Turn a list of TYPECASE clauses into nested IFs.  We check that
 121 ;;; the list of clauses is a proper list, that each clause is a proper
 122 ;;; list as well, and that, if there is an otherwise clause, it is the
 123 ;;; last one.
 124   (defun expand-typecase-clauses (clauses variable)
 125     (if (null clauses)
 126         'nil
 127         (if (not (consp clauses))
 128             (error 'malformed-typecase-clauses
 129                    :clauses clauses)
 130             (let ((clause (car clauses)))
 131               (unless (and (proper-list-p clause)
 132                            (not (null clause)))
 133                 (error 'malformed-typecase-clause
 134                        :clause clause))
 135               (if (or (eq (car clause) 'otherwise)
 136                       (eq (car clause) t))
 137                   (if (null (cdr clauses))
 138                       `(progn ,@(cdr clause))
 139                       (error 'otherwise-clause-not-last
 140                              :clauses (cdr clauses)))
 141                   ;; it is a normal clause
 142                   (let ((type (car clause))
 143                         (forms (cdr clause)))
 144                     `(if (%typep ,variable ,type)
 145                          (progn ,@forms)
 146                          ,(expand-typecase-clauses (cdr clauses) variable))))))))
 147   (swf-defmacro typecase (keyform &rest clauses)
 148     (let ((variable (gensym)))
 149       `(let ((,variable ,keyform))
 150          ,(expand-typecase-clauses clauses variable))))
 151
 152   )