compile/defun.lisp

   1 (in-package :as3-compiler)
   2
   3 ;;;; defun and similar
   4
   5 (defun %swf-defun (name args body &key method constructor)
   6   (let* ((*current-lambda* (make-lambda-context args)))
   7     (pushnew
   8      ;; function data:
   9      ;;  swf name in format suitable for passing to asm (string/'(qname...))
  10      ;;  args to as3-method:
  11      ;;    name id?
  12      ;;    list of arg types (probably all T/* for now)
  13      ;;    return type
  14      ;;    flags
  15      ;;    list of assembly
  16      ;;    ?
  17      (list
  18       (as3-asm::symbol-to-qname-list name)
  19       0 ;; name in method struct?
  20       (loop for i in args collect 0) ;; arg types, 0 = t/*/any
  21       0 0 ;; return type = any, flags = 0
  22       (append ;; assembly
  23        (if (or method constructor)
  24            '((:get-local-0)
  25              (:push-scope))
  26            nil)
  27        (if constructor
  28            '((:get-local-0)
  29              (:construct-super 0))
  30            nil)
  31        (if constructor
  32            `(,@(scompile `(progn ,@body))
  33                ;;(pop)
  34                (:return-void))
  35            (scompile `(return (progn ,@body))))))
  36      (gethash name (functions *symbol-table*) (list))
  37      :test 'equal
  38      :key 'car)))
  39
  40 ;;(format t "~{~s~%~}" (sixth (find-swf-function 'floor)))
  41 ;;(format t "~{~s~%~}" (as3-asm::as3-disassemble (as3-asm:assemble (sixth (find-swf-function 'random)))))
  42
  43 (defun old-%swf-defun (name args body &key method constructor)
  44   (when (symbolp name)
  45     (setf name (as3-asm::symbol-to-qname name)))
  46   (let* ((*current-lambda* (make-lambda-context args))
  47          (mid
  48           (as3-asm::as3-method 0
  49                       (loop for i in args collect 0 ) ;; 0 = * (any type)
  50                       0 0
  51                       :body
  52                       (assemble-method-body
  53                        (append
  54                         (if (or method constructor)
  55                             '((:get-local-0)
  56                               (:push-scope))
  57                             nil)
  58                         (if constructor
  59                             '((:get-local-0)
  60                               (:construct-super 0))
  61                             nil)
  62                         (if constructor
  63                             `(,@(scompile `(progn ,@body))
  64                                 ;;(pop)
  65                                 (:return-void))
  66                             (scompile `(return (progn ,@body)))))))))
  67     (unless constructor
  68       (push (list name mid) (function-names *compiler-context*)))
  69     mid))
  70
  71 (defmacro swf-defun (name (&rest args) &body body)
  72   `(%swf-defun ',name ',args (list
  73                             ,@(loop for i in body
  74                                  if (and (consp i) (eql (car i) 'cl))
  75                                  collect (cadr i)
  76                                  else
  77                                  collect (list 'quote i)))))
  78
  79 (defmacro swf-constructor (name (&rest args) &body body)
  80   `(%swf-defun ',name ',args (list
  81                             ,@(loop for i in body
  82                                  if (and (consp i) (eql (car i) 'cl))
  83                                  collect (cadr i)
  84                                  else
  85                                  collect (list 'quote i)))
  86                :constructor t))
  87
  88 (defmacro swf-defmemfun (name (&rest args) &body body)
  89   `(%swf-defun ',name ',args (list
  90                             ,@(loop for i in body
  91                                  if (and (consp i) (eql (car i) 'cl))
  92                                  collect (cadr i)
  93                                  else
  94                                  collect (list 'quote i)))
  95                :method t))
  96
  97 (defmacro define-swf-class (name super (&rest options) &body members)
  98
  99 )
 100
 101
 102 (defmacro swf-defmacro (name (&rest args) &body body)
 103   `(defmethod scompile-cons ((car (eql ',name)) cdr)
 104      (destructuring-bind (,@args) cdr
 105        (scompile
 106         ,@body))))