test/test.lisp

   1 (in-package :avm2-compiler)
   2 ;;; random tests for various features, need to figure out how to
   3 ;;; automate these at some point
   4
   5 (with-open-file (s "/tmp/tests.swf"
   6                    :direction :output
   7                               :element-type '(unsigned-byte 8)
   8                               :if-exists :supersede)
   9   (with-compilation-to-stream s ("frame1" `((0 "testClass")))
  10
  11     (def-swf-class :test-class "test-class" flash.display::sprite ()
  12                    (()
  13                     (main this)))
  14
  15
  16     #+nil(swf-defmemfun flet-test1 ()
  17            (%flet (foo (a b c) (+ a b c))
  18                   (call-%flet foo "a" "b" "c")
  19                   (call-%flet foo "1" "2" "3")))
  20
  21     (swf-defmemfun flet-test1 ()
  22       (%flet (foo (a b c) (+ a b c))
  23              (call-%flet foo (%flet (afoo (a b c) (+ a b c))
  24                                     (call-%flet afoo "a" "b" "c"))
  25                          "b" "c" )))
  26
  27     #+nil(swf-defmemfun uwp-test ()
  28            (let ((s2 "<"))
  29              (block foo
  30                1
  31                (unwind-protect
  32                     (if :true (return-from foo "-ret-") 4)
  33                  (%set-local s2 (+ s2 "uwp")))
  34                2)
  35              (+ s2 ">")))
  36
  37     (swf-defmemfun uwp-test ()
  38       (let ((s2 "<"))
  39         (block foo
  40           (unwind-protect
  41                (progn
  42                  (return-from foo "-ret-")
  43                  "bleh")
  44             (%set-local s2 (+ s2 123))))
  45         (+ s2 "<")))
  46
  47     (swf-defmemfun cons-test ()
  48       (let* ((a (cons 2 3))
  49              (b (cons 1 a)))
  50         (%set-property (cdr b) %car 123)
  51         (+ "(" (car a) " " (car b) ")")))
  52
  53     (swf-defmemfun test-dolist ()
  54       "not implemented"#+nil(let ((temp ""))
  55         (dolist (a (cons "a" (cons "b" (cons "c" nil)))
  56                  temp)
  57           (%set-local temp (+ temp (:to-string a))))))
  58
  59     (swf-defmemfun i255 (a)
  60       (flash::Math.max (flash::Math.min (floor (* a 256)) 255) 0))
  61
  62     (swf-defmemfun rgb (r g b)
  63       (+ (* (i255 r) 65536) (* (i255 g) 256) (i255 b)))
  64
  65     (swf-defmemfun rgba (r g b a)
  66       (+ (* (i255 a) 65536 256) (rgb r g b)))
  67
  68     (swf-defmemfun main (arg)
  69       (let ((foo (%new flash.text::Text-Field 0))
  70             (canvas (%new flash.display::Sprite 0)))
  71         (%set-property foo :width 350)
  72         (%set-property foo :auto-size "left")
  73         (%set-property foo :text-color (rgb 0.2 0.9 0.2 ))
  74         (%set-property foo :word-wrap :true)
  75         (%set-property foo :background :true)
  76         (%set-property foo :background-color (rgba 0.1 0.1 0.1 0.1))
  77         (let ((str "abc..."))
  78           (%set-local str (+ str (flash::string.from-char-code 26085)))
  79           (%set-local str (+ str (flash::string.from-char-code 26412)))
  80           (%set-local str (+ str (flash::string.from-char-code #x8a9e)))
  81           (let ((cc (cons 0 2)))
  82             (%set-local str (+ str (cons 2 3)))
  83             (%set-local str (+ str "=(" (car cc) " " (cdr cc) ")"))
  84             (%set-local str (+ str " || car(nil)=" (car nil)))
  85             (%set-local str (+ str " || %typeof=" (%type-of cc)))
  86             (%set-local str (+ str " || %typep...=" (%typep cc cons-type)))
  87             (%set-local str (+ str " || %typep.1.=" (%typep 1 cons-type)))
  88             (%set-local str (+ str " || case="
  89                                (case (car cc)
  90                                  (1 "-1-")
  91                                  (0 "-0-")
  92                                  (2 "-2-")
  93                                  (otherwise "-t-")
  94                                  )))
  95             (%set-local str (+ str " || case2="
  96                                (case (cdr cc)
  97                                  (1 "-1-")
  98                                  (0 "-0-")
  99                                  (2 "-2-"))))
 100             (%set-local str (+ str " || block="
 101                                (block foo
 102                                  1
 103                                  (if t (return-from foo "-ret-") 4)
 104                                  2)))
 105             #+nil(%set-local str (+ str " uwp=" (uwp-test)))
 106             (%set-local str (+ str " || cons=" (cons-test)))
 107             (%set-local str (+ str " || %flet=" (flet-test1)))
 108             ;;(%set-local str (+ str " %flet=" (flet-test2 "a" "b" "c")))
 109             ;;(%set-local str (+ str " cdr(1)=" (cdr 1)))
 110             (%set-local str (+ str " || <" (if (car :null) "t" "f") ">"))
 111             (%set-local str (+ str " || typecase 123="
 112                                (typecase 123
 113                                  (cons-type "-cons-")
 114                                  (:int "-:int-")
 115                                  (otherwise "-t-"))))
 116             (%set-local str (+ str " || typecase cons="
 117                                (typecase cc
 118                                  (cons-type "-cons-")
 119                                  (otherwise "-t-"))))
 120             (%set-local str (+ str " || when t ="
 121                                (when t "-t-")))
 122             (%set-local str (+ str " || when nil ="
 123                                (when nil "-t-")))
 124             (%set-local str (+ str " || unless t ="
 125                                (unless t "-t-")))
 126             (%set-local str (+ str " || unless nil ="
 127                                (unless nil "-t-")))
 128             (%set-local str (+ str " || and ="
 129                                (and)))
 130             (%set-local str (+ str " || and t ="
 131                                (and "t")))
 132             (%set-local str (+ str " || and t nil ="
 133                                (and "t" nil)))
 134             (%set-local str (+ str " || and nil t ="
 135                                (and nil "t")))
 136             (%set-local str (+ str " || and t t ="
 137                                (and "t1" "t2")))
 138             (%set-local str (+ str " || or ="
 139                                (or)))
 140             (%set-local str (+ str " || or t ="
 141                                (or "t")))
 142             (%set-local str (+ str " || or t nil ="
 143                                (or "t" nil)))
 144             (%set-local str (+ str " || or nil t ="
 145                                (or nil "t")))
 146             (%set-local str (+ str " || or t t ="
 147                                (or "t1" "t2")))
 148             (%set-local str (+ str " || cond="
 149                                (cond
 150                                  ((eq 1 cc) "-foo-")
 151                                  ((> 3 2) "-3>2-")
 152                                  (nil "-nil-")
 153                                  (t "-t-"))))
 154             (let ((c2 (cons "a" (cons "b" nil))))
 155               (%set-local str (+ str " || pop1 =" (pop c2)))
 156               (%set-local str (+ str " || pop2 = (" (car c2) " . " (cdr c2) ")"))
 157 )
 158             (%set-local str (+ str " || dolist=" (test-dolist)))
 159 )
 160
 161           (%set-property foo :text (+ str " || " (%call-property (%array 1 2 3) :to-string))))
 162         (:add-child arg canvas)
 163         (:add-child arg foo)
 164         (%set-property this :canvas canvas)
 165         (frame :null)
 166         #+nil(:add-event-listener arg "enterFrame" (%get-lex :frame))
 167         (:add-event-listener canvas "click" (%asm (:get-lex frame)))))
 168
 169     (swf-defmacro with-fill (gfx (color alpha &key line-style) &body body)
 170       `(progn
 171          ,@(when line-style
 172                  `((:line-style ,gfx ,@line-style)))
 173          (:begin-fill ,gfx ,color ,alpha)
 174          ,@body
 175          (:end-fill ,gfx)))
 176
 177     (swf-defmemfun frame (evt)
 178       (let* ((canvas (%get-property this :canvas))
 179              (gfx (:graphics canvas))
 180              (matrix (%new flash.geom::Matrix 0)))
 181
 182         (%set-property canvas :opaque-background #x0d0f00)
 183         (:clear gfx)
 184         (with-fill gfx (#x202600  0.5)
 185                    (:draw-rect gfx 0 0 400 300 ))
 186         (:create-gradient-box matrix
 187                               400 300 0 0 0)
 188         (:begin-gradient-fill gfx "radial"
 189                               (%array #x202600 #x0d0f00) ;; colors
 190                               (%array 1 1)               ;; alpha
 191                               (%array 0 255)             ;; ratios
 192                               matrix)
 193         (:draw-rect gfx 0 0 400 300 )
 194         (:end-fill gfx)))))