compile/math-ops.lisp

   1 (in-package :avm2-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                                (:coerce-any))))
  20                          (t
  21                           (append
  22                            (scompile (first cdr))
  23                            (loop for ,i in (cdr cdr)
  24                               append (scompile ,i)
  25                               collect `(,',opcode))
  26                            '((:coerce-any))))))))))
  27
  28 (define-transitive-binops
  29   (+ :add 0)
  30   (- :subtract nil %1-)
  31   (* :multiply 1)
  32   (/ :divide nil %1/)
  33   (logior :bit-or 0)
  34   (logxor :bit-xor 0)
  35   (logand :bit-and -1)
  36   ;; (logeqv ??? -1)
  37 )
  38 ;;(scompile '(+))
  39 ;;(scompile '(+ 1))
  40 ;;(scompile '(+ 1 2))
  41 ;;(scompile '(+ 1 2 3))
  42
  43 (defmacro define-compare-binops (&body ops)
  44   (let ((i (gensym))
  45         (j (gensym)))
  46     `(progn
  47        ,@(loop for (op opcode) in ops
  48             collect `(defmethod scompile-cons ((car (eql ',op)) cdr)
  49                        (case (length cdr)
  50                          (0 (error "not enough arguments for ~a" ',op))
  51                          (1 `((:push-true)
  52                               (:coerce-any)))
  53                          (2 (append
  54                              (scompile (first cdr))
  55                              (scompile (second cdr))
  56                              `((,',opcode)
  57                                (:coerce-any))))
  58                          (t
  59                           (append
  60                            (scompile (first cdr))
  61                            (scompile (second cdr))
  62                            `((,',opcode))
  63                            (loop for (,i ,j) on (cdr cdr)
  64                               while ,j
  65                               append (scompile ,i)
  66                               append (scompile ,j)
  67                               collect `(,',opcode)
  68                               collect `(:bit-and) ;; no logical and?
  69                                 )
  70                            '((:coerce-any))))))))))
  71
  72 (define-compare-binops
  73     (< :less-than)
  74     (<= :less-equals)
  75     (= :equals)
  76     (>= :greater-equals)
  77     (> :greater-than))
  78
  79 ;; (scompile '(< 1 2 3 4))