From 193b8c01e35b06d3393cc3609bf27be07c147813 Mon Sep 17 00:00:00 2001
From: Bart Botta <00003b@gmail.com>
Date: Mon, 20 Oct 2008 01:16:40 -0500
Subject: [PATCH] stuff for defining avm classes, more
 CL(cons,car,cdr,if,case,typep,nil,etc)

---
 asm/opcodes.lisp           |   2 +-
 compile/as3-compile.asd    |   2 +
 compile/compiler.lisp      |   3 +-
 compile/defun.lisp         |  74 ++++++-----
 compile/ffi.lisp           |   4 +-
 compile/special-forms.lisp |  35 +++++
 compile/swfclass.lisp      |  11 ++
 file/write.lisp            | 100 +++++++++++++--
 lib/cl-conses.lisp         |  46 +++++++
 lib/cl.lisp                |  75 ++++++++++-
 test/roots.lisp            | 314 +++++++++++++++++++++------------------------
 11 files changed, 455 insertions(+), 211 deletions(-)
 create mode 100644 compile/swfclass.lisp
 create mode 100644 lib/cl-conses.lisp
 rewrite test/roots.lisp (93%)

diff --git a/asm/opcodes.lisp b/asm/opcodes.lisp
index 80bf9fa..c168179 100644
--- a/asm/opcodes.lisp
+++ b/asm/opcodes.lisp
@@ -19,7 +19,7 @@ for that here and return count of extra args"
   ;; name   (args)    opcode    pop push   pop-scope push-scope  local  flags
   (:breakpoint ()                      #x01  0 0) ;
   (:nop        ()                      #x02  0 0) ;
-  (:op-throw   ()                      #x03  1 0) ;
+  (:throw      ()                      #x03  1 0) ;
   (:get-super  ((multiname multiname-q30)) #x04  (1+ (runtime-name-count multiname)) 1)
   (:set-super  ((multiname multiname-q30)) #x05  (+ 2 (runtime-name-count multiname)))
   (:dxns       ((string string-u30))    #x06  0 0 0 0 0 +set-dxns+)
diff --git a/compile/as3-compile.asd b/compile/as3-compile.asd
index b4a0ec2..1dfda09 100644
--- a/compile/as3-compile.asd
+++ b/compile/as3-compile.asd
@@ -6,6 +6,8 @@
                         (:file "compiler")
                         (:file "special-forms")
                         (:file "defun")
+                        (:file "swfclass")
+                        (:file "low-level")
                         (:file "math-ops")
                         (:file "ffi")
                         )
diff --git a/compile/compiler.lisp b/compile/compiler.lisp
index 74e4853..0756adf 100644
--- a/compile/compiler.lisp
+++ b/compile/compiler.lisp
@@ -74,7 +74,8 @@
   (:false :push-false)
   (:nan :push-nan)
   (:undefined :push-undefined)
-  (:null :push-null))
+  (:null :push-null)
+  (nil :push-null))
 
 ;;; interface for implementing special forms
 
diff --git a/compile/defun.lisp b/compile/defun.lisp
index 4938ba4..a9f2229 100644
--- a/compile/defun.lisp
+++ b/compile/defun.lisp
@@ -2,40 +2,48 @@
 
 ;;;; defun and similar
 
-(defun %swf-defun (name args body &key method constructor)
+(defun %compile-defun (args body method constructor)
   (let* ((*current-lambda* (make-lambda-context args)))
-    (pushnew
-     ;; function data:
-     ;;  swf name in format suitable for passing to asm (string/'(qname...))
-     ;;  args to as3-method:
-     ;;    name id?
-     ;;    list of arg types (probably all T/* for now)
-     ;;    return type
-     ;;    flags
-     ;;    list of assembly
-     ;;    ?
-     (list
-      (as3-asm::symbol-to-qname-list name)
-      0 ;; name in method struct?
-      (loop for i in args collect 0) ;; arg types, 0 = t/*/any
-      0 0 ;; return type = any, flags = 0
-      (append ;; assembly
-       (if (or method constructor)
-           '((:get-local-0)
-             (:push-scope))
-           nil)
-       (if constructor
-           '((:get-local-0)
-             (:construct-super 0))
-           nil)
-       (if constructor
-           `(,@(scompile `(progn ,@body))
-               ;;(pop)
-               (:return-void))
-           (scompile `(return (progn ,@body))))))
-     (gethash name (functions *symbol-table*) (list))
-     :test 'equal
-     :key 'car)))
+    (append
+     (if (or method constructor)
+         '((:get-local-0)
+           (:push-scope))
+         nil)
+     (if constructor
+         '((:get-local-0)
+           (:construct-super 0))
+         nil)
+     (if constructor
+         `(,@(scompile `(progn ,@body))
+             ;;(pop)
+             (:return-void))
+         (scompile `(return (progn ,@body)))))))
+
+(defun %swf-defun (name args body &key method constructor)
+  ;; was pushnew, but that makes it hard to work on code (since can't
+  ;; redefine things) push isn't quite right either, should replace
+  ;; existing calue or something
+  ;; (or more likely, just not have a list at all?)
+  (push
+   ;; function data:
+   ;;  swf name in format suitable for passing to asm (string/'(qname...))
+   ;;  args to as3-method:
+   ;;    name id?
+   ;;    list of arg types (probably all T/* for now)
+   ;;    return type
+   ;;    flags
+   ;;    list of assembly
+   ;;    ?
+   (list
+    (as3-asm::symbol-to-qname-list name)
+    0                                ;; name in method struct?
+    (loop for i in args collect 0)   ;; arg types, 0 = t/*/any
+    0 0                              ;; return type = any, flags = 0
+    (%compile-defun args body method constructor))
+   (gethash name (functions *symbol-table*) (list))
+   ;;:test 'equal
+   ;;:key 'car
+   ))
 
 ;;(format t "~{~s~%~}" (sixth (find-swf-function 'floor)))
 ;;(format t "~{~s~%~}" (as3-asm::as3-disassemble (as3-asm:assemble (sixth (find-swf-function 'random)))))
diff --git a/compile/ffi.lisp b/compile/ffi.lisp
index bc9d8fc..0aeb6fd 100644
--- a/compile/ffi.lisp
+++ b/compile/ffi.lisp
@@ -13,7 +13,7 @@
      ;; ignoring it...
 
      ;; store class name
-     (setf (gethash ',class-name (classes *symbol-table*)) ,class-swf-name)
+     (setf (gethash ',class-name (classes *symbol-table*)) (list ,class-swf-name))
      ;; store constants
      ,@(loop for i in constants
           collect (destructuring-bind (name &key swf-name type) i
@@ -137,7 +137,7 @@
                 (symbol
                  (let ((c (find-swf-class class)))
                    (assert c) ;; fixme: better error reporting
-                   c))
+                   (car c)))
                 (t class))))
     `((:find-property-strict ,name)
       (:construct-prop ,name ,arg-count)
diff --git a/compile/special-forms.lisp b/compile/special-forms.lisp
index 631ce8b..818f9bb 100644
--- a/compile/special-forms.lisp
+++ b/compile/special-forms.lisp
@@ -182,6 +182,23 @@
           (:coerce-any)
           (:%dlabel ,label2))))
 
+(define-special %if (cond false-test true-branch false-branch)
+  (let (#+nil(true-label (gensym "%IF-TRUE-"))
+        (false-label (gensym "%IF-FALSE-"))
+        (end-label (gensym "%IF-END-")))
+    `(,@(scompile cond)
+        (,false-test ,false-label)
+        ,@(scompile true-branch)
+        (:coerce-any)
+        (:jump ,end-label)
+        (:%dlabel ,false-label)
+        ,@(scompile false-branch)
+        (:coerce-any)
+        (:%dlabel ,end-label))))
+
+(define-special if (cond true-branch false-branch)
+  `(,@(scompile `(%if ,cond :if-false ,true-branch ,false-branch))))
+
 ;; (as3-asm::with-assembler-context (as3-asm::code (as3-asm:assemble-method-body (scompile '(when :true 1)) )))
 
 
@@ -251,3 +268,21 @@
          append (scompile i)) ;; calculate args
       (:new-array ,(length args))))
 
+
+(define-special %error (value)
+  `(,@(scompile value)
+      (:throw)))
+
+#+nil(define-special %typep (object type)
+  `(,@(scompile object)
+      (:is-type ,type)))
+
+(define-special %typep (object type)
+  `(,@(scompile object)
+      (:get-lex ,type)
+      (:is-type-late )))
+
+(define-special %type-of (object)
+  `(,@(scompile object)
+      (:type-of))
+)
\ No newline at end of file
diff --git a/compile/swfclass.lisp b/compile/swfclass.lisp
new file mode 100644
index 0000000..f86d10f
--- /dev/null
+++ b/compile/swfclass.lisp
@@ -0,0 +1,11 @@
+(in-package :as3-compiler)
+
+;;;; code for defining vm level classes
+
+(defmacro def-swf-class (name ns super (&rest properties) ((&rest constructor-args) &body constructor))
+  `(setf (gethash ',name (classes *symbol-table*))
+         (list ',(as3-asm::symbol-to-qname-list name)
+               ',ns
+               ',super
+               ',properties
+               (list ',constructor-args ',constructor))))
diff --git a/file/write.lisp b/file/write.lisp
index a0c2468..7f052d2 100644
--- a/file/write.lisp
+++ b/file/write.lisp
@@ -84,17 +84,27 @@
 
 
 (defmethod write-generic ((trait as3-asm::trait-info) &optional (*standard-output* *standard-output*))
+  (format *trace-output* "trait-data : ~s ~s~%"
+          (as3-asm::name trait)
+           (as3-asm::trait-data trait))
   (write-u30 (as3-asm::name trait))
   (write-generic (as3-asm::trait-data trait))
   (when (not (zerop (logand #x40 (as3-asm::kind (as3-asm::trait-data trait)))))
     (write-counted-sequence 'write-u30 (as3-asm::metadata trait))))
 
 (defmethod write-generic ((td as3-asm::trait-data-slot/const) &optional (*standard-output* *standard-output*))
+  (format *trace-output* "trait-data-slot/const :~s ~s ~s ~s ~s~%"
+          (as3-asm::kind td)
+          ( as3-asm::slot-id td)
+          ( as3-asm::type-name td)
+          (as3-asm::vindex td)
+          (as3-asm::vkind td))
   (write-u8 (as3-asm::kind td))
   (write-u30 (as3-asm::slot-id td))
   (write-u30 (as3-asm::type-name td))
   (write-u30 (as3-asm::vindex td))
-  (write-u8 (as3-asm::vkind td)))
+  (unless (zerop (as3-asm::vindex td)) 
+    (write-u8 (as3-asm::vkind td))))
 
 (defmethod write-generic ((td as3-asm::trait-data-class) &optional (*standard-output* *standard-output*))
   (write-u8 (as3-asm::kind td))
@@ -376,7 +386,56 @@
                                     :body (as3-asm::assemble-method-body asm))))
       (push (list n mid) (function-names *compiler-context*)))))
 
+(defun assemble-class (name ns super properties constructor)
+  (let* ((constructor-mid (as3-asm::as3-method
+                           0 ;; name
+                           (loop for i in (first constructor)
+                              collect 0) ;; constructor arg types
+                           0 0
+                           :body
+                           (as3-asm::assemble-method-body
+                            (%compile-defun (first constructor)
+                                            (second constructor) t t))))
+         ;; fixme: probably should make this configurable at some point
+         (class-init (as3-asm::as3-method 0 nil 0 0 ;; meta-class init
+                                          :body
+                                          (as3-asm::assemble-method-body
+                                           `((:get-local-0)
+                                             (:push-scope)
+                                             (:return-void))
+                                           :init-scope 0)))
+         (junk (as3-asm::as3-ns-intern ns))
+         (bleh ())
+         (class (as3-asm::as3-class
+                 (as3-asm::asm-intern-multiname name)
+                 (as3-asm::asm-intern-multiname
+                  (or (car (find-swf-class super))
+                      super))
+                 ;; todo: add interfaces
+                 09 nil ;; flags, interfaces
+                 constructor-mid
+                 (loop for i in properties
+                    collect
+                      (make-instance
+                       'as3-asm::trait-info
+                       'as3-asm::name (as3-asm::asm-intern-multiname i)
+                       'as3-asm::trait-data
+                       (make-instance 'as3-asm::trait-data-slot/const
+                                                    'as3-asm::kind 0
+                                                    'as3-asm::slot-id 0 ;; auto-assign
+                                                    'as3-asm::type-name 0 ;; */t
+                                                    'as3-asm::vindex 0 ;; no value
+                                                    'as3-asm::vkind 0 ;; no value
+                                                    )))
+                 class-init
+                 :protected-ns junk
+                 ;; todo: class traits
+                 ;; :class-traits nil
+                 )))
+    (push (list name class) (class-names *compiler-context*))))
+
 (defparameter *break-compile* nil)
+;;(setf *break-compile* t)
 ;;; quick hack for testing, need to write a proper API at some point, which
 ;;;  compiles functions from a list of packages or whatever
 (defmacro with-compilation-to-stream (s (frame-name exports) &body body)
@@ -389,12 +448,29 @@
        ;; fixme: add these to assembler-context constructor or something
        (as3-asm::as3-intern "")
        (as3-asm::as3-ns-intern "")
+       (format t "==-== body~%")
+       ;; compile the body code
        ,@body
+       (format t "==-== classes~%")
+       ;; assemble classes
+       (loop for k being the hash-keys of (classes *cl-symbol-table*)
+          using (hash-value v)
+          for (swf-name ns super properties constructor) = v
+          when (or properties constructor)
+          do (assemble-class swf-name ns super properties constructor))
+       (loop for k being the hash-keys of (classes *symbol-table*)
+          using (hash-value v)
+          for (swf-name ns super properties constructor) = v
+          when (or properties constructor)
+          do (assemble-class swf-name ns super properties constructor))
+       (format t "==-== functions~%")
+       ;; assemble functions
        (loop for k being the hash-keys of (functions *cl-symbol-table*)
           do (assemble-function k))
        (loop for k being the hash-keys of (functions *symbol-table*)
           do (assemble-function k))
-
+       (format t "==-== boilerplate~%")
+       ;; script boilerplate
        (let ((,script-init
               (as3-asm::as3-method
                0 () 0 0
@@ -405,15 +481,20 @@
                   ,@(loop for ,i below (length (as3-asm::classes as3-asm::*assembler-context*))
                        append (new-class+scopes ,i))
                   (:return-void))))))
+       (format t "==-== boilerplate2~%")
          (vector-push-extend
           `(,,script-init
             ,@(loop for i in (class-names *compiler-context*)
-                 collect (make-instance 'as3-asm::trait-info 'as3-asm::name (as3-asm::qname "" (first i))
-                                        'as3-asm::trait-data (make-instance 'as3-asm::trait-data-class
-                                                                            'as3-asm::slot-id 0
-                                                                            'as3-asm::classi (second i))))
+                 do (format t "-=c-~s~%" i)
+                 collect (make-instance 'as3-asm::trait-info
+                                        'as3-asm::name
+                                        (as3-asm::asm-intern-multiname (first i))
+                                        'as3-asm::trait-data
+                                        (make-instance 'as3-asm::trait-data-class
+                                                       'as3-asm::slot-id 0
+                                                       'as3-asm::classi (second i))))
             ,@(loop for i in (function-names *compiler-context*)
-                 do (format t "-=-~s~%" i)
+                 do (format t "-=f-~s~%" i)
                  collect (make-instance 'as3-asm::trait-info
                                         'as3-asm::name
                                         (if (numberp (first i))
@@ -423,5 +504,8 @@
                                                                             'as3-asm::slot-id 0
                                                                             'as3-asm::method (second i)))))
           (as3-asm::scripts as3-asm::*assembler-context*)))
+
        (when *break-compile* (break))
-       (write-swf ,s ,frame-name ,exports))))
\ No newline at end of file
+       (format t "==-== write~%")
+       ;; write out the .swf
+       (write-swf ,s ,frame-name ,exports))))
diff --git a/lib/cl-conses.lisp b/lib/cl-conses.lisp
new file mode 100644
index 0000000..b0ece8d
--- /dev/null
+++ b/lib/cl-conses.lisp
@@ -0,0 +1,46 @@
+(in-package #:as3-compiler)
+
+;;; implement functions/macros from CL package
+;;;
+;;; most probably don't match CL semantics very closely yet...
+
+;;; conses dictionary (14.2)
+;;;
+;;; not sure what best internal rep for conses is,
+;;;  could use anonymous object
+;;;  2 element array
+;;;  instances of named class
+;;;  ?
+;;;
+;;;  named class is probably easiest to recognize for type checking
+;;;    so trying that first
+;;;  anon object with car and cdr properties might also be nice, and
+;;;    just allow any object with those to be used as a 'cons', but
+;;;    wouldn't match CL sematics very well
+(let ((*symbol-table* *cl-symbol-table*))
+  ;; todo: probably should figure out how to make this final/sealed/etc.
+  (def-swf-class cons-type "cons" object (%car %cdr)
+                 ((a b)
+                  (%set-property this %car a)
+                  (%set-property this %cdr b)))
+
+  (swf-defmemfun cons (a b)
+    (%asm (:find-property-strict cons-type)
+          (:get-local-1)
+          (:get-local-2)
+          (:construct-prop cons-type 2)))
+
+  (swf-defmemfun car (a)
+    (if (eq a :null)
+        :null
+        (%asm (:get-local-1)
+              (:get-property %car))))
+  (swf-defmemfun cdr (a)
+    (if (eq a :null)
+        :null
+        (if (%typep a cons-type)
+            (%asm (:get-local-1)
+                  (:get-property %cdr))
+            (%error "type-error: unknown type cdr"))))
+
+)
\ No newline at end of file
diff --git a/lib/cl.lisp b/lib/cl.lisp
index defc83e..b06243b 100644
--- a/lib/cl.lisp
+++ b/lib/cl.lisp
@@ -34,4 +34,77 @@
   (swf-defmemfun tan (radians)
     (flash::math.tan radians))
 
-)
\ No newline at end of file
+  (swf-defmemfun eq (a b)
+    (%asm (:get-local-1)
+          (:get-local-2)
+          (:strict-equals)))
+
+  (swf-defmemfun eql (a b)
+    (%asm (:get-local-1)
+          (:get-local-2)
+          (:equals)))
+
+  #+nil  (swf-defmemfun error (datum &rest args) )
+
+  #+nil  (swf-defmemfun typep (object type)
+    (%typep object type))
+
+
+
+;;; from sicl
+
+  (defun proper-list-p (object)
+    (if (null object)
+	t
+	(if (consp object)
+	    (proper-list-p (cdr object))
+	    nil)))
+
+  (defun eql-ify (keys variable)
+    (if (null keys)
+        '()
+        (cons `(eql ,variable ,(car keys))
+              (eql-ify (cdr keys) variable))))
+;;; This function turns a list of CASE clauses into nested IFs.  It
+;;; checks that the list of clauses is a proper list and that each
+;;; clause is also a proper list.  It also checks that, if there is an
+;;; otherwise clause, it is the last one.
+(defun expand-case-clauses (clauses variable)
+  (if (null clauses)
+      'nil
+      (if (not (consp clauses))
+	  (error 'malformed-case-clauses
+		 :clauses clauses)
+	  (let ((clause (car clauses)))
+	    (unless (and (proper-list-p clause)
+			 (not (null clause)))
+	      (error 'malformed-case-clause
+		     :clause clause))
+	    (if (or (eq (car clause) 'otherwise)
+		    (eq (car clause) t))
+		(if (null (cdr clauses))
+		    `(progn ,@(cdr clause))
+		    (error 'otherwise-clause-not-last
+			   :clauses (cdr clauses)))
+		;; it is a normal clause
+		(let ((keys (car clause))
+		      (forms (cdr clause)))
+		  (if (and (atom keys)
+			   (not (null keys)))
+		      `(if (eql ,variable ,keys)
+			   (progn ,@forms)
+			   ,(expand-case-clauses (cdr clauses) variable))
+		      (if (not (proper-list-p keys))
+			  (error 'malformed-keys
+				 :keys keys)
+			  `(if (or ,@(eql-ify keys variable))
+			       (progn ,@forms)
+			       ,(expand-case-clauses (cdr clauses) variable))))))))))
+
+  (swf-defmacro case (keyform &rest clauses)
+    (let ((variable (gensym "CASE-VAR-")))
+      `(let ((,variable ,keyform))
+         ,(expand-case-clauses clauses variable))))
+
+  )
+
diff --git a/test/roots.lisp b/test/roots.lisp
dissimilarity index 93%
index f3720d8..8961886 100644
--- a/test/roots.lisp
+++ b/test/roots.lisp
@@ -1,165 +1,149 @@
-(in-package :as3-compiler)
-;;; sample from old version. works but needs more refactoring
-
-(define-special %to-double (a)
-  `(,@(scompile a)
-    (:convert-double)))
-
-(define-special %to-integer (a)
-  `(,@(scompile a)
-    (:convert-integer)))
-
-(with-open-file (s "/tmp/roots.swf"
-                   :direction :output
-                              :element-type '(unsigned-byte 8)
-                              :if-exists :supersede)
-  (with-compilation-to-stream s ("frame1" `((0 "test-class")))
-    (let*
-        ((constr
-          (as3-asm::as3-method
-           0 NIL 0 0
-           :body
-           (as3-asm::assemble-method-body
-            `((:GET-LOCAL-0)
-              (:PUSH-SCOPE)
-              (:GET-LOCAL-0)
-              (:CONSTRUCT-SUPER 0)
-              (:FIND-PROPERTY-STRICT MAIN)
-              (:GET-LOCAL 0)
-              (:CALL-PROPERTY MAIN 1)
-              (:RETURN-VOID))))
-
-          #+nil(swf-constructor .constr. ()
-            (main this)))
-
-         (cinit (as3-asm::as3-method 0 nil 0 0 ;; meta-class init
-                            :body
-                            (as3-asm::assemble-method-body
-                             `((:get-local-0)
-                               (:push-scope)
-                               (:return-void))
-                             :init-scope 0)))
-         #+nil(cinit (swf-defmemfun .cinit.
-                             `((:get-local-0)
-                               (:push-scope)
-                               (:return-void))))
-
-         (junk (as3-asm::as3-ns-intern "test-class"))
-         (class (as3-asm::as3-class
-                 (as3-asm::qname "" "test-class")
-                 (as3-asm::qname "flash.display" "Sprite")
-                 09 nil
-                 constr #+nil(as3-asm::symbol-to-qname-list '.constr.)
-                 nil
-                 cinit ;;(as3-asm::symbol-to-qname-list '.cinit.)
-                 :protected-ns junk )))
-
-      (push (list "test-class" class) (class-names *compiler-context*))
-
-      (swf-defmemfun random-range (a b)
-        (+ a (floor (random (- b a)))))
-
-      #+nil(swf-defmemfun radians (a)
-        (/ (* a flash::math.PI) 180.0))
-      (swf-defmemfun radians (a)
-        (/ (* a 3.1415926) 180.0))
-
-      (swf-defmemfun i255 (a)
-        (flash::Math.max (flash::Math.min (floor (* a 256)) 255) 0))
-
-      (swf-defmemfun rgb (r g b)
-        (+ (* (i255 r) 65536) (* (i255 g) 256) (i255 b)))
-
-      (swf-defmemfun main (arg)
-        (let ((foo (%new flash.text::Text-Field 0))
-              (canvas (%new flash.display::Sprite 0)))
-          (%set-property foo :auto-size "left")
-          (%set-property foo :text-color (rgb 200 100 100))
-          (%set-property foo :word-wrap :true)
-          (let ((str"abc..." ))
-            (%set-local str (+ str (flash::string.from-char-code 26085)))
-            (%set-local str (+ str (flash::string.from-char-code 26412)))
-            (%set-local str (+ str (flash::string.from-char-code 21566)))
-            (%set-local str (+ str (%get-property str :length )))
-            (dotimes (x 15) (%set-local str (+ str " [" (flash::.char-code-at str x) "]")))
-            (%set-property foo :text (+ str (%call-property (%array 1 2 3) :to-string))))
-          (:add-child arg canvas)
-          (:add-child arg foo)
-          (%set-property this :canvas canvas)
-          (frame :null)
-          #+nil(:add-event-listener arg "enterFrame" (%get-lex :frame))
-          (:add-event-listener canvas "click" (%asm (:get-lex frame)))))
-
-      (swf-defmacro with-fill (gfx (color alpha &key line-style) &body body)
-        `(progn
-           ,@(when line-style
-                   `((:line-style ,gfx ,@line-style)))
-           (:begin-fill ,gfx ,color ,alpha)
-           ,@body
-           (:end-fill ,gfx)))
-
-      (swf-defmemfun frame (evt)
-        (let* ((canvas (%get-property this :canvas))
-               (gfx (:graphics canvas))
-               (matrix (%new flash.geom::Matrix 0)))
-
-          (%set-property canvas :opaque-background #x0d0f00)
-          (:clear gfx)
-          (with-fill gfx (#x202600  0.5)
-            (:draw-rect gfx 0 0 400 300 ))
-          (:create-gradient-box matrix
-                          400 300 0 0 0)
-          (:begin-gradient-fill gfx "radial"
-                          (%array #x202600 #x0d0f00) ;; colors
-                          (%array 1 1) ;; alpha
-                          (%array 0 255) ;; ratios
-                          matrix)
-          (:draw-rect gfx 0 0 400 300 )
-          (:end-fill gfx)
-          (root canvas 200 150 (random 360) 7 1.0 0.005 )))
-
-      (swf-defmemfun root (canvas x y angle depth alpha decay)
-        (%set-local alpha (%to-double alpha))
-        (%set-local x (%to-double x))
-        (%set-local y (%to-double y))
-        (let* ((s (* depth 0.5))
-               (w (* s 6.0))
-               (line-size (* s 0.5))
-               (gfx (:graphics canvas )))
-          (dotimes (i (%to-integer (* depth (random-range 10 20))))
-            (let* ((v (/ depth 5.0))
-                   (color (rgb  (- 0.8 (* v 0.25))
-                                 0.8
-                                 (- 0.8 v))))
-              (%set-local alpha (flash::Math.max 0.0 (- alpha (* i decay))))
-
-              ;; stop if alpha gets below 1/256 or so
-              (when (> alpha 0.004)
-                (%set-local angle (+ angle (random-range -60 60)))
-                (let ((dx (+ x (* (cos (radians angle)) w)))
-                      (dy (+ y (* (sin (radians angle)) w))))
-
-                  ;; drop shadow
-                  (with-fill gfx (0 (* alpha 0.6) :line-style (:nan 0 alpha))
-                             (:draw-circle gfx (+ x s 1) (1- (+ y s)) (/ w 3)))
-
-                  ;; line segment to next position:
-                  (with-fill gfx (color (* alpha 0.6)
-                                        :line-style (line-size color alpha))
-                             (:move-to gfx x y)
-                             (:line-to gfx dx dy))
-
-                  ;; filled circle
-                  (with-fill gfx (color (* alpha 0.5)
-                                        :line-style ((* 0.5 line-size)
-                                                     color alpha))
-                             (:draw-circle gfx x y (/ w 4)))
-
-                  (when (and (> depth 0) (> (random 1.0) 0.85))
-                    (root canvas x y (+ angle (random-range -60 60))
-                           (1- depth) alpha decay))
-                  (%set-local x (%to-double dx))
-                  (%set-local y (%to-double dy))))))
-
-          (when (and (> depth 0) (> (random 1.0) 0.7))
-            (root canvas x y angle (1- depth) alpha decay)))))))
\ No newline at end of file
+(in-package :as3-compiler)
+;;; sample from old version. works but needs more refactoring
+
+(define-special %to-double (a)
+  `(,@(scompile a)
+    (:convert-double)))
+
+(define-special %to-integer (a)
+  `(,@(scompile a)
+    (:convert-integer)))
+
+(with-open-file (s "/tmp/roots.swf"
+                   :direction :output
+                              :element-type '(unsigned-byte 8)
+                              :if-exists :supersede)
+  (with-compilation-to-stream s ("frame1" `((0 "testClass")))
+
+    (def-swf-class :test-class "test-class" flash.display::sprite ()
+                   (()
+                    (main this)))
+
+    (swf-defmemfun random-range (a b)
+      (+ a (floor (random (- b a)))))
+
+    #+nil(swf-defmemfun radians (a)
+           (/ (* a flash::math.PI) 180.0))
+    (swf-defmemfun radians (a)
+      (/ (* a #.pi) 180.0))
+
+    (swf-defmemfun i255 (a)
+      (flash::Math.max (flash::Math.min (floor (* a 256)) 255) 0))
+
+    (swf-defmemfun rgb (r g b)
+      (+ (* (i255 r) 65536) (* (i255 g) 256) (i255 b)))
+
+    (swf-defmemfun main (arg)
+      (let ((foo (%new flash.text::Text-Field 0))
+            (canvas (%new flash.display::Sprite 0)))
+        (%set-property foo :auto-size "left")
+        (%set-property foo :text-color (rgb 200 100 100))
+        (%set-property foo :word-wrap :true)
+        (let ((str"abc..." ))
+          (%set-local str (+ str (flash::string.from-char-code 26085)))
+          (%set-local str (+ str (flash::string.from-char-code 26412)))
+          (%set-local str (+ str (flash::string.from-char-code 21566)))
+          (%set-local str (+ str (%get-property str :length )))
+          (let ((cc (cons 0 2)))
+            (%set-local str (+ str (cons 2 3)))
+            (%set-local str (+ str "=(" (car cc) " " (cdr cc) ")"))
+            (%set-local str (+ str " car(nil)=" (car nil)))
+            (%set-local str (+ str " %typeof=" (%type-of cc)))
+            (%set-local str (+ str " %typep...=" (%typep cc cons-type)))
+            (%set-local str (+ str " %typep.1.=" (%typep 1 cons-type)))
+            (%set-local str (+ str " case="
+                               (case (car cc)
+                                 (1 "-1-")
+                                 (0 "-0-")
+                                 (2 "-2-")
+                                 (otherwise "-t-")
+)))
+            (%set-local str (+ str " case2="
+                               (case (cdr cc)
+                                 (1 "-1-")
+                                 (0 "-0-")
+                                 (2 "-2-"))))
+;            (%set-local str (+ str " cdr(1)=" (cdr 1)))
+            (%set-local str (+ str " <" (if (car :null) "t" "f") ">")))
+
+          (%set-property foo :text (+ str (%call-property (%array 1 2 3) :to-string))))
+        (:add-child arg canvas)
+        (:add-child arg foo)
+        (%set-property this :canvas canvas)
+        (frame :null)
+        #+nil(:add-event-listener arg "enterFrame" (%get-lex :frame))
+        (:add-event-listener canvas "click" (%asm (:get-lex frame)))))
+
+    (swf-defmacro with-fill (gfx (color alpha &key line-style) &body body)
+      `(progn
+         ,@(when line-style
+                 `((:line-style ,gfx ,@line-style)))
+         (:begin-fill ,gfx ,color ,alpha)
+         ,@body
+         (:end-fill ,gfx)))
+
+    (swf-defmemfun frame (evt)
+      (let* ((canvas (%get-property this :canvas))
+             (gfx (:graphics canvas))
+             (matrix (%new flash.geom::Matrix 0)))
+
+        (%set-property canvas :opaque-background #x0d0f00)
+        (:clear gfx)
+        (with-fill gfx (#x202600  0.5)
+                   (:draw-rect gfx 0 0 400 300 ))
+        (:create-gradient-box matrix
+                              400 300 0 0 0)
+        (:begin-gradient-fill gfx "radial"
+                              (%array #x202600 #x0d0f00) ;; colors
+                              (%array 1 1)               ;; alpha
+                              (%array 0 255)             ;; ratios
+                              matrix)
+        (:draw-rect gfx 0 0 400 300 )
+        (:end-fill gfx)
+        (root canvas 200 150 (random 360) 7 1.0 0.005 )))
+
+    (swf-defmemfun root (canvas x y angle depth alpha decay)
+      (%set-local alpha (%to-double alpha))
+      (%set-local x (%to-double x))
+      (%set-local y (%to-double y))
+      (let* ((s (* depth 0.5))
+             (w (* s 6.0))
+             (line-size (* s 0.5))
+             (gfx (:graphics canvas )))
+        (dotimes (i (%to-integer (* depth (random-range 10 20))))
+          (let* ((v (/ depth 5.0))
+                 (color (rgb  (- 0.8 (* v 0.25))
+                              0.8
+                              (- 0.8 v))))
+            (%set-local alpha (flash::Math.max 0.0 (- alpha (* i decay))))
+
+            ;; stop if alpha gets below 1/256 or so
+            (when (> alpha 0.004)
+              (%set-local angle (+ angle (random-range -60 60)))
+              (let ((dx (+ x (* (cos (radians angle)) w)))
+                    (dy (+ y (* (sin (radians angle)) w))))
+
+                ;; drop shadow
+                (with-fill gfx (0 (* alpha 0.6) :line-style (:nan 0 alpha))
+                           (:draw-circle gfx (+ x s 1) (1- (+ y s)) (/ w 3)))
+
+                ;; line segment to next position:
+                (with-fill gfx (color (* alpha 0.6)
+                                      :line-style (line-size color alpha))
+                           (:move-to gfx x y)
+                           (:line-to gfx dx dy))
+
+                ;; filled circle
+                (with-fill gfx (color (* alpha 0.5)
+                                      :line-style ((* 0.5 line-size)
+                                                   color alpha))
+                           (:draw-circle gfx x y (/ w 4)))
+
+                (when (and (> depth 0) (> (random 1.0) 0.85))
+                  (root canvas x y (+ angle (random-range -60 60))
+                        (1- depth) alpha decay))
+                (%set-local x (%to-double dx))
+                (%set-local y (%to-double dy))))))
+
+        (when (and (> depth 0) (> (random 1.0) 0.7))
+          (root canvas x y angle (1- depth) alpha decay))))))
\ No newline at end of file
-- 
2.11.4.GIT