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 (define-special %call-property (object property &rest args)
 100   ;; (%call-property object property args) -> value
 101   ;;(format t "call property ~s . ~s ( ~s ) ~%" (first cdr) (second cdr) (third cdr))
 102   `(,@(scompile object) ;; find the object
 103       ,@(loop for i in args
 104            append (scompile i)) ;; calculate args
 105       (:call-property ,property ,(length args)))) ;; call it
 106
 107
 108 (define-special %get-property (object property-name)
 109   ;; (%get-property object property) -> value
 110   ;;(format t "get property ~s . ~s ~%" (first cdr) (second cdr))
 111   `(,@(scompile object) ;; find the object
 112       ;; fixme: look up properties for real?
 113       (:get-property ,property-name)))
 114
 115 (define-special %call-property-without-object (property &rest args)
 116   ;; (%call-property-without-object property args) -> value
 117   ;;(format t "call property without object * . ~s ( ~s ) ~%" property args)
 118   `((:find-property-strict ,property) ;; find obj with prop
 119     ,@(loop for i in args
 120          append (scompile i)) ;; calculate args
 121     (:call-property ,property ,(length args)))) ;; call it
 122
 123 (define-special %get-property-without-object (property)
 124   `((:find-property-strict ,property)
 125     (:get-property ,property)))
 126
 127
 128
 129 ;;; not sure if these are needed or not, or if api is right, just
 130 ;;; copied from old code
 131 (define-special %set-property (object property value)
 132   ;; (%set-property object property value) -> value
 133   ;;(format t "set property ~s . ~s = ~s ~%" (first cdr) (second cdr) (third cdr))
 134   `(,@(scompile value) ;; calculate value
 135       (:dup) ;; leave a copy on stack so we can return it
 136       ,@(scompile object) ;; find the object
 137       (:swap)                   ;; stack => return-value object value
 138       (:set-property ,(or (find-swf-property property) property))))
 139
 140 ;; used by stuff like Math.random(), etc
 141 (define-special %call-lex-prop (object-name property &rest args)
 142   ;; fixme: better name for this?
 143   ;; (%call-lex-prop object-name property args) -> value
 144   ;;(format t "call proplex ~s . ~s ( ~s ) ~%" (first cdr) (second cdr) (third cdr))
 145   `((:get-lex ,(if (find-swf-class object-name)
 146                    (swf-name (find-swf-class object-name))
 147                    object-name)) ;; find the object
 148     ,@(loop for i in args
 149          append (scompile i)) ;; calculate args
 150     (:call-property ,property ,(length args))))
 151
 152 ;; used by stuff like Math.random(), etc
 153 (define-special %get-lex-prop (object-name property)
 154   ;; fixme: better name for this?
 155   `((:get-lex ,(if (find-swf-class object-name)
 156                    (swf-name (find-swf-class object-name))
 157                    object-name)) ;; find the object
 158     (:get-property ,(if (find-swf-class property)
 159                    (swf-name (find-swf-class property))
 160                    property))))
 161
 162
 163 #+nil
 164 (define-special %get-lex (name)
 165   ;; (%get-lex object-name ) -> value
 166   `((:get-lex ,name)))
 167
 168
 169 #+nil
 170 (print (swf-defmemfun bleh (arg)
 171          (let ((canvas (%asm (:new (qname "flash.display" "Sprite") 0))))
 172            (:add-child arg canvas))
 173          ))
 174
 175 (define-special %new (class arg-count)
 176   (let ((name (typecase class
 177                 (symbol
 178                  (let ((c (find-swf-class class)))
 179                    (assert c) ;; fixme: better error reporting
 180                    (swf-name c)))
 181                 (t class))))
 182     `((:find-property-strict ,name)
 183       (:construct-prop ,name ,arg-count)
 184       #+nil(:coerce ,name)
 185       (:coerce-any))))
 186
 187 ;; (avm2-asm:assemble (scompile '(%new flash.text:Text-Field 0)))
 188 ;; (avm2-asm:assemble (scompile '(%new "flash.text:TextField" 0)))
 189 ;; (avm2-asm:assemble (scompile '(%new "flash.text::TextField" 0)))
 190 ;; (avm2-asm:assemble (scompile '(%new (:qname "flash.text" "TextField") 0)))