compile/math-ops.lisp

   1 (in-package :as3-compiler)
   2
   3 ;;; expand multiple arg math/comparison ops into chained binary ops
   4
   5 (defmacro define-transitive-binops (&body ops)
   6   (let ((i (gensym)))
   7     `(progn
   8        ,@(loop for (op opcode identity unary-op) in ops
   9             collect `(defmethod scompile-cons ((car (eql ',op)) cdr)
  10                        (case (length cdr)
  11                          (0 ,(if identity `(scompile ,identity) `(error "not enough arguments for ~a" ,op)))
  12                          (1 ,(if unary-op
  13                                  `(scompile `(,',unary-op ,(first cdr)))
  14                                  `(scompile (first cdr))))
  15                          (2 (append
  16                              (scompile (first cdr))
  17                              (scompile (second cdr))
  18                              `((,',opcode))))
  19                          (t
  20                           (append
  21                            (scompile (first cdr))
  22                            (loop for ,i in (cdr cdr)
  23                               append (scompile ,i)
  24                               collect `(,',opcode))))))))))
  25
  26 (define-transitive-binops
  27     (+ :add 0)
  28     (- :subtract nil %1-)
  29   (* :multiply 1)
  30   (/ :divide nil %1/)
  31   (logior :bit-or 0)
  32   (logxor :bit-xor 0)
  33   (logand :bit-and -1)
  34   ;; (logeqv ??? -1)
  35 )
  36 ;;(scompile '(+))
  37 ;;(scompile '(+ 1))
  38 ;;(scompile '(+ 1 2))
  39 ;;(scompile '(+ 1 2 3))
  40
  41 (defmacro define-compare-binops (&body ops)
  42   (let ((i (gensym))
  43         (j (gensym)))
  44     `(progn
  45        ,@(loop for (op opcode) in ops
  46             collect `(defmethod scompile-cons ((car (eql ',op)) cdr)
  47                        (case (length cdr)
  48                          (0 (error "not enough arguments for ~a" ',op))
  49                          (1 `((push-true)))
  50                          (2 (append
  51                              (scompile (first cdr))
  52                              (scompile (second cdr))
  53                              `((,',opcode))))
  54                          (t
  55                           (append
  56                            (scompile (first cdr))
  57                            (scompile (second cdr))
  58                            `((,',opcode))
  59                            (loop for (,i ,j) on (cdr cdr)
  60                               while ,j
  61                               append (scompile ,i)
  62                               append (scompile ,j)
  63                               collect `(,',opcode)
  64                               collect `(:bit-and) ;; no logical and?
  65                               )))))))))
  66
  67 (define-compare-binops
  68     (< :less-than)
  69     (<= :less-equals)
  70     (= :equals)
  71     (>= :greater-equals)
  72     (> :greater-than))
  73
  74 ;; (scompile '(< 1 2 3 4))