file/write.lisp

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