file/write.lisp

   1 (in-package :avm2-compiler)
   2
   3 ;;; code to write out abc tag/hard coded simple .swf file to seekable
   4 ;;; stream or file
   5
   6
   7 ;; todo: range checks
   8
   9 ;;;;;;;;;;;;;;;;;;;;;
  10 ;;; low level writers
  11
  12 (defun write-u8 (byte &optional (stream *standard-output*))
  13   (write-byte byte stream))
  14
  15 (defun write-u16 (integer &optional (stream *standard-output*))
  16   (write-byte (ldb (byte 8 0) integer) stream)
  17   (write-byte (ldb (byte 8 8) integer) stream))
  18
  19 (defun write-u24 (integer &optional (stream *standard-output*))
  20   (write-byte (ldb (byte 8 0) integer) stream)
  21   (write-byte (ldb (byte 8 8) integer) stream)
  22   (write-byte (ldb (byte 8 16) integer) stream))
  23
  24 (defun write-u32-raw (integer &optional (stream *standard-output*))
  25   (write-byte (ldb (byte 8 0) integer) stream)
  26   (write-byte (ldb (byte 8 8) integer) stream)
  27   (write-byte (ldb (byte 8 16) integer) stream)
  28   (write-byte (ldb (byte 8 24) integer) stream))
  29
  30 ;;; fixme: this is probably overly complicated, and encodes things inefficiently
  31 ;;; - the spec says variable length encoded s32 are sign extended, so we
  32 ;;; should need an extra byte if the high bit of the encoded value
  33 ;;; doesn't match the sign. The actual vm seems to not sign extend though,
  34 ;;; and negative s32 are always written with a full 32 bits, so we could
  35 ;;; encode positive s32 without the extra byte.
  36 ;;; we also use this for unsigned types, so those shouldn't have the extra byte
  37 ;;; either way
  38 (defun write-variable-length-encoded (integer &optional (stream *standard-output*))
  39   (loop
  40      for i = integer then i2
  41      for i2 = (ash i -7)
  42      for b = (ldb (byte 7 0) i)
  43      for done = (or (= i2 0) (= i2 -1))
  44      when (or (not (eql (logbitp 6 i2) (logbitp 6 i))) (not done))
  45      do (setf b (logior #x80 b))
  46      do (write-byte b stream)
  47      when (and done (logbitp 7 b))
  48      do (write-byte (if (minusp i2) #x7f 0) stream)
  49      until done))
  50
  51 (defun write-u30 (integer &optional (stream *standard-output*))
  52   (assert (<= 0 integer (expt 2 30)))
  53   (write-variable-length-encoded integer stream))
  54
  55 (defun write-u32 (integer &optional (stream *standard-output*))
  56   (assert (<= 0 integer (expt 2 32)))
  57   (write-variable-length-encoded integer stream))
  58
  59 (defun write-s32 (integer &optional (stream *standard-output*))
  60   ;; flash 9/mxmlc seems to want negative #s stored as if they were
  61   ;; casted to uints first :/
  62   (assert (<= (abs integer) (expt 2 32)))
  63   (when (< integer 0) (setf integer (+ (expt 2 32) integer)))
  64   (write-variable-length-encoded integer stream))
  65
  66 (defun write-double (float &optional (stream *standard-output*))
  67   (loop with d = (ieee-floats::encode-float64 float)
  68      for i from 0 below 64 by 8
  69      do (write-byte (ldb (byte 8 i) d) stream)))
  70
  71 (defun write-counted-sequence (function seq &key (count-adjust 0) (start 0))
  72   (declare (ignorable start))
  73   ;;(format *error-output* "counted seq ~d (+ ~d ) entries ~a ~%" (length seq) count-adjust function)
  74   (if (<= (length seq) start)
  75       (write-u30 0)
  76       (progn
  77         (write-u30 (+ (length seq) count-adjust))
  78         (loop for i from start below (length seq)
  79            do (funcall function (elt seq i))))))
  80
  81 (defun write-string-info (string &optional (stream *standard-output*))
  82   (let ((utf8 (sb-ext:string-to-octets string :external-format :utf-8)))
  83     (write-u30 (length utf8))
  84     (write-sequence utf8 stream)))
  85
  86 (defun write-0-terminated-string (string &optional (stream *standard-output*))
  87   (let ((utf8 (sb-ext:string-to-octets string :external-format :utf-8)))
  88     (write-sequence utf8 stream)
  89     (write-u8 0 stream)))
  90
  91 ;;;;;;;;;;;;;;;;;;;;;
  92 ;;; writers for asm level data structures
  93
  94 (defgeneric write-generic (data &optional *standard-output*))
  95
  96 (defmethod write-generic ((trait avm2-asm::trait-info) &optional (*standard-output* *standard-output*))
  97   #+nil(format *trace-output* "trait-data : ~s ~s~%"
  98           (avm2-asm::name trait)
  99            (avm2-asm::trait-data trait))
 100   (write-u30 (avm2-asm::name trait))
 101   (write-generic (avm2-asm::trait-data trait))
 102   (when (not (zerop (logand #x40 (avm2-asm::kind (avm2-asm::trait-data trait)))))
 103     (write-counted-sequence 'write-u30 (avm2-asm::metadata trait))))
 104
 105 (defmethod write-generic ((td avm2-asm::trait-data-slot/const) &optional (*standard-output* *standard-output*))
 106   #+nil(format *trace-output* "trait-data-slot/const :~s ~s ~s ~s ~s~%"
 107           (avm2-asm::kind td)
 108           ( avm2-asm::slot-id td)
 109           ( avm2-asm::type-name td)
 110           (avm2-asm::vindex td)
 111           (avm2-asm::vkind td))
 112   (write-u8 (avm2-asm::kind td))
 113   (write-u30 (avm2-asm::slot-id td))
 114   (write-u30 (avm2-asm::type-name td))
 115   (write-u30 (avm2-asm::vindex td))
 116   (unless (zerop (avm2-asm::vindex td))
 117     (write-u8 (avm2-asm::vkind td))))
 118
 119 (defmethod write-generic ((td avm2-asm::trait-data-class) &optional (*standard-output* *standard-output*))
 120   (write-u8 (avm2-asm::kind td))
 121   (write-u30 (avm2-asm::slot-id td))
 122   (write-u30 (avm2-asm::classi td)))
 123
 124 (defmethod write-generic ((td avm2-asm::trait-data-function) &optional (*standard-output* *standard-output*))
 125   (write-u8 (avm2-asm::kind td))
 126   (write-u30 (avm2-asm::slot-id td))
 127   (write-u30 (avm2-asm::fn td)))
 128
 129 (defmethod write-generic ((td avm2-asm::trait-data-method/get/set) &optional (*standard-output* *standard-output*))
 130   (write-u8 (avm2-asm::kind td))
 131   (write-u30 (avm2-asm::slot-id td))
 132   (write-u30 (avm2-asm::method-id td)))
 133
 134
 135 (defun write-namespace (namespace &optional (stream *standard-output*))
 136   "storing namespace_info as (kind name_index) for now "
 137   (write-u8 (first namespace) stream)
 138   (write-u30 (second namespace) stream))
 139
 140 (defun write-namespace-set (namespace-set &optional (stream *standard-output*))
 141   "namespace-set (ns_set_info) = (ns1 ns2 ... nsN)"
 142   (write-u30 (length namespace-set) stream)
 143   (loop for i in namespace-set
 144      do (write-u30 i stream)))
 145
 146 (defun write-multiname (multiname &optional (stream *standard-output*))
 147   "multiname_info = (kind values*) for now, 0-2 values depending on kind"
 148   ;;; TODO: error checking
 149   (let ((kind (first multiname)))
 150     (write-u8 kind stream)
 151     (loop for i in (cdr multiname)
 152        do (write-u30 i stream))))
 153
 154
 155 (defun write-method-info (method-info &optional (*standard-output* *standard-output*))
 156   "u30 param-count, u30 return-type, u30 param-type[param-count], u30 name,
 157  u8 flags, option_info, param-info ==
 158   (name (param types = multinames) return-type flags (option) (param names)"
 159   (destructuring-bind (name param-types return-type flags &optional optional-params pnames)
 160       method-info
 161     (write-u30 (length param-types))
 162     (write-u30 return-type)
 163     (map 'nil 'write-u30 param-types)
 164     (write-u30 name)
 165     (write-u8 flags)
 166     (when optional-params
 167       (write-u30 (length optional-params))
 168       ;; optional-param = (( val . kind )
 169       (map 'nil (lambda (a)
 170                   (write-u30 (car a))
 171                   (write-u8 (cdr a))) optional-params))
 172     (when pnames
 173       (write-u30 (length pnames))
 174       (map 'nil 'write-u30 pnames))))
 175
 176 (defun write-metadata-info (metadata &optional (*standard-output* *standard-output*))
 177   "metadata = (name (item_info ... )), item_info = (key . value)"
 178   (write-u30 (car metadata))
 179   (write-u30 (length (second metadata)))
 180   (map 'nil (lambda (a) (write-u30 (car a))  (write-u30 (cdr a)))
 181        (second metadata)))
 182
 183 (defun write-instance (instance &optional (*standard-output* *standard-output*))
 184   (destructuring-bind
 185         (name super-name flags interfaces iinit traits
 186               &optional protected-ns) instance
 187     #+nil(format *trace-output* "write instance ~s~%  ~s ~s ~s ~s ~s ~s ~s~% ~s~%"
 188             instance
 189             name super-name flags interfaces iinit traits protected-ns
 190             (assoc iinit (function-names *compiler-context*) :test 'equal))
 191     (write-u30 name)
 192     (write-u30 super-name)
 193     (write-u8 flags)
 194     (when (not (zerop (logand flags avm2-asm::+class-protected-ns+)))
 195       (write-u30 protected-ns))
 196     (write-counted-sequence 'write-u30 interfaces)
 197     (write-u30 iinit)
 198     (write-counted-sequence 'write-generic traits)))
 199
 200 (defun write-class (class &optional (*standard-output* *standard-output*))
 201   " class = (cinit trait1 trait2 ... traitN)"
 202   #+nil(format *trace-output* "write class ~s~%  ~s~%  ~S~%"
 203           class
 204           (assoc (car class) (function-names *compiler-context*) :test 'equal)
 205           (cdr class))
 206   (write-u30 (car class))
 207   (write-counted-sequence 'write-generic (cdr class)))
 208
 209
 210
 211 (defun write-script (script &optional (*standard-output* *standard-output*))
 212   " script = (init trait1 trait2 ... traitN)"
 213   (write-u30 (car script))
 214   (write-counted-sequence 'write-generic (cdr script)))
 215
 216 (defun write-method-body (method-body &optional (*standard-output* *standard-output*))
 217   (write-u30 (avm2-asm::method-id method-body))
 218   (write-u30 (avm2-asm::max-stack method-body))
 219   (write-u30 (1+ (avm2-asm::local-count method-body)))
 220   (write-u30 (avm2-asm::init-scope-depth method-body))
 221   (write-u30 (avm2-asm::max-scope-depth method-body))
 222   (write-counted-sequence 'write-u8 (avm2-asm::code method-body))
 223   (write-counted-sequence 'write-generic (avm2-asm::exceptions method-body))
 224   (write-counted-sequence 'write-generic (avm2-asm::traits method-body)))
 225
 226 (defmethod write-generic ((ei avm2-asm::exception-info) &optional (*standard-output* *standard-output*))
 227   (write-u30 (avm2-asm::from ei))
 228   (write-u30 (avm2-asm::to ei))
 229   (write-u30 (avm2-asm::target ei))
 230   (write-u30 (avm2-asm::exc-type ei))
 231   (write-u30 (avm2-asm::var-name ei)))
 232
 233
 234
 235 (defun write-abc-file (&optional (data avm2-asm::*assembler-context*) (*standard-output* *standard-output*))
 236   (with-accessors
 237         ((ints avm2-asm::ints) (uints avm2-asm::uints) (doubles avm2-asm::doubles)
 238          (strings avm2-asm::strings) (namespaces avm2-asm::namespaces)
 239          (ns-sets avm2-asm::ns-sets) (multinames avm2-asm::multinames)
 240          (method-infos avm2-asm::method-infos) (metadata avm2-asm::metadata)
 241          (classes avm2-asm::classes) (instances avm2-asm::instances)
 242          (scripts avm2-asm::scripts) (method-bodies avm2-asm::method-bodies))
 243       data
 244
 245     (write-u16 16) ;minor version
 246     (write-u16 46) ;major version
 247     ;; constant pool
 248     (write-counted-sequence 'write-s32 ints :start 1)
 249     (write-counted-sequence 'write-u32 uints :start 1)
 250     (write-counted-sequence 'write-double doubles :start 1)
 251     (write-counted-sequence 'write-string-info strings :start 1)
 252     (write-counted-sequence 'write-namespace namespaces :start 1)
 253     (write-counted-sequence 'write-namespace-set ns-sets :start 1)
 254     (write-counted-sequence 'write-multiname multinames :start 1)
 255     ;; methods, etc
 256     (write-counted-sequence 'write-method-info method-infos)
 257     (write-counted-sequence 'write-metadata-info metadata)
 258     (write-counted-sequence 'write-instance instances)
 259     ;; classes and instances share the same length field
 260     (map 'nil 'write-class classes)
 261     (write-counted-sequence 'write-script scripts)
 262     (write-counted-sequence 'write-method-body method-bodies)))
 263
 264 (defun write-as3-tag (as3 tag-name &optional (*standard-output* *standard-output*))
 265   ;; always use the long form for size for now...
 266   (let ((size-pos (file-position *standard-output*)) start)
 267     ;; (write-u16 (logior (ash #x48 6) 63)) ;; was #x48, (x52?)
 268     ;; tag DoABC = 82
 269     (write-u16 (logior (ash #x52 6) 63))
 270     (setf size-pos (file-position *standard-output*))
 271     (write-u32-raw 0)    ;; size, to be filled in later
 272     (setf start (file-position *standard-output*))
 273     ;; flags 1 = lazy initialize
 274     (write-sequence '(01 00 00 00) *standard-output*)
 275     ;; tag name
 276     (write-0-terminated-string tag-name *standard-output*)
 277     ;; write the abc data
 278     (write-abc-file as3)
 279     ;; fill in the tag size
 280     (let* ((here (file-position *standard-output*))
 281            (length (- here start)))
 282       (file-position *standard-output* size-pos)
 283       (write-u32-raw (+ length  ))
 284       (file-position *standard-output* here))))
 285
 286 (defmacro write-tag ((tag stream) &body body)
 287   ;; fixme: handle short tags more efficiently
 288   (let ((start (gensym))
 289         (end (gensym)))
 290     `(let ((,start (file-position ,stream)))
 291        (write-u16 (logior (ash ,tag 6) 63) ,stream)
 292        (setf ,start (file-position ,stream))
 293        (write-u32-raw 0 ,stream)    ;; size, to be filled in later
 294        ,@body
 295     ;; fill in the tag size
 296     (let* ((,end (file-position ,stream)))
 297       (file-position ,stream ,start)
 298       (write-u32-raw  (- ,end ,start 4) ,stream)
 299       (file-position ,stream ,end)))))
 300
 301 (defun write-rect (stream x y)
 302   ;;(write-sequence '(#x78 #x00 #x03 #xe8 #x00 #x00 #x0b #xb8 #x00) stream)
 303   ;; we just always use fixed size for now...
 304   (write-sequence
 305    (loop with temp = 16
 306          for val in (list 0 x 0 y) ;; min/max x,y
 307          collect (logior (ash temp 3) (ldb (byte 3 13) val)) into l
 308          collect (ldb (byte 8 5) val) into l
 309          do (setf temp (ldb (byte 5 0) val))
 310          finally (return (append l (list (ash temp 3)))))
 311    stream))
 312
 313
 314 (defun write-swf (stream frame-label symbol-classes &key (flash-version 9) (x-twips 8000) (y-twips 6000))
 315   ;;; write out a minimal .swf, based on the stuff hxasm writes
 316   (write-sequence `(#x46 #x57 #x53 ,flash-version) stream) ;;magic "FWS" + ver
 317   ;;  (write-u32-raw (+ #x17 6 (length as3) (if (>= (length as3) 63) 6 2)) stream)
 318   ;; file length (filled in later)
 319   (write-u32-raw 0 stream)
 320   ;; 8000x6000 twips = 400x300 pels
 321   ;;(write-sequence '(#x78 #x00 #x03 #xe8 #x00 #x00 #x0b #xb8 #x00) stream)
 322   (write-rect stream x-twips y-twips)
 323   (write-u16 #x1e00 stream) ;; 30fps
 324   (write-u16 #x0001 stream) ;; 1 frame
 325
 326   ;; FileAttributes tag
 327   (write-u16 (logior (ash #x45 6) 4) stream) ;; type=69 + length=4
 328   (write-u8 #b00011001 stream) ;; flags: reserved=000, HasMetadata=1,AS3=1,res=00, UseNetwork=1
 329   (write-u8 0 stream) ;;reserved
 330   (write-u8 0 stream) ;;reserved
 331   (write-u8 0 stream) ;;reserved
 332
 333   ;; Script Limits tag type=65, length = 4
 334   (write-sequence '(#x44 #x10 #xe8 #x03 #x3c #x00) stream) ;; script limits? stack 1000, time 60
 335
 336   ;; SetBackgroundColor tag type=9, length=3 color=#x869ca7
 337   (write-sequence '(#x43 #x02      #x86 #x9c #xa7 ) stream) ;; bg color?
 338   ;; FrameLabel tag type=43, length=4
 339   ;; (write-sequence '(#xc4 #x0a #x66 #x6f #x6f 00) stream) ;; frame label
 340   (write-tag (43 stream)
 341     (write-0-terminated-string frame-label stream))
 342
 343   ;; AS3 tag
 344   (write-as3-tag avm2-asm::*assembler-context* "frame" stream)
 345   ;; SymbolClass tag, tag=76 length=8
 346   ;;(write-u16 #x1308 stream) ;;tag+length
 347   ;;   NumSymbols=#x0001 Tag[1] = #x0000 Name[1]="foo"#x0
 348   ;;  (write-sequence '(#x01 00 00 00 #x66 #x6f #x6f 00) stream)
 349   (write-tag (76 stream)
 350     (write-u16 (length symbol-classes) stream) ;; # of symbols
 351     (loop for i in symbol-classes
 352          do
 353          (write-u16 (first i) stream) ;; tag
 354          (write-0-terminated-string (second i) stream))) ;; name
 355
 356   ;; ShowFrame tag type=1, length=0
 357   (write-u16 (logior (ash #x01 6) 0) stream) ;; show frame tag
 358   ;; End tag type=1, length=0
 359   (write-u16 (logior (ash #x00 6) 0) stream) ;; end tag
 360   ;; fill in the file size
 361   (file-position stream 4)
 362   (write-u32-raw (file-length stream) stream)
 363 )
 364
 365
 366 ;;; fixme: deal with package stuff, possibly reorganize stuff between asm/compiler...
 367
 368 (defun super-names (name)
 369   (let ((c (when name (find-swf-class name))))
 370     (when c
 371       (cons (swf-name c) (super-names (extends c))))))
 372
 373 (defun push-lex-scope (mn-index)
 374   `((:get-lex ,(if (integerp mn-index) `(:id ,mn-index)mn-index))
 375     (:push-scope)))
 376
 377 (defun new-class+scopes (class)
 378   ;; fixme: allow class lookup instead of using class-id directly?
 379   (let ((supers (reverse (super-names (extends class)))))
 380     `((:get-scope-object 0)
 381       ,@(loop for i in supers
 382            append (push-lex-scope i))
 383       (:get-lex ,(swf-name (find-swf-class (extends class))))
 384       (:new-class ,(second (assoc (swf-name class) (class-names *compiler-context*))))
 385       ,@(loop repeat  (length supers)
 386            collect `(:pop-scope))
 387       (:init-property  ,(swf-name class)))))
 388
 389
 390 (defun assemble-function (name)
 391   #+nil(format t "--assemble-function ~s :~%" name)
 392   (destructuring-bind (n nid argtypes return-type flags asm)
 393       (find-swf-function name)
 394     (let ((mid (avm2-asm::avm2-method nid argtypes return-type flags
 395                                     :body (avm2-asm::assemble-method-body asm))))
 396       (push (list n mid) (function-names *compiler-context*)))))
 397
 398 (defun assemble-class (name ns super properties constructor)
 399   (let* ((constructor-mid (avm2-asm::avm2-method
 400                            0 ;; name
 401                            (loop for i in (first constructor)
 402                               collect 0) ;; constructor arg types
 403                            0 0
 404                            :body
 405                            (avm2-asm::assemble-method-body
 406                             (%compile-defun name (first constructor)
 407                                             (second constructor) t t))))
 408          ;; fixme: probably should make this configurable at some point
 409          (class-init (avm2-asm::avm2-method 0 nil 0 0 ;; meta-class init
 410                                           :body
 411                                           (avm2-asm::assemble-method-body
 412                                            `((:get-local-0)
 413                                              (:push-scope)
 414                                              (:return-void))
 415                                            :init-scope 0)))
 416          (junk (avm2-asm::avm2-ns-intern ns))
 417          (class (avm2-asm::avm2-class
 418                  (avm2-asm::asm-intern-multiname name)
 419                  (avm2-asm::asm-intern-multiname
 420                   (or (swf-name (find-swf-class super))
 421                       super))
 422                  ;; todo: add interfaces
 423                  09 nil ;; flags, interfaces
 424                  constructor-mid
 425                  (loop for i in properties
 426                     collect
 427                       (make-instance
 428                        'avm2-asm::trait-info
 429                        'avm2-asm::name (avm2-asm::asm-intern-multiname i)
 430                        'avm2-asm::trait-data
 431                        (make-instance 'avm2-asm::trait-data-slot/const
 432                                                     'avm2-asm::kind 0
 433                                                     'avm2-asm::slot-id 0 ;; auto-assign
 434                                                     'avm2-asm::type-name 0 ;; */t
 435                                                     'avm2-asm::vindex 0 ;; no value
 436                                                     'avm2-asm::vkind 0 ;; no value
 437                                                     )))
 438                  class-init
 439                  :protected-ns junk
 440                  ;; todo: class traits
 441                  ;; :class-traits nil
 442                  )))
 443     (push (list name class) (class-names *compiler-context*))))
 444
 445 (defparameter *break-compile* nil)
 446 ;;(setf *break-compile* t)
 447 ;;; quick hack for testing, need to write a proper API at some point, which
 448 ;;;  compiles functions from a list of packages or whatever
 449 (defmacro with-compilation-to-stream (s (frame-name exports &key (swf-version 9) (x-twips 8000) (y-twips 6000)) &body body)
 450   (let ((script-init (gensym))
 451         (script-init-scope-setup (gensym)))
 452
 453     `(let ((avm2-asm::*assembler-context* (make-instance 'avm2-asm::assembler-context))
 454            (*compiler-context* (make-instance 'compiler-context))
 455            (*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table*)))
 456            (,script-init-scope-setup nil))
 457        ;; fixme: add these to assembler-context constructor or something
 458        (avm2-asm::avm2-intern "")
 459        (avm2-asm::avm2-ns-intern "")
 460        #+nil(format t "==-== body~%")
 461        ;; compile the body code
 462        ,@body
 463        #+nil(format t "==-== classes~%")
 464        ;; assemble classes
 465        (loop for symbol-table in (list *cl-symbol-table* *symbol-table*)
 466           do (loop for k being the hash-keys of (classes symbol-table)
 467                 using (hash-value v)
 468                 do
 469                   (with-accessors ((swf-name swf-name) (ns ns)
 470                                    (extends extends) (properties properties)
 471                                    (constructor constructor)) v
 472                     (when (or properties constructor)
 473                       #+nil(format t "name=~s extends = ~s, find=~s sn=~s~%" swf-name
 474                               extends (find-swf-class extends)
 475                               (swf-name (find-swf-class extends))
 476                               )
 477                       (assemble-class swf-name ns
 478                                       extends
 479                                       properties constructor)))
 480                   (setf ,script-init-scope-setup
 481                         (append ,script-init-scope-setup (new-class+scopes v)))))
 482        #+nil(format t "==-== functions~%")
 483        ;; assemble functions
 484        (loop for k being the hash-keys of (functions *cl-symbol-table*)
 485           do (assemble-function k))
 486        (loop for k being the hash-keys of (functions *symbol-table*)
 487           do (assemble-function k))
 488        #+nil(format t "==-== boilerplate~%")
 489        ;; script boilerplate
 490        (let ((,script-init
 491               (avm2-asm::avm2-method
 492                0 () 0 0
 493                :body
 494                (avm2-asm::assemble-method-body
 495                 `((:get-local-0)
 496                   (:push-scope)
 497                   ,@,script-init-scope-setup
 498                   (:return-void))))))
 499          #+nil(format t "==-== boilerplate2~%")
 500          (vector-push-extend
 501           `(,,script-init
 502             ,@(loop for i in (class-names *compiler-context*)
 503                  ;;do (format t "-=c-~s~%" i)
 504                  collect (make-instance 'avm2-asm::trait-info
 505                                         'avm2-asm::name
 506                                         (avm2-asm::asm-intern-multiname (first i))
 507                                         'avm2-asm::trait-data
 508                                         (make-instance 'avm2-asm::trait-data-class
 509                                                        'avm2-asm::slot-id 0
 510                                                        'avm2-asm::classi (second i))))
 511             ,@(loop for i in (function-names *compiler-context*)
 512                  ;;do (format t "-=f-~s~%" i)
 513                  collect (make-instance 'avm2-asm::trait-info
 514                                         'avm2-asm::name
 515                                         (if (numberp (first i))
 516                                             (first i)
 517                                             (avm2-asm::asm-intern-multiname (first i)))
 518                                         'avm2-asm::trait-data (make-instance 'avm2-asm::trait-data-method/get/set
 519                                                                             'avm2-asm::slot-id 0
 520                                                                             'avm2-asm::method (second i)))))
 521           (avm2-asm::scripts avm2-asm::*assembler-context*)))
 522
 523        (when *break-compile* (break))
 524        #+nil(format t "==-== write~%")
 525        ;; write out the .swf
 526        (write-swf ,s ,frame-name ,exports :flash-version ,swf-version :x-twips ,x-twips :y-twips ,y-twips))))