asm/context.lisp

   1 (in-package :avm2-asm)
   2
   3
   4 (defclass avm2sym ()
   5   ((string-id :initform nil :initarg string-id :accessor string-id)
   6    (namespace-id :initform nil :initarg namespace-id :accessor namespace-id)
   7    (method-id :initform nil :initarg method-id :accessor method-id)
   8    (class-id :initform nil :initarg class-id :accessor class-id)))
   9
  10 (defclass assembler-context ()
  11   ;; avm2 constant pools are 1 based, so we start them at 1 here, and
  12   ;; skip the first entry on write
  13   ((ints :initform (make-array 32 :fill-pointer 1 :adjustable t) :reader ints)
  14    (uints :initform (make-array 32 :fill-pointer 1 :adjustable t) :reader uints)
  15    (doubles :initform (make-array 32 :fill-pointer 1 :adjustable t) :reader doubles)
  16    (strings :initform (make-array 32 :fill-pointer 1 :adjustable t) :reader strings)
  17    (namespaces :initform (make-array 32 :fill-pointer 1 :adjustable t) :reader namespaces)
  18    (ns-sets :initform (make-array 32 :fill-pointer 1 :adjustable t) :reader ns-sets)
  19    (multinames :initform (make-array 32 :fill-pointer 1 :adjustable t) :reader multinames)
  20    ;;;
  21    (method-infos :initform (make-array 32 :fill-pointer 0 :adjustable t) :reader method-infos)
  22    (metadata :initform (make-array 32 :fill-pointer 0 :adjustable t) :reader metadata)
  23    ;; possibly should store classes and instances together, or
  24    ;; otherwise enforce them being the same length...
  25    (classes :initform (make-array 32 :fill-pointer 0 :adjustable t) :reader classes)
  26    (instances :initform (make-array 32 :fill-pointer 0 :adjustable t) :reader instances)
  27    (scripts :initform (make-array 32 :fill-pointer 0 :adjustable t) :reader scripts)
  28    (method-bodies :initform (make-array 32 :fill-pointer 0 :adjustable t) :reader method-bodies)
  29
  30    ;; strings seem immutable, so combining all string literals
  31
  32    ;; probably should eventually do this for all constants
  33    (string-intern-hash :initform (make-hash-table :test 'equal) :reader string-intern-hash)
  34    (multiname-hash :initform (make-hash-table :test 'equalp) :reader multiname-hash)
  35    (ns-set-hash :initform (make-hash-table :test 'equalp) :reader ns-set-hash)
  36    ;; we need to put method indices directly into code for
  37    ;; closures/anonymous lambdas, and eventually for implementing load
  38    ;; time part of defun, so store a symbol->index mapping here, and allocate
  39    ;; a blank method_info on demand (for usage site or definition)
  40    (method-id-hash :initform (make-hash-table) :reader method-id-hash)))
  41
  42
  43 (defparameter *assembler-context* (make-instance 'assembler-context))
  44 (defparameter *empty-sym* (make-instance 'avm2sym 'string-id 1 'namespace-id 1
  45                                          'method-id 1 'class-id 1))
  46 (defun avm2-intern (string-designator)
  47   (let ((string (and string-designator (string string-designator))))
  48     (if (or (not string) #+()(string= string ""))
  49         *empty-sym*
  50         (let ((i (gethash string (string-intern-hash *assembler-context*)))
  51               (j (length (strings *assembler-context*))))
  52           (if i
  53               (progn
  54                 ;;(format t "used interned string ~a = ~d ~%" string i)
  55                 i)
  56               (progn
  57                 ;;(format t "interning ~a = ~d ~%" string j)
  58                 (vector-push-extend string (strings *assembler-context*))
  59                 (setf (gethash string (string-intern-hash *assembler-context*))
  60                       (make-instance 'avm2sym 'string-id j))))))))
  61 (defun avm2-string (s)
  62   (string-id (avm2-intern s)))
  63
  64 (defun avm2-intern-int (int)
  65   ;;fixme: write a real version of this
  66   ;;(format t "intern int ~a ~%" int)
  67   (loop with a = (ints *assembler-context*)
  68      for i from 1 below (length a)
  69      when (= int (aref a i))
  70      return i
  71      finally (return (prog1
  72                          (length a)
  73                        (vector-push-extend int a)))))
  74
  75 (defun avm2-intern-uint (int)
  76   ;;fixme: write a real version of this
  77   (loop with a = (uints *assembler-context*)
  78      for i from 1 below (length a)
  79      when (= int (aref a i))
  80      return i
  81      finally (return (prog1
  82                          (length a)
  83                        (vector-push-extend int a)))))
  84
  85 (defun avm2-intern-double (double)
  86   ;;fixme: write a real version of this
  87   (loop with a = (doubles *assembler-context*)
  88      with d = (float double 1d0)
  89      for i from 1 below (length a)
  90      when (= d (aref a i))
  91      return i
  92      finally (return (prog1
  93                          (length a)
  94                        (vector-push-extend d a)))))
  95
  96
  97 ;;;;;; namespace.kind values
  98 (defparameter +namespace+           #x08)
  99 (defparameter +package-namespace+   #x16)
 100 (defparameter +package-internal-ns+ #x17)
 101 (defparameter +protected-namespace+ #x18)
 102 (defparameter +explicit-namespace+  #x19)
 103 (defparameter +static-protected-ns+ #x1a)
 104 (defparameter +private-ns+          #x05)
 105
 106 (defun avm2-ns-intern (string-designator &key (kind +package-namespace+))
 107   (let ((sym (avm2-intern string-designator)))
 108     (if (namespace-id sym)
 109         (namespace-id sym)
 110         (prog1
 111             (setf (namespace-id sym) (length (namespaces *assembler-context*)))
 112           (vector-push-extend (list kind (string-id sym))
 113                               (namespaces *assembler-context*))))))
 114
 115 (defun avm2-ns-set-intern (namespaces)
 116   (let* ((ns-ids (loop for i in namespaces
 117                      when (numberp i)
 118                      collect i
 119                      else
 120                      collect (avm2-ns-intern i)))
 121          (id (gethash ns-ids (ns-set-hash *assembler-context*))))
 122     (if id
 123         id
 124         (prog1
 125           (setf (gethash ns-ids (ns-set-hash *assembler-context*))
 126                 (length (ns-sets *assembler-context*)))
 127           (vector-push-extend ns-ids (ns-sets *assembler-context*))))))
 128
 129
 130 ;;; multiname.kind values
 131 (defparameter +qname+        #x07)
 132 (defparameter +qname-a+      #x0d)
 133 (defparameter +rt-qname+     #x0f)
 134 (defparameter +rt-qname-a+   #x10)
 135 (defparameter +rt-qname-l+   #x11)
 136 (defparameter +rt-qname-la+  #x12)
 137 (defparameter +multiname+    #x09)
 138 (defparameter +multiname-a+  #x0e)
 139 (defparameter +multiname-l+  #x1b)
 140 (defparameter +multiname-la+ #x1c)
 141
 142 (defun intern-multiname (kind ns name)
 143   (let* ((ns (avm2-ns-intern ns))
 144          (name (avm2-string name))
 145          (mn (list kind ns name))
 146          (id (gethash mn (multiname-hash *assembler-context*))))
 147     (if id
 148         id
 149         (progn
 150           (vector-push-extend mn (multinames *assembler-context*))
 151           (setf (gethash mn (multiname-hash *assembler-context*))
 152                 (1- (length (multinames *assembler-context*))))))))
 153
 154 (defun intern-multiname-l (kind &rest ns-list)
 155   (let* ((ns-set (avm2-ns-set-intern ns-list))
 156          (mn (list kind ns-set))
 157          (id (gethash mn (multiname-hash *assembler-context*))))
 158     (if id
 159         id
 160         (progn
 161           (vector-push-extend mn (multinames *assembler-context*))
 162           (setf (gethash mn (multiname-hash *assembler-context*))
 163                 (1- (length (multinames *assembler-context*))))))))
 164
 165 (defun qname (ns name)
 166   (intern-multiname +qname+ ns name))
 167
 168
 169 (defun parsed-qname (name)
 170   (let ((p (position #\: name :test 'char=)))
 171     (if p
 172         (qname (subseq name 0 p) (subseq name (position #\: name :start p :test-not 'char=)))
 173         (qname "" name))))
 174
 175 ;;; instance_info.flags values
 176
 177 (defparameter +class-sealed+       #x01)
 178 (defparameter +class-final+        #x02)
 179 (defparameter +class-interface+    #x04)
 180 (defparameter +class-protected-ns+ #x08)
 181
 182
 183 ;;; fixme: probably should make an effort to avoid duplicates or something?
 184 (defun avm2-class (name-mn super-mn flags interfaces instance-init traits class-init &key protected-ns class-traits )
 185   (let ((class-id (length (classes *assembler-context*))))
 186     (vector-push-extend (list name-mn super-mn flags interfaces
 187                               instance-init traits protected-ns)
 188                         (instances *assembler-context*))
 189     (vector-push-extend (cons class-init class-traits)
 190                         (classes *assembler-context*))
 191     class-id))
 192
 193
 194 (defun intern-method-id (id)
 195   ;; id might be function name, or gensym for anonymous lambdas
 196   (let* ((index (gethash id (method-id-hash *assembler-context*))))
 197     (if index
 198         index
 199         (progn
 200           (vector-push-extend nil (method-infos *assembler-context*))
 201           (setf (gethash id (method-id-hash *assembler-context*))
 202                 (1- (length (method-infos *assembler-context*))))))))
 203
 204 (defun avm2-method (label name param-types return-type flags &key option-params pnames body)
 205   ;; name is mn-pool-id for the name in the method_info struct
 206   ;; label is a symbol identifying the method so its ID can be looked up
 207   ;;   to compile into other functions, and isn't intended to appear in
 208   ;;   the .swf anywhere
 209   ;; (label can be NIL to generate a name automatically if no other
 210   ;;  refs are needed aside from caller)
 211   (let* ((label (or label (gensym)))
 212          (method-id (intern-method-id label)))
 213     (when body (setf flags (logior flags (flags body))))
 214     ;;; todo: handle multiple method definitions better (or decide if it needs handled at all)
 215     (assert (null (aref (method-infos *assembler-context*) method-id))
 216             () "duplicate method for ~s (~s)?" name label)
 217     (setf (aref (method-infos *assembler-context*) method-id)
 218           (list name
 219                 (mapcar 'asm-intern-multiname param-types)
 220                 (asm-intern-multiname return-type)
 221                 flags option-params pnames))
 222     (setf (method-id body) method-id)
 223     (vector-push-extend body (method-bodies *assembler-context*))
 224     method-id))
 225
 226
 227 (defclass trait-info ()
 228   ((name :initarg name :accessor name)
 229    (trait-data :initarg trait-data :accessor trait-data)
 230    (metadata :initarg metadata :accessor metadata)))
 231
 232 (defclass trait-data-slot/const ()
 233   ((kind :initform 0 :initarg kind :accessor kind) ;; 0 or 6
 234    (slot-id :initarg slot-id :accessor slot-id)
 235    (type-name :initarg type-name :accessor type-name)
 236    (vindex :initarg vindex :accessor vindex)
 237    (vkind :initarg vkind :accessor vkind)))
 238
 239 (defclass trait-data-class ()
 240   ((kind :initform 4 :initarg kind :accessor kind)
 241    (slot-id :initarg slot-id :accessor slot-id)
 242    (classi :initarg classi :accessor classi)))
 243
 244
 245 (defclass trait-data-function ()
 246   ((kind :initform 5 :initarg kind :accessor kind)
 247    (slot-id :initarg slot-id :accessor slot-id)
 248    (fn :initarg function :accessor fn)))
 249
 250
 251 (defclass trait-data-method/get/set ()
 252   ((kind :initform 1 :initarg kind :accessor kind) ;;1 2 3
 253    (slot-id :initarg slot-id :accessor slot-id)
 254    (method-id :initarg method :accessor method-id)))
 255
 256
 257 (defclass exception-info ()
 258   ((from :initarg from :accessor from)
 259    (to :initarg to :accessor to)
 260    (target :initarg target :accessor target)
 261    (exc-type :initarg exc-type :accessor exc-type)
 262    (var-name :initarg var-name :accessor var-name)))
 263
 264
 265 (defun qname-string (mn-id)
 266   (let* ((mn (aref (multinames *assembler-context*) mn-id))
 267          (ns (second mn))
 268          (name (third mn)))
 269     (setf name (if name (aref (strings *assembler-context*) name) ""))
 270     (setf ns (if ns
 271                  (aref (strings *assembler-context*)
 272                        (second (aref (namespaces *assembler-context*) ns)))
 273                  ""))
 274     (if (string= ns "")
 275         name
 276         (format nil "~a:~a" ns name ))))
 277
 278 #+(or)(let ((*assembler-context* (make-instance 'assembler-context)))
 279       (qname "baz baz"  "bleh")
 280       (format t "~s ~%" (multinames *assembler-context*))
 281       (format t "--~a =  ~a ~%" (qname "foo" "bar")
 282               (qname-string (qname "foo" "bar")))
 283       (loop for i from 0
 284          for j across (multinames *assembler-context*)
 285          do (format t " mn ~a = ~a ~%" i j))
 286
 287       (loop for i from 0
 288          for j across (strings *assembler-context*)
 289          do (format t " string ~a = ~a ~%" i j))
 290
 291       (loop for i from 0
 292          for j across (namespaces *assembler-context*)
 293          do (format t " ns ~a = ~a ~%" i j))
 294
 295       (format t "--~a =  ~a ~%" (qname "" "bar") (qname-string (qname "" "bar"))))
 296
 297
 298
 299
 300