lib/wrap-lib.lisp

   1 ;;; util to convert playerglobal.extracted.lisp into more useful format
   2 ;;;
   3
   4 (error "run this stuff by hand...")
   5
   6 ;; format notes:
   7 ;;   set default float format to double
   8 ;;   need to recognize:
   9 ;;      Infinity, -Infinity, NaN, undefined
  10
  11 ;; top level forms: :class :interface :constant :method
  12
  13 ;; (:class name &key extends implements public final dynamic properties)
  14 ;; :interface = :class
  15 ;; (:method  name arg-list return-type &key namespace-type static final native uri override)
  16 ;; (:constant &key name type value static namespace-type)
  17
  18 ;; forms valid in properties field of class:
  19 ;;   :constant :method = same as top level
  20 ;;   :method-get, :method-set = same as :method
  21 ;;   :constructor = same as :method ?
  22 ;;   :variable = same as :constant
  23
  24 ;; namespace-types = :private, :public, :internal, :static.protected
  25
  26 ;;; to generate:
  27 ;;  export list (library-packages.lisp)
  28 ;;  class hierarchy? (player-classes.lisp)
  29 ;;  wrappers (player-lib.lisp, player-class-decl.lisp)
  30
  31
  32 ;;;;;;;;;;;;;;;;;;;
  33 (defparameter *odd* nil)
  34 (let ((cl-ppcre:*regex-char-code-limit* 256))
  35   (defparameter *scanners*
  36     (loop for i in  '("^I([A-Z][a-z])" ":I([A-Z][a-z])" ;; interfaces
  37
  38                       ;;; special cases that shuoldn't match the acronym stuff
  39                       ;; possibly should just not use the XML to -xml
  40                       ;; stil regexes on names that only have
  41                       ;; uppercase letters, so we don't need to
  42                       ;; special case the words with which they conflict?
  43                       "CAPTURING_PHASE" "TIMER" "SECURITY" "COMPOSITION"
  44                       "ACTIONSCRIPT" "SHADER" "WIDE" "DIVIDE" "PROPORTIONAL"
  45                       "WIDTH" "IDEOGRAPHIC" "INVALID" "VALID" "PRIORITIZE"
  46                       "INSTRUCTION" "DECLARATION" "QUATERNION" "CONNECTIONS"
  47                       ;;; handle upper case acronyms/abbreviations in
  48                       ;;; CamelCase identifiers
  49                       "XML" "URI" "NaN" "URL" "CSM" "SQL" "AVM1"
  50                       "SWF" "EOF" "IO" "DRM" "HTML" "HTTP" "IME"
  51                       "PDF" "ID3" "ID" "OLAP" "HLOC" "AIR" "RSL"
  52                       "UI" "JPEG" "PNG" "AMF" "SOAP" "MXML" "WSDL"
  53                       "CSS" "SHA" "UID" "UTF" "TLS" "UTC" "FPS"
  54                       ;;; special cases
  55                       "QName" "3DTo" "IBEAM" "CFFHinting"
  56                       "SQRT1_2" "RETURNINDEXEDARRAY" "UNIQUESORT"
  57                       "CASEINSENSITIVE" "ThreeDTranslationHandlePoints"
  58                       "scale9Grid"
  59                       )
  60        collect (cl-ppcre:create-scanner i)))
  61   (defun lispify-name (n)
  62     (setf n (or n ""))
  63     (loop for i in *scanners*
  64        for j in '( "i-\\1" ":i-\\1"
  65
  66                   "capturing-phase" "timer" "security" "composition"
  67                   "actionscript" "shader" "wide" "divide" "proportional"
  68                   "width" "ideographic" "invalid" "valid" "prioritize"
  69                   "instruction" "declaration" "quaternion" "connections"
  70
  71                   "-xml" "-uri" "-nan" "-url" "-csm" "-sql" "-avm1"
  72                   "-swf" "-eof" "-io" "-drm" "-html" "-http" "-ime"
  73                   "-pdf" "-id3" "-id" "-olap" "-hloc" "-air" "-rsl"
  74                   "-ui" "-jpeg" "-png" "-amf" "-soap" "-mxml" "-wsdl"
  75                   "-css" "-sha" "-uid" "-utf" "-tls"  "-utc" "-fps"
  76
  77                   "Q-name" "3d-to" "i-beam" "cff-hinting"
  78                   "sqrt-1/2" "return-indexed-array" "unique-sort"
  79                   "case-insensitive" "three-d-translation-handle-points"
  80                   "scale-9-grid")
  81        do (setf n (cl-ppcre:regex-replace-all i n j)))
  82     (coerce (loop
  83                for last = nil then i
  84                for i across (string n)
  85                if (char= i #\_)
  86                do (setf i #\-)
  87                if (and last (lower-case-p last) (upper-case-p i))
  88                collect #\-
  89                if (or last (not (char= i #\-)))
  90                collect (char-downcase i)
  91                when (and last (upper-case-p last) (upper-case-p i))
  92                do (push n *odd*))
  93             'string)))
  94
  95
  96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97
  98 (defparameter *symbols* (make-hash-table :test 'equal))
  99 (defparameter *public-symbols* (make-hash-table :test 'equal))
 100 (defparameter *class-forms* nil)
 101 (defparameter *top-level-method-forms* nil)
 102 (defparameter *top-level-constant-forms* nil)
 103 (defparameter *current-class* nil)
 104
 105 (defun add-% (name)
 106   (if (char= (char (string name) 0) #\%)
 107       name
 108       (format nil "%~a" name)))
 109
 110 (defclass class-junk ()
 111   ((methods :initform nil :accessor methods)
 112    (constants :initform nil :accessor constants)
 113    (variables :initform nil :accessor variables)))
 114
 115 (defparameter *current-namespace* "%flash")
 116
 117 (defun add-name (name &key ns-type ((:ns *current-namespace*) *current-namespace*))
 118   (unless *current-namespace* (break))
 119   (let ((sep "::"))
 120     (pushnew name (gethash *current-namespace* *symbols* nil) :test 'equal)
 121     (unless (member ns-type '(:private :public :internal :static.protected nil))
 122       (format t "unknown namespace type ~s~%" ns-type))
 123     (unless (member ns-type '(:private :internal :static-protected))
 124       (setf sep ":")
 125       (pushnew name (gethash *current-namespace* *public-symbols* nil) :test 'equal))
 126     (concatenate 'string *current-namespace* sep name)))
 127
 128 (defun parse-class-name (name)
 129   (let* ((name-start (position #\: name :from-end t :test 'char=))
 130          (package-start (when name-start (position #\: name :from-end t :end (- name-start 2)))))
 131     ;; name package qualifier
 132     (values (subseq name (1+ (or name-start -1)))
 133             (when name-start
 134               (subseq name (1+ (or package-start -1)) (1- name-start)))
 135             (when package-start (subseq name 0 (1- package-start))))))
 136
 137
 138 (defun mangle (name &key constantp)
 139   (if constantp
 140       (format nil "+~a+" (lispify-name name))
 141       (lispify-name name)))
 142
 143 (defun mangle-type-name (name)
 144   (multiple-value-bind (class-name ns qualifier)
 145       (parse-class-name name)
 146     (declare (ignore qualifier))
 147     (if ns
 148         (format nil "%~a:~a" ns (mangle class-name))
 149         (format nil "%flash:~a" (mangle class-name)))))
 150
 151 (defun parse-constant (tag &key name type value static namespace-type top-level)
 152   (unless (member namespace-type '(:private :internal :static-protected))
 153     (let ((lisp-name (add-name (mangle name :constantp (eq tag :constant))
 154                                :ns-type namespace-type)))
 155       (if top-level
 156           ;; top-level= (def lisp-sym swf-name type
 157           (push (format nil "(swf-ffi-defconstant ~a ~s ~s)" lisp-name name type) *top-level-constant-forms*)
 158           ;; inside a class
 159           (if (eq tag :constant)
 160               (push (format nil "(~a :swf-name ~s :type ~s :value ~s)" lisp-name name type value)
 161                     (constants *current-class*))
 162               (push (format nil "(~a :swf-name ~s :type ~s :value ~s :static ~s)" lisp-name name type value static)
 163                     (variables *current-class*)))))))
 164
 165 (defun parse-class (type name &key extends implements public final dynamic properties)
 166   (multiple-value-bind (class-name ns qualifier)
 167       (parse-class-name name)
 168     (declare (ignore qualifier))
 169     (let* ((*current-namespace* (add-% (or ns *current-namespace*)))
 170            (lisp-name (add-name (mangle class-name)))
 171            (*current-class* (make-instance 'class-junk)))
 172       (loop for form in properties
 173          do
 174          (ecase (car form)
 175            (:constant (apply 'parse-constant form))
 176            (:variable (apply 'parse-constant form))
 177            (:method (apply 'parse-method  (append form `(:class ,lisp-name))))
 178            (:method-get (apply 'parse-method (append form `(:class ,lisp-name))))
 179            (:method-set (apply 'parse-method (append form `(:class ,lisp-name))))
 180            (:constructor (apply 'parse-method (append form `(:class ,lisp-name))))))
 181       (push
 182        (format nil "(let ((*symbol-table* *player-symbol-table*))
 183   (declare-swf-class ~a (~a)
 184     :swf-name ~s
 185     :constants
 186     (~{~a~^~%     ~})
 187     :properties
 188     (~{~a~^~%     ~})
 189     :methods
 190     (~{~a~^~%     ~})))~%"
 191                lisp-name (if extends (mangle-type-name extends) "")
 192                name
 193                (constants *current-class*)
 194                (variables *current-class*)
 195                (methods *current-class*)
 196                )
 197        *class-forms*)
 198       )))
 199
 200 (defun parse-method (type name arg-list return-type &key namespace-type static final native uri override top-level class)
 201   (declare (ignorable namespace-type final native override))
 202   (unless (member namespace-type '(:private :internal :static-protected))
 203     (let* ((lisp-name (add-name (mangle name) :ns-type namespace-type :ns (add-% (or uri *current-namespace*))))
 204            (static-or-global (or top-level static (member type '(:constructor :function))))
 205            (top-wrapper-macro (if static-or-global
 206                                   (if class
 207                                       "swf-ffi-defun-lex"
 208                                       "swf-ffi-defun-find-prop-strict")
 209                                   "swf-ffi-defmethod")))
 210       (if static-or-global
 211           ;; top-level/static = "(def sym swf-name args return)"
 212           (push
 213            (format nil "(~a ~a ~s~%    ~s ~s~a)"
 214                    top-wrapper-macro lisp-name
 215                    (if uri (format nil "~a:~a" uri name) name)
 216                    arg-list return-type
 217                    (if class (format nil " :class ~a" class) ""))
 218            *top-level-method-forms*)
 219           ;; inside class (but not static)
 220           (if (member type '(:method-get :method-set))
 221               ;; ** get/set look like variables to callers
 222               ;; fixme: don't add twice when we have get and set, and handle type better
 223               (push (format nil "(~a :swf-name ~s :type ~s :static ~s)" lisp-name name return-type static)
 224                     (variables *current-class*))
 225               ;; normal methods
 226               (push
 227                (format nil "(~a :swf-name ~s :return-type ~s~%        :args ~s)" lisp-name name
 228                        return-type arg-list)
 229                (methods *current-class*)))
 230           ))))
 231
 232 (defun parse-form (form)
 233   (ecase (car form)
 234     (:constant (apply 'parse-constant (append form '(:top-level t))))
 235     (:class (apply 'parse-class form))
 236     (:interface (apply 'parse-class form))
 237     (:method (apply 'parse-method (append form '(:top-level t)) ))))
 238
 239 #+nil
 240 (let ((*symbols* (make-hash-table :test 'equal))
 241       (*public-symbols* (make-hash-table :test 'equal))
 242       (*current-namespace* "%flash")
 243       (*class-forms* nil)
 244       (*top-level-method-forms* nil)
 245       (*top-level-constant-forms* nil))
 246   ;; read the data
 247   (add-name "void")
 248   (add-name "*")
 249   (with-open-file (s "lib/playerglobal.extracted.lisp")
 250     (loop with eof = (gensym)
 251        for form = (let ((*read-default-float-format* 'double-float))
 252                     (read s nil eof))
 253        until (eq form eof)
 254        do (parse-form form)))
 255   ;; write the defpackage forms
 256   (with-open-file (ffi-packages "lib/player-ffi-packages.lisp" :direction :output :if-exists :supersede)
 257     (format ffi-packages ";;; --generated file, do not edit--~%~%")
 258     (format ffi-packages "(in-package :avm2-compiler)~%")
 259     (loop
 260        for k being the hash-keys of *public-symbols* using (hash-value v)
 261        do (format ffi-packages "(defpackage #:~a~%  (:export~{~%    #:~a~}))~%~%" k v)))
 262   ;; write the ffi wrappers
 263   (with-open-file (ffi-defs "lib/player-ffi-defs.lisp" :direction :output :if-exists :supersede)
 264     (format ffi-defs ";;; --generated file, do not edit--~%~%")
 265     (format ffi-defs "(in-package :avm2-compiler)~%")
 266     (format ffi-defs "(clrhash (functions *player-symbol-table*))~%")
 267     (format ffi-defs "(clrhash (variables *player-symbol-table*))~%")
 268     (format ffi-defs "(clrhash (properties *player-symbol-table*))~%")
 269     (format ffi-defs "(clrhash (constants *player-symbol-table*))~%")
 270     (format ffi-defs "(clrhash (class-methods *player-symbol-table*))~%")
 271     (format ffi-defs "(clrhash (class-static-methods *player-symbol-table*))~%")
 272     (format ffi-defs "(clrhash (classes *player-symbol-table*))~%~%")
 273     (format ffi-defs "(let ((*symbol-table* *player-symbol-table*))~%")
 274     (loop for i in (reverse *top-level-constant-forms*)
 275        do (format ffi-defs "  ~a~%" i))
 276     ;; we don't wrap the entire file in 1 let, since that makes it
 277     ;; take much longer to compile on some implementations
 278     (format ffi-defs ")~%~%")
 279     (loop for i in (reverse *top-level-method-forms*)
 280        do (format ffi-defs "(let ((*symbol-table* *player-symbol-table*))~%  ~a)~%~%" i))
 281     (loop for i in (reverse *class-forms*)
 282        do (format ffi-defs "~a" i))
 283
 284     ))