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   (write-u30 (as3-asm::name trait))
  88   (write-generic (as3-asm::trait-data trait))
  89   (when (not (zerop (logand #x40 (as3-asm::kind (as3-asm::trait-data trait)))))
  90     (write-counted-sequence 'write-u30 (as3-asm::metadata trait))))
  91
  92 (defmethod write-generic ((td as3-asm::trait-data-slot/const) &optional (*standard-output* *standard-output*))
  93   (write-u8 (as3-asm::kind td))
  94   (write-u30 (as3-asm::slot-id td))
  95   (write-u30 (as3-asm::type-name td))
  96   (write-u30 (as3-asm::vindex td))
  97   (write-u8 (as3-asm::vkind td)))
  98
  99 (defmethod write-generic ((td as3-asm::trait-data-class) &optional (*standard-output* *standard-output*))
 100   (write-u8 (as3-asm::kind td))
 101   (write-u30 (as3-asm::slot-id td))
 102   (write-u30 (as3-asm::classi td)))
 103
 104 (defmethod write-generic ((td as3-asm::trait-data-function) &optional (*standard-output* *standard-output*))
 105   (write-u8 (as3-asm::kind td))
 106   (write-u30 (as3-asm::slot-id td))
 107   (write-u30 (as3-asm::fn td)))
 108
 109 (defmethod write-generic ((td as3-asm::trait-data-method/get/set) &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::method-id td)))
 113
 114
 115 (defun write-namespace (namespace &optional (stream *standard-output*))
 116   "storing namespace_info as (kind name_index) for now "
 117   (write-u8 (first namespace) stream)
 118   (write-u30 (second namespace) stream))
 119
 120 (defun write-namespace-set (namespace-set &optional (stream *standard-output*))
 121   "namespace-set (ns_set_info) = (ns1 ns2 ... nsN)"
 122   (write-u30 (length namespace-set) stream)
 123   (loop for i in namespace-set
 124      do (write-u30 i stream)))
 125
 126 (defun write-multiname (multiname &optional (stream *standard-output*))
 127   "multiname_info = (kind values*) for now, 0-2 values depending on kind"
 128   ;;; TODO: error checking
 129   (let ((kind (first multiname)))
 130     (write-u8 kind stream)
 131     (loop for i in (cdr multiname)
 132        do (write-u30 i stream))))
 133
 134
 135 (defun write-method-info (method-info &optional (*standard-output* *standard-output*))
 136   "u30 param-count, u30 return-type, u30 param-type[param-count], u30 name,
 137  u8 flags, option_info, param-info ==
 138   (name (param types = multinames) return-type flags (option) (param names)"
 139   (destructuring-bind (name param-types return-type flags &optional optional-params pnames)
 140       method-info
 141     (write-u30 (length param-types))
 142     (write-u30 return-type)
 143     (map 'nil 'write-u30 param-types)
 144     (write-u30 name)
 145     (write-u8 flags)
 146     (when optional-params
 147       (write-u30 (length optional-params))
 148       ;; optional-param = (( val . kind )
 149       (map 'nil (lambda (a)
 150                   (write-u30 (car a))
 151                   (write-u8 (cdr a))) optional-params))
 152     (when pnames
 153       (write-u30 (length pnames))
 154       (map 'nil 'write-u30 pnames))))
 155
 156 (defun write-metadata-info (metadata &optional (*standard-output* *standard-output*))
 157   "metadata = (name (item_info ... )), item_info = (key . value)"
 158   (write-u30 (car metadata))
 159   (write-u30 (length (second metadata)))
 160   (map 'nil (lambda (a) (write-u30 (car a))  (write-u30 (cdr a)))
 161        (second metadata)))
 162
 163 (defun write-instance (instance &optional (*standard-output* *standard-output*))
 164   (destructuring-bind
 165         (name super-name flags interfaces iinit traits
 166               &optional protected-ns) instance
 167     (format *trace-output* "write instance ~s~%  ~s ~s ~s ~s ~s ~s ~s~% ~s~%"
 168             instance
 169             name super-name flags interfaces iinit traits protected-ns
 170             (assoc iinit (function-names *compiler-context*) :test 'equal))
 171     (write-u30 name)
 172     (write-u30 super-name)
 173     (write-u8 flags)
 174     (when (not (zerop (logand flags as3-asm::+class-protected-ns+)))
 175       (write-u30 protected-ns))
 176     (write-counted-sequence 'write-u30 interfaces)
 177     (write-u30 iinit)
 178     (write-counted-sequence 'write-generic traits)))
 179
 180 (defun write-class (class &optional (*standard-output* *standard-output*))
 181   " class = (cinit trait1 trait2 ... traitN)"
 182   (format *trace-output* "write class ~s~%  ~s~%  ~S~%"
 183           class
 184           (assoc (car class) (function-names *compiler-context*) :test 'equal)
 185           (cdr class))
 186   (write-u30 (car class))
 187   (write-counted-sequence 'write-generic (cdr class)))
 188
 189
 190
 191 (defun write-script (script &optional (*standard-output* *standard-output*))
 192   " script = (init trait1 trait2 ... traitN)"
 193   (write-u30 (car script))
 194   (write-counted-sequence 'write-generic (cdr script)))
 195
 196 (defun write-method-body (method-body &optional (*standard-output* *standard-output*))
 197   (write-u30 (as3-asm::method-id method-body))
 198   (write-u30 (as3-asm::max-stack method-body))
 199   (write-u30 (1+ (as3-asm::local-count method-body)))
 200   (write-u30 (as3-asm::init-scope-depth method-body))
 201   (write-u30 (as3-asm::max-scope-depth method-body))
 202   (write-counted-sequence 'write-u8 (as3-asm::code method-body))
 203   (write-counted-sequence 'write-generic (as3-asm::exceptions method-body))
 204   (write-counted-sequence 'write-generic (as3-asm::traits method-body)))
 205
 206 (defmethod write-generic ((ei as3-asm::exception-info) &optional (*standard-output* *standard-output*))
 207   (write-u30 (as3-asm::from ei))
 208   (write-u30 (as3-asm::to ei))
 209   (write-u30 (as3-asm::target ei))
 210   (write-u30 (as3-asm::exc-type ei))
 211   (write-u30 (as3-asm::var-name ei)))
 212
 213
 214
 215 (defun write-abc-file (&optional (data as3-asm::*assembler-context*) (*standard-output* *standard-output*))
 216   (with-accessors
 217         ((ints as3-asm::ints) (uints as3-asm::uints) (doubles as3-asm::doubles)
 218          (strings as3-asm::strings) (namespaces as3-asm::namespaces)
 219          (ns-sets as3-asm::ns-sets) (multinames as3-asm::multinames)
 220          (method-infos as3-asm::method-infos) (metadata as3-asm::metadata)
 221          (classes as3-asm::classes) (instances as3-asm::instances)
 222          (scripts as3-asm::scripts) (method-bodies as3-asm::method-bodies))
 223       data
 224
 225     (write-u16 16) ;minor version
 226     (write-u16 46) ;major version
 227     ;; constant pool
 228     (write-counted-sequence 'write-s32 ints :start 1)
 229     (write-counted-sequence 'write-u32 uints :start 1)
 230     (write-counted-sequence 'write-double doubles :start 1)
 231     (write-counted-sequence 'write-string-info strings :start 1)
 232     (write-counted-sequence 'write-namespace namespaces :start 1)
 233     (write-counted-sequence 'write-namespace-set ns-sets :start 1)
 234     (write-counted-sequence 'write-multiname multinames :start 1)
 235     ;; methods, etc
 236     (write-counted-sequence 'write-method-info method-infos)
 237     (write-counted-sequence 'write-metadata-info metadata)
 238     (write-counted-sequence 'write-instance instances)
 239     ;; classes and instances share the same length field
 240     (map 'nil 'write-class classes)
 241     (write-counted-sequence 'write-script scripts)
 242     (write-counted-sequence 'write-method-body method-bodies)))
 243
 244 (defun write-as3-tag (as3 tag-name &optional (*standard-output* *standard-output*))
 245   ;; always use the long form for size for now...
 246   (let ((size-pos (file-position *standard-output*)) start)
 247     ;; (write-u16 (logior (ash #x48 6) 63)) ;; was #x48, (x52?)
 248     ;; tag DoABC = 82
 249     (write-u16 (logior (ash #x52 6) 63))
 250     (setf size-pos (file-position *standard-output*))
 251     (write-u32-raw 0)    ;; size, to be filled in later
 252     (setf start (file-position *standard-output*))
 253     ;; flags 1 = lazy initialize
 254     (write-sequence '(01 00 00 00) *standard-output*)
 255     ;; tag name
 256     (write-0-terminated-string tag-name *standard-output*)
 257     ;; write the abc data
 258     (write-abc-file as3)
 259     ;; fill in the tag size
 260     (let* ((here (file-position *standard-output*))
 261            (length (- here start)))
 262       (file-position *standard-output* size-pos)
 263       (write-u32-raw (+ length  ))
 264       (file-position *standard-output* here))))
 265
 266 (defmacro write-tag ((tag stream) &body body)
 267   ;; fixme: handle short tags more efficiently
 268   (let ((start (gensym))
 269         (end (gensym)))
 270     `(let ((,start (file-position ,stream)))
 271        (write-u16 (logior (ash ,tag 6) 63) ,stream)
 272        (setf ,start (file-position ,stream))
 273        (write-u32-raw 0 ,stream)    ;; size, to be filled in later
 274        ,@body
 275     ;; fill in the tag size
 276     (let* ((,end (file-position ,stream)))
 277       (file-position ,stream ,start)
 278       (write-u32-raw  (- ,end ,start 4) ,stream)
 279       (file-position ,stream ,end)))))
 280
 281
 282 (defun write-swf (stream frame-label symbol-classes)
 283   ;;; write out a minimal .swf, based on the stuff hxasm writes
 284   (write-sequence '(#x46 #x57 #x53 #x09) stream) ;;magic "FWS9"
 285   ;;  (write-u32-raw (+ #x17 6 (length as3) (if (>= (length as3) 63) 6 2)) stream)
 286   ;; file length (filled in later)
 287   (write-u32-raw 0 stream)
 288   ;; 8000x6000 twips = 400x300 pels
 289   (write-sequence '(#x78 #x00 #x03 #xe8 #x00 #x00 #x0b #xb8 #x00) stream)
 290   (write-u16 #x1e00 stream) ;; 30fps
 291   (write-u16 #x0001 stream) ;; 1 frame
 292
 293   ;; FileAttributes tag
 294   (write-u16 (logior (ash #x45 6) 4) stream) ;; type=69 + length=4
 295   (write-u8 #b00011001 stream) ;; flags: reserved=000, HasMetadata=1,AS3=1,res=00, UseNetwork=1
 296   (write-u8 0 stream) ;;reserved
 297   (write-u8 0 stream) ;;reserved
 298   (write-u8 0 stream) ;;reserved
 299
 300   ;; Script Limits tag type=65, length = 4
 301   (write-sequence '(#x44 #x10 #xe8 #x03 #x3c #x00) stream) ;; script limits? stack 1000, time 60
 302
 303   ;; SetBackgroundColor tag type=9, length=3 color=#x869ca7
 304   (write-sequence '(#x43 #x02      #x86 #x9c #xa7 ) stream) ;; bg color?
 305   ;; FrameLabel tag type=43, length=4
 306   ;; (write-sequence '(#xc4 #x0a #x66 #x6f #x6f 00) stream) ;; frame label
 307   (write-tag (43 stream)
 308     (write-0-terminated-string frame-label stream))
 309
 310   ;; AS3 tag
 311   (write-as3-tag as3-asm::*assembler-context* "frame" stream)
 312   ;; SymbolClass tag, tag=76 length=8
 313   ;;(write-u16 #x1308 stream) ;;tag+length
 314   ;;   NumSymbols=#x0001 Tag[1] = #x0000 Name[1]="foo"#x0
 315   ;;  (write-sequence '(#x01 00 00 00 #x66 #x6f #x6f 00) stream)
 316   (write-tag (76 stream)
 317     (write-u16 (length symbol-classes) stream) ;; # of symbols
 318     (loop for i in symbol-classes
 319          do
 320          (write-u16 (first i) stream) ;; tag
 321          (write-0-terminated-string (second i) stream))) ;; name
 322
 323   ;; ShowFrame tag type=1, length=0
 324   (write-u16 (logior (ash #x01 6) 0) stream) ;; show frame tag
 325   ;; End tag type=1, length=0
 326   (write-u16 (logior (ash #x00 6) 0) stream) ;; end tag
 327   ;; fill in the file size
 328   (file-position stream 4)
 329   (write-u32-raw (file-length stream) stream)
 330 )
 331
 332
 333 ;;; fixme: deal with package stuff, possibly reorganize stuff between asm/compiler...
 334
 335 (defun super-names (name)
 336   (let ((s (assoc name *flash-player-classes* :test 'string=)))
 337     (if s
 338         (cons (second s) (super-names (second s)))
 339         s)))
 340
 341 (defun push-lex-scope (mn-index)
 342   `((:get-lex ,(if (integerp mn-index) `(:id ,mn-index)mn-index))
 343     (:push-scope)))
 344
 345 (defun new-class+scopes (class-id)
 346   ;; fixme: allow class lookup instead of using class-id directly?
 347   (format t "cid = ~a classes=~s~%" class-id (as3-asm::classes as3-asm::*assembler-context*))
 348   (format t " instances = ~s~%" (as3-asm::instances as3-asm::*assembler-context*))
 349   (let* ((class (aref (as3-asm::classes as3-asm::*assembler-context*) class-id))
 350          (inst (aref (as3-asm::instances as3-asm::*assembler-context*) class-id)))
 351     (declare (ignorable class))
 352     (destructuring-bind (name-mn super-mn flags interfaces instance-init traits protected-ns)
 353         inst
 354       (declare (ignorable name-mn super-mn flags interfaces instance-init traits protected-ns))
 355       (format t "cid = ~a name-mn = ~a=~a  super-mn = ~a=~a ~%"
 356               class-id name-mn (as3-asm::qname-string name-mn)
 357               super-mn (as3-asm::qname-string super-mn))
 358       ;;(format t " supers = ~s~%" (reverse (super-names (as3-asm::qname-string super-mn))))
 359       (let ((supers (reverse (super-names (as3-asm::qname-string super-mn)))))
 360         `((:get-scope-object 0)
 361           ,@(loop for i in supers
 362                append (push-lex-scope i))
 363           ,@(push-lex-scope super-mn)
 364           (:get-lex (:id ,super-mn))
 365           (:new-class ,class-id)
 366           ,@(loop repeat (1+ (length supers))
 367                collect `(:pop-scope))
 368           (:init-property (:id ,name-mn)))))))
 369
 370
 371 (defun assemble-function (name)
 372   (format t "--assemble-function ~s :~%" name)
 373   (destructuring-bind (n nid argtypes return-type flags asm)
 374       (find-swf-function name)
 375     (let ((mid (as3-asm::as3-method nid argtypes return-type flags
 376                                     :body (as3-asm::assemble-method-body asm))))
 377       (push (list n mid) (function-names *compiler-context*)))))
 378
 379 (defparameter *break-compile* nil)
 380 ;;; quick hack for testing, need to write a proper API at some point, which
 381 ;;;  compiles functions from a list of packages or whatever
 382 (defmacro with-compilation-to-stream (s (frame-name exports) &body body)
 383   (let ((script-init (gensym))
 384         (i (gensym)))
 385
 386     `(let ((as3-asm::*assembler-context* (make-instance 'as3-asm::assembler-context))
 387            (*compiler-context* (make-instance 'compiler-context))
 388            (*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table*))))
 389        ;; fixme: add these to assembler-context constructor or something
 390        (as3-asm::as3-intern "")
 391        (as3-asm::as3-ns-intern "")
 392        ,@body
 393        (loop for k being the hash-keys of (functions *cl-symbol-table*)
 394           do (assemble-function k))
 395        (loop for k being the hash-keys of (functions *symbol-table*)
 396           do (assemble-function k))
 397
 398        (let ((,script-init
 399               (as3-asm::as3-method
 400                0 () 0 0
 401                :body
 402                (as3-asm::assemble-method-body
 403                 `((:get-local-0)
 404                   (:push-scope)
 405                   ,@(loop for ,i below (length (as3-asm::classes as3-asm::*assembler-context*))
 406                        append (new-class+scopes ,i))
 407                   (:return-void))))))
 408          (vector-push-extend
 409           `(,,script-init
 410             ,@(loop for i in (class-names *compiler-context*)
 411                  collect (make-instance 'as3-asm::trait-info 'as3-asm::name (as3-asm::qname "" (first i))
 412                                         'as3-asm::trait-data (make-instance 'as3-asm::trait-data-class
 413                                                                             'as3-asm::slot-id 0
 414                                                                             'as3-asm::classi (second i))))
 415             ,@(loop for i in (function-names *compiler-context*)
 416                  do (format t "-=-~s~%" i)
 417                  collect (make-instance 'as3-asm::trait-info
 418                                         'as3-asm::name
 419                                         (if (numberp (first i))
 420                                             (first i)
 421                                             (as3-asm::asm-intern-multiname (first i)))
 422                                         'as3-asm::trait-data (make-instance 'as3-asm::trait-data-method/get/set
 423                                                                             'as3-asm::slot-id 0
 424                                                                             'as3-asm::method (second i)))))
 425           (as3-asm::scripts as3-asm::*assembler-context*)))
 426        (when *break-compile* (break))
 427        (write-swf ,s ,frame-name ,exports))))