asm/context.lisp

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