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
  37
  38 (defparameter *assembler-context* (make-instance 'assembler-context))
  39 (defparameter *empty-sym* (make-instance 'avm2sym 'string-id 1 'namespace-id 1
  40                                          'method-id 1 'class-id 1))
  41 (defun avm2-intern (string-designator)
  42   (let ((string (and string-designator (string string-designator))))
  43     (if (or (not string) #+()(string= string ""))
  44         *empty-sym*
  45         (let ((i (gethash string (string-intern-hash *assembler-context*)))
  46               (j (length (strings *assembler-context*))))
  47           (if i
  48               (progn
  49                 ;;(format t "used interned string ~a = ~d ~%" string i)
  50                 i)
  51               (progn
  52                 ;;(format t "interning ~a = ~d ~%" string j)
  53                 (vector-push-extend string (strings *assembler-context*))
  54                 (setf (gethash string (string-intern-hash *assembler-context*))
  55                       (make-instance 'avm2sym 'string-id j))))))))
  56 (defun avm2-string (s)
  57   (string-id (avm2-intern s)))
  58
  59 (defun avm2-intern-int (int)
  60   ;;fixme: write a real version of this
  61   ;;(format t "intern int ~a ~%" int)
  62   (loop with a = (ints *assembler-context*)
  63      for i from 1 below (length a)
  64      when (= int (aref a i))
  65      return i
  66      finally (return (prog1
  67                          (length a)
  68                        (vector-push-extend int a)))))
  69
  70 (defun avm2-intern-uint (int)
  71   ;;fixme: write a real version of this
  72   (loop with a = (uints *assembler-context*)
  73      for i from 1 below (length a)
  74      when (= int (aref a i))
  75      return i
  76      finally (return (prog1
  77                          (length a)
  78                        (vector-push-extend int a)))))
  79
  80 (defun avm2-intern-double (double)
  81   ;;fixme: write a real version of this
  82   (loop with a = (doubles *assembler-context*)
  83      with d = (float double 1d0)
  84      for i from 1 below (length a)
  85      when (= d (aref a i))
  86      return i
  87      finally (return (prog1
  88                          (length a)
  89                        (vector-push-extend d a)))))
  90
  91
  92 ;;;;;; namespace.kind values
  93 (defparameter +namespace+           #x08)
  94 (defparameter +package-namespace+   #x16)
  95 (defparameter +package-internal-ns+ #x17)
  96 (defparameter +protected-namespace+ #x18)
  97 (defparameter +explicit-namespace+  #x19)
  98 (defparameter +static-protected-ns+ #x1a)
  99 (defparameter +private-ns+          #x05)
 100
 101 (defun avm2-ns-intern (string-designator &key (kind +package-namespace+))
 102   (let ((sym (avm2-intern string-designator)))
 103     (if (namespace-id sym)
 104         (namespace-id sym)
 105         (prog1
 106             (setf (namespace-id sym) (length (namespaces *assembler-context*)))
 107           (vector-push-extend (list kind (string-id sym))
 108                               (namespaces *assembler-context*))))))
 109
 110 (defun avm2-ns-set-intern (namespaces)
 111   (let* ((ns-ids (loop for i in namespaces
 112                      when (numberp i)
 113                      collect i
 114                      else
 115                      collect (avm2-ns-intern i)))
 116          (id (gethash ns-ids (ns-set-hash *assembler-context*))))
 117     (if id
 118         id
 119         (prog1
 120           (setf (gethash ns-ids (ns-set-hash *assembler-context*))
 121                 (length (ns-sets *assembler-context*)))
 122           (vector-push-extend ns-ids (ns-sets *assembler-context*))))))
 123
 124
 125 ;;; multiname.kind values
 126 (defparameter +qname+        #x07)
 127 (defparameter +qname-a+      #x0d)
 128 (defparameter +rt-qname+     #x0f)
 129 (defparameter +rt-qname-a+   #x10)
 130 (defparameter +rt-qname-l+   #x11)
 131 (defparameter +rt-qname-la+  #x12)
 132 (defparameter +multiname+    #x09)
 133 (defparameter +multiname-a+  #x0e)
 134 (defparameter +multiname-l+  #x1b)
 135 (defparameter +multiname-la+ #x1c)
 136
 137 (defun intern-multiname (kind ns name)
 138   (let* ((ns (avm2-ns-intern ns))
 139          (name (avm2-string name))
 140          (mn (list kind ns name))
 141          (id (gethash mn (multiname-hash *assembler-context*))))
 142     (if id
 143         id
 144         (progn
 145           (vector-push-extend mn (multinames *assembler-context*))
 146           (setf (gethash mn (multiname-hash *assembler-context*))
 147                 (1- (length (multinames *assembler-context*))))))))
 148
 149 (defun intern-multiname-l (kind &rest ns-list)
 150   (let* ((ns-set (avm2-ns-set-intern ns-list))
 151          (mn (list kind ns-set))
 152          (id (gethash mn (multiname-hash *assembler-context*))))
 153     (if id
 154         id
 155         (progn
 156           (vector-push-extend mn (multinames *assembler-context*))
 157           (setf (gethash mn (multiname-hash *assembler-context*))
 158                 (1- (length (multinames *assembler-context*))))))))
 159
 160 (defun qname (ns name)
 161   (intern-multiname +qname+ ns name))
 162
 163
 164 (defun parsed-qname (name)
 165   (let ((p (position #\: name :test 'char=)))
 166     (if p
 167         (qname (subseq name 0 p) (subseq name (position #\: name :start p :test-not 'char=)))
 168         (qname "" name))))
 169
 170 ;;; instance_info.flags values
 171
 172 (defparameter +class-sealed+       #x01)
 173 (defparameter +class-final+        #x02)
 174 (defparameter +class-interface+    #x04)
 175 (defparameter +class-protected-ns+ #x08)
 176
 177
 178 ;;; fixme: probably should make an effort to avoid duplicates or something?
 179 (defun avm2-class (name-mn super-mn flags interfaces instance-init traits class-init &key protected-ns class-traits )
 180   (let ((class-id (length (classes *assembler-context*))))
 181     (vector-push-extend (list name-mn super-mn flags interfaces
 182                               instance-init traits protected-ns)
 183                         (instances *assembler-context*))
 184     (vector-push-extend (cons class-init class-traits)
 185                         (classes *assembler-context*))
 186     class-id))
 187
 188 (defun avm2-method (name param-types return-type flags &key option-params pnames body)
 189   (let ((method-id (length (method-infos *assembler-context*))))
 190     (when body (setf flags (logior flags (flags body))))
 191     (vector-push-extend (list name param-types return-type flags option-params pnames)
 192                         (method-infos *assembler-context*))
 193     (setf (method-id body) method-id)
 194     (vector-push-extend body (method-bodies *assembler-context*))
 195     method-id))
 196
 197
 198 (defclass trait-info ()
 199   ((name :initarg name :accessor name)
 200    (trait-data :initarg trait-data :accessor trait-data)
 201    (metadata :initarg metadata :accessor metadata)))
 202
 203 (defclass trait-data-slot/const ()
 204   ((kind :initform 0 :initarg kind :accessor kind) ;; 0 or 6
 205    (slot-id :initarg slot-id :accessor slot-id)
 206    (type-name :initarg type-name :accessor type-name)
 207    (vindex :initarg vindex :accessor vindex)
 208    (vkind :initarg vkind :accessor vkind)))
 209
 210 (defclass trait-data-class ()
 211   ((kind :initform 4 :initarg kind :accessor kind)
 212    (slot-id :initarg slot-id :accessor slot-id)
 213    (classi :initarg classi :accessor classi)))
 214
 215
 216 (defclass trait-data-function ()
 217   ((kind :initform 5 :initarg kind :accessor kind)
 218    (slot-id :initarg slot-id :accessor slot-id)
 219    (fn :initarg function :accessor fn)))
 220
 221
 222 (defclass trait-data-method/get/set ()
 223   ((kind :initform 1 :initarg kind :accessor kind) ;;1 2 3
 224    (slot-id :initarg slot-id :accessor slot-id)
 225    (method-id :initarg method :accessor method-id)))
 226
 227
 228 (defclass exception-info ()
 229   ((from :initarg from :accessor from)
 230    (to :initarg to :accessor to)
 231    (target :initarg target :accessor target)
 232    (exc-type :initarg exc-type :accessor exc-type)
 233    (var-name :initarg var-name :accessor var-name)))
 234
 235
 236 (defun qname-string (mn-id)
 237   (let* ((mn (aref (multinames *assembler-context*) mn-id))
 238          (ns (second mn))
 239          (name (third mn)))
 240     (setf name (if name (aref (strings *assembler-context*) name) ""))
 241     (setf ns (if ns
 242                  (aref (strings *assembler-context*)
 243                        (second (aref (namespaces *assembler-context*) ns)))
 244                  ""))
 245     (if (string= ns "")
 246         name
 247         (format nil "~a:~a" ns name ))))
 248
 249 #+(or)(let ((*assembler-context* (make-instance 'assembler-context)))
 250       (qname "baz baz"  "bleh")
 251       (format t "~s ~%" (multinames *assembler-context*))
 252       (format t "--~a =  ~a ~%" (qname "foo" "bar")
 253               (qname-string (qname "foo" "bar")))
 254       (loop for i from 0
 255          for j across (multinames *assembler-context*)
 256          do (format t " mn ~a = ~a ~%" i j))
 257
 258       (loop for i from 0
 259          for j across (strings *assembler-context*)
 260          do (format t " string ~a = ~a ~%" i j))
 261
 262       (loop for i from 0
 263          for j across (namespaces *assembler-context*)
 264          do (format t " ns ~a = ~a ~%" i j))
 265
 266       (format t "--~a =  ~a ~%" (qname "" "bar") (qname-string (qname "" "bar"))))
 267
 268
 269
 270
 271