compile/ffi.lisp

   1 (in-package :avm2-compiler)
   2
   3
   4
   5 (defmacro declare-swf-class (class-name (&optional super) &body _ &key ((:swf-name class-swf-name)) constants properties methods)
   6   "declare an external class to be accessed through ffi"
   7
   8   (declare (ignore _))
   9   ;(format t "props = ~a ~%" properties)
  10   ;(format t "name = ~s  ~s eql=~s ~%" name (car (last (car properties))) (eql name (car (last (car properties)))))
  11   `(progn
  12      ;; using the old player-classes.lisp stuff for super for now, so
  13      ;; ignoring it...
  14
  15      ;; store class name
  16      (add-swf-class ',class-name ',class-swf-name :extends ',super)
  17
  18      ;; store constants
  19      ,@(loop for i in constants
  20           collect (destructuring-bind (name &key swf-name type value static) i
  21                     (declare (ignore type value))
  22                     `(pushnew (list ,class-swf-name ,swf-name)
  23                                 (gethash ',name (constants *symbol-table*)
  24                                          (list))
  25                                  :test 'equal)))
  26      ;; store properties
  27      ,@(loop for i in properties
  28           append (destructuring-bind (pname &key swf-name type access declared-by value static) i
  29                      (declare (ignore access type value))
  30                      `((add-swf-property ',pname  ,swf-name))))
  31      ;; store methods
  32      ,@(loop for i in methods
  33           append (destructuring-bind (mname &key swf-name return-type
  34                                            declared-by args static) i
  35                      (declare (ignore args return-type))
  36                      `((pushnew ,swf-name
  37                                 (gethash ',mname
  38                                          (class-methods *symbol-table*)
  39                                          (list))
  40                                 :test 'string=))))))
  41
  42 (defmacro swf-ffi-defun-lex (lisp-name member (&rest args) return &key class)
  43   "declare a static member function of a class, for example Math.random()"
  44   (declare (ignore args return))
  45   `(pushnew (list ',class ,member)
  46             (gethash ',lisp-name
  47                      (class-static-methods *symbol-table*) (list))
  48             :test 'equal))
  49
  50 (defmacro swf-ffi-defun-find-prop-strict (lisp-name member (&rest args) return)
  51   "declare a function in a namespace?, for example flash.sampler:getMemberNames()"
  52   (declare (ignore args return))
  53   `(pushnew (list ,member)
  54             (gethash ',lisp-name
  55                      (functions *symbol-table*) (list))
  56             :test 'equal))
  57
  58 (defmacro old-swf-ffi-defun-lex (lisp-name class member (&rest args) return)
  59   "declare a static member function of a class, for example Math.random()"
  60   (declare (ignore args return))
  61   `(pushnew (list ,class ,member)
  62             (gethash ',lisp-name
  63                      (class-static-methods *symbol-table*) (list))
  64             :test 'equal))
  65
  66 (defmacro swf-ffi-defconstant (lisp-name member type)
  67   "declare a top level constant, for example NaN"
  68   (declare (ignore type))
  69   `(pushnew (list "" ,member)
  70             (gethash ',lisp-name
  71                      (constants *symbol-table*) (list))
  72             :test 'equal))
  73 (defmacro swf-ffi-defconstant-lex (lisp-name class member type)
  74   "declare a constant member of a class, for example Math.PI"
  75   (declare (ignore type))
  76   `(pushnew (list ,class ,member)
  77             (gethash ',lisp-name
  78                      (constants *symbol-table*) (list))
  79             :test 'equal))
  80
  81 (defmacro swf-ffi-defmethod (lisp-name member (&rest args) return)
  82   "declare a member function of a class, for example array.concat()"
  83   (declare (ignore args return))
  84   `(pushnew ',member
  85             (gethash ',lisp-name
  86                      (class-methods *symbol-table*) (list))
  87             :test 'string=))
  88
  89 (defmacro old-swf-ffi-defmethod (lisp-name type member (&rest args) return)
  90   "declare a member function of a class, for example array.concat()"
  91   (declare (ignore type args return))
  92   `(pushnew ',member
  93             (gethash ',lisp-name
  94                      (class-methods *symbol-table*) (list))
  95             :test 'string=))
  96
  97
  98
  99
 100
 101 (define-special %call-property (object property &rest args)
 102   ;; (%call-property object property args) -> value
 103   ;;(format t "call property ~s . ~s ( ~s ) ~%" (first cdr) (second cdr) (third cdr))
 104   `(,@(scompile object) ;; find the object
 105       ,@(loop for i in args
 106            append (scompile i)) ;; calculate args
 107       (:call-property ,property ,(length args)))) ;; call it
 108
 109
 110 (define-special %get-property (object property-name)
 111   ;; (%get-property object property) -> value
 112   ;;(format t "get property ~s . ~s ~%" (first cdr) (second cdr))
 113   `(,@(scompile object) ;; find the object
 114       ;; fixme: look up properties for real?
 115       (:get-property ,property-name)))
 116
 117 (define-special %call-property-without-object (property &rest args)
 118   ;; (%call-property-without-object property args) -> value
 119   ;;(format t "call property without object * . ~s ( ~s ) ~%" property args)
 120   `((:find-property-strict ,property) ;; find obj with prop
 121     ,@(loop for i in args
 122          append (scompile i)) ;; calculate args
 123     (:call-property ,property ,(length args)))) ;; call it
 124
 125
 126
 127 ;;; not sure if these are needed or not, or if api is right, just
 128 ;;; copied from old code
 129 (define-special %set-property (object property value)
 130   ;; (%set-property object property value) -> value
 131   ;;(format t "set property ~s . ~s = ~s ~%" (first cdr) (second cdr) (third cdr))
 132   `(,@(scompile value) ;; calculate value
 133       (:dup) ;; leave a copy on stack so we can return it
 134       ,@(scompile object) ;; find the object
 135       (:swap)                   ;; stack => return-value object value
 136       (:set-property ,(or (find-swf-property property) property))))
 137
 138 ;; used by stuff like Math.random(), etc
 139 (define-special %call-lex-prop (object-name property &rest args)
 140   ;; fixme: better name for this?
 141   ;; (%call-lex-prop object-name property args) -> value
 142   ;;(format t "call proplex ~s . ~s ( ~s ) ~%" (first cdr) (second cdr) (third cdr))
 143   `((:get-lex ,(if (find-swf-class object-name)
 144                    (swf-name (find-swf-class object-name))
 145                    object-name)) ;; find the object
 146     ,@(loop for i in args
 147          append (scompile i)) ;; calculate args
 148     (:call-property ,property ,(length args))))
 149
 150 #+nil
 151 (define-special %get-lex (name)
 152   ;; (%get-lex object-name ) -> value
 153   `((:get-lex ,name)))
 154
 155
 156 #+nil
 157 (print (swf-defmemfun bleh (arg)
 158          (let ((canvas (%asm (:new (qname "flash.display" "Sprite") 0))))
 159            (:add-child arg canvas))
 160          ))
 161
 162 (define-special %new (class arg-count)
 163   (let ((name (typecase class
 164                 (symbol
 165                  (let ((c (find-swf-class class)))
 166                    (assert c) ;; fixme: better error reporting
 167                    (swf-name c)))
 168                 (t class))))
 169     `((:find-property-strict ,name)
 170       (:construct-prop ,name ,arg-count)
 171       #+nil(:coerce ,name)
 172       (:coerce-any))))
 173
 174 ;; (avm2-asm:assemble (scompile '(%new flash.text:Text-Field 0)))
 175 ;; (avm2-asm:assemble (scompile '(%new "flash.text:TextField" 0)))
 176 ;; (avm2-asm:assemble (scompile '(%new "flash.text::TextField" 0)))
 177 ;; (avm2-asm:assemble (scompile '(%new (:qname "flash.text" "TextField") 0)))