compile/defun.lisp

   1 (in-package :avm2-compiler)
   2
   3 ;;;; defun and similar
   4
   5 (defun %compile-defun (name args body method constructor &key (nil-block t))
   6   ;; fixme: is the nil-block stuff still valid?
   7   (with-lambda-context (:args args :blocks (when nil-block (list nil)))
   8     (append
   9      (if (or method constructor)
  10          '((:get-local-0)
  11            (:push-scope))
  12          nil)
  13      (if constructor
  14          '((:get-local-0)
  15            (:construct-super 0))
  16          nil)
  17      (if constructor
  18          `(,@(scompile `(block ,name ,@body))
  19              ;;(pop)
  20              (:return-void))
  21          `(,@(scompile `(block ,name ,@body))
  22              (:return-value)))
  23      (compile-lambda-context-cleanup))))
  24
  25 (defun %swf-defun (name args body &key method constructor)
  26   ;; was pushnew, but that makes it hard to work on code (since can't
  27   ;; redefine things) push isn't quite right either, should replace
  28   ;; existing value or something
  29   ;; (or more likely, just not have a list at all?)
  30   (flet ((parse-arglist (args)
  31            ;; fixme: add error checking, better lambda list parsing
  32            (loop with rest = nil
  33               with optional = nil
  34               for i in args
  35               when (eq i'&arest)
  36               do
  37                 (setf rest i)
  38                 (setf i nil)
  39                 (setf optional nil)
  40               when (eq i '&optional)
  41               do
  42                 (setf optional t)
  43                 (setf i nil)
  44               when (and i (not rest))
  45               count 1 into count
  46               when i
  47               collect i into arg-names
  48               and when optional
  49               collect i into optional-names
  50               finally (return (values arg-names count rest optional-names)))))
  51     (multiple-value-bind (names count rest-p optionals)
  52         (parse-arglist args)
  53       (declare (ignorable optionals))
  54       (when optionals (error "&optional args not supported yet"))
  55       (push
  56        ;; function data:
  57        ;;  swf name in format suitable for passing to asm (string/'(qname...))
  58        ;;  args to avm2-method:
  59        ;;    name id?
  60        ;;    list of arg types (probably all T/* for now)
  61        ;;    return type
  62        ;;    flags
  63        ;;    list of assembly
  64        ;;    ?
  65        (list
  66         (avm2-asm::symbol-to-qname-list name)
  67         0                              ;; name in method struct?
  68         (loop repeat count collect 0)  ;; arg types, 0 = t/*/any
  69         0                              ;; return type, 0 = any
  70         (if rest-p #x04 0)             ;; flags, #x04 = &rest
  71         (%compile-defun name names body method constructor))
  72        (gethash name (functions *symbol-table*) (list))
  73        ;;:test 'equal
  74        ;;:key 'car
  75        ))))
  76
  77 ;;(format t "~{~s~%~}" (sixth (find-swf-function 'floor)))
  78 ;;(format t "~{~s~%~}" (avm2-asm::avm2-disassemble (avm2-asm:assemble (sixth (find-swf-function 'random)))))
  79
  80 (defun old-%swf-defun (name args body &key method constructor)
  81   (when (symbolp name)
  82     (setf name (avm2-asm::symbol-to-qname name)))
  83   (with-lambda-context (:args args)
  84     (let* ((mid
  85             (avm2-asm::avm2-method 0
  86                                  (loop for i in args collect 0 ) ;; 0 = * (any type)
  87                                  0 0
  88                                  :body
  89                                  (assemble-method-body
  90                                   (append
  91                                    (if (or method constructor)
  92                                        '((:get-local-0)
  93                                          (:push-scope))
  94                                        nil)
  95                                    (if constructor
  96                                        '((:get-local-0)
  97                                          (:construct-super 0))
  98                                        nil)
  99                                    (if constructor
 100                                        `(,@(scompile `(progn ,@body))
 101                                            ;;(pop)
 102                                            (:return-void))
 103                                        (scompile `(return (progn ,@body)))))))))
 104       (unless constructor
 105         (push (list name mid) (function-names *compiler-context*)))
 106       mid)))
 107
 108 (defmacro swf-defun (name (&rest args) &body body)
 109   `(%swf-defun ',name ',args (list
 110                             ,@(loop for i in body
 111                                  if (and (consp i) (eql (car i) 'cl))
 112                                  collect (cadr i)
 113                                  else
 114                                  collect (list 'quote i)))))
 115
 116 (defmacro swf-constructor (name (&rest args) &body body)
 117   `(%swf-defun ',name ',args (list
 118                             ,@(loop for i in body
 119                                  if (and (consp i) (eql (car i) 'cl))
 120                                  collect (cadr i)
 121                                  else
 122                                  collect (list 'quote i)))
 123                :constructor t))
 124
 125 (defmacro swf-defmemfun (name (&rest args) &body body)
 126   `(%swf-defun ',name ',args (list
 127                             ,@(loop for i in body
 128                                  if (and (consp i) (eql (car i) 'cl))
 129                                  collect (cadr i)
 130                                  else
 131                                  collect (list 'quote i)))
 132                :method t))
 133
 134 (defmacro define-swf-class (name super (&rest options) &body members)
 135
 136 )
 137
 138
 139 (defmacro swf-defmacro (name (&rest args) &body body)
 140   `(defmethod scompile-cons ((car (eql ',name)) cdr)
 141      (destructuring-bind (,@args) cdr
 142        (scompile
 143         (progn ,@body)))))
 144
 145
 146 (defmacro dump-defun-asm (args &body body)
 147   "debugging function to compile a defun to asm, and print results"
 148   (let ((asm (gensym)))
 149     `(let ((,asm (%compile-defun 'foo
 150                   ',args
 151                   ',body
 152                   nil nil)))
 153        (format t "~%~{~s~%~}" ,asm)
 154        ,asm)))