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")) :swf-version 9)
  10
  11     (def-swf-class :test-class "test-class" %flash.display::sprite (blob)
  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                  (setf s2 (+ s2 "uwp")))
  34                2)
  35              (+ s2 ">")))
  36
  37     (swf-defmemfun uwp-test ()
  38       (let* ((s2 "<")
  39              (s3 (block foo
  40                    (unwind-protect
  41                         (progn
  42                           (return-from foo "-ret-")
  43                           "bleh")
  44                      (setf s2 (+ s2 123))))))
  45         (+ s2 s3 ">")))
  46
  47     (swf-defmemfun cons-test ()
  48       (let* ((a (cons 2 3))
  49              (b (cons 1 a)))
  50         (rplaca (cdr b) 123)
  51         (+ "(" (car a) " " (car b) ")")))
  52
  53     (swf-defmemfun dolist-test ()
  54       (let ((temp ""))
  55         (dolist (a (cons "a" (cons "b" (cons "c" nil)))
  56                  temp)
  57           (setf temp (+ temp (%flash:to-string a))))))
  58
  59     (swf-defmemfun dotimes-test ()
  60       (let ((temp "{"))
  61         (setf temp (+ (dotimes (a 5 temp)
  62                               (setf temp (+ temp a)))
  63                             "}"))))
  64
  65     (swf-defmemfun do/do*-tests ()
  66       (+ ""
  67          ;; examples from clhs
  68          (do ((temp-one 1 (1+ temp-one))
  69               (temp-two 0 (1- temp-two)))
  70              ((> (- temp-one temp-two) 5) temp-one))
  71          " "
  72          (do ((temp-one 1 (1+ temp-one))
  73               (temp-two 0 (1+ temp-one)))
  74              ((= 3 temp-two) temp-one))
  75          " "
  76          (do* ((temp-one 1 (1+ temp-one))
  77                (temp-two 0 (1+ temp-one)))
  78               ((= 3 temp-two) temp-one))))
  79
  80     (swf-defmemfun rest-test (a b c &arest d)
  81       (+ "(" a " " b " " c " " d ")"))
  82
  83     (swf-defmemfun space-test (obj count)
  84       (let ((now (%new %flash:date 0))
  85             (cons nil))
  86         (setf (blob obj) (dotimes (a count cons)
  87                            (push 1 cons)))
  88         (+ "[" (/ (- (%new %flash:date 0) now) 1000.0) "sec]")))
  89
  90     (swf-defmemfun car-speed-test (obj count)
  91       (let ((now (%new %flash:date 0))
  92             (sum 0))
  93         (dolist (a (blob obj))
  94           (incf sum a))
  95         (+ "[" (/ (- (%new %flash:date 0) now) 1000.0) "sec,sum=" sum "]")))
  96
  97     (swf-defmemfun space-test2 (obj count)
  98       (let ((now (%new %flash:date 0))
  99             (cons nil))
 100         (setf (blob obj) (dotimes (a count cons)
 101                            (push (+ "Hello World" a) cons)))
 102         (+ "[" (/ (- (%new %flash:date 0) now) 1000.0) "sec]")))
 103
 104     (swf-defmemfun unused-args-test (a b c) "ok")
 105
 106     (swf-defmemfun list->str (l)
 107       (if (atom l)
 108           (%flash:to-string l)
 109           (let ((s "("))
 110             (tagbody
 111              :start
 112                (incf s (car l))
 113                (setf l (cdr l))
 114                (cond
 115                  ((null l) (go :end))
 116                  ((consp l)
 117                   (incf s " ")
 118                   (go :start))
 119                  (t
 120                    (incf s (+ " . " l))
 121                    (go :end)))
 122              :end)
 123             (+ s ")"))))
 124
 125     (swf-defmemfun i255 (a)
 126       (max (min (floor (* a 256)) 255) 0))
 127
 128     (swf-defmemfun rgb (r g b)
 129       (+ (* (i255 r) 65536) (* (i255 g) 256) (i255 b)))
 130
 131     (swf-defmemfun rgba (r g b a)
 132       (+ (* (i255 a) 65536 256) (rgb r g b)))
 133
 134     (swf-defmemfun main (arg)
 135       (let ((foo (%new %flash.text:Text-Field 0))
 136             (canvas (%new %flash.display:Sprite 0)))
 137         (setf (%flash.display:width foo) 350)
 138         (setf (%flash.text:auto-size foo) "left")
 139         (setf (%flash.text:text-color foo) (rgb 0.2 0.9 0.2 ))
 140         (setf (%flash.text:word-wrap foo) t)
 141         (setf (%flash.text:background foo) t)
 142         (setf (%flash.text:background-color foo) (rgba 0.1 0.1 0.1 0.1))
 143         (let ((str "abc..."))
 144           (setf str (+ str (%flash:from-char-code 26085 26412 #x8a9e)))
 145           (let ((cc (cons 0 2)))
 146             (setf str (+ str (cons 2 3)))
 147             (setf str (+ str "=(" (car cc) " " (cdr cc) ")"))
 148             (setf str (+ str "cons size=" (%flash.sampler:get-size cc)))
 149             (setf str (+ str "int size=" (%flash.sampler:get-size 1)))
 150             (setf str (+ str " || car(nil)=" (car nil)))
 151             (setf str (+ str " || %typeof=" (%type-of cc)))
 152             (setf str (+ str " || %typep...=" (%typep cc cons-type)))
 153             (setf str (+ str " || %typep.1.=" (%typep 1 cons-type)))
 154             (setf str (+ str " || case="
 155                                (case (car cc)
 156                                  (1 "-1-")
 157                                  (0 "-0-")
 158                                  (2 "-2-")
 159                                  (otherwise "-t-")
 160                                  )))
 161             (setf str (+ str " || case2="
 162                                (case (cdr cc)
 163                                  (1 "-1-")
 164                                  (0 "-0-")
 165                                  (2 "-2-"))))
 166             (setf str (+ str " || block="
 167                                (block foo
 168                                  1
 169                                  (if t (return-from foo "-ret-") 4)
 170                                  2)))
 171             (setf str (+ str " uwp=" (uwp-test)))
 172             (setf str (+ str " || cons=" (cons-test)))
 173             (setf str (+ str " || %flet=" (flet-test1)))
 174             ;;(setf str (+ str " %flet=" (flet-test2 "a" "b" "c")))
 175             ;;(setf str (+ str " cdr(1)=" (cdr 1)))
 176             (setf str (+ str " || <" (if (car nil) "t" "f") ">"))
 177             (setf str (+ str " || typecase 123="
 178                                (typecase 123
 179                                  (cons-type "-cons-")
 180                                  (:int "-:int-")
 181                                  (otherwise "-t-"))))
 182             (setf str (+ str " || typecase cons="
 183                                (typecase cc
 184                                  (cons-type "-cons-")
 185                                  (otherwise "-t-"))))
 186             (setf str (+ str " || when t ="
 187                                (when t "-t-")))
 188             (setf str (+ str " || when nil ="
 189                                (when nil "-t-")))
 190             (setf str (+ str " || unless t ="
 191                                (unless t "-t-")))
 192             (setf str (+ str " || unless nil ="
 193                                (unless nil "-t-")))
 194             (setf str (+ str " || and ="
 195                                (and)))
 196             (setf str (+ str " || and t ="
 197                                (and "t")))
 198             (setf str (+ str " || and t nil ="
 199                                (and "t" nil)))
 200             (setf str (+ str " || and nil t ="
 201                                (and nil "t")))
 202             (setf str (+ str " || and t t ="
 203                                (and "t1" "t2")))
 204             (setf str (+ str " || or ="
 205                                (or)))
 206             (setf str (+ str " || or t ="
 207                                (or "t")))
 208             (setf str (+ str " || or t nil ="
 209                                (or "t" nil)))
 210             (setf str (+ str " || or nil t ="
 211                                (or nil "t")))
 212             (setf str (+ str " || or t t ="
 213                                (or "t1" "t2")))
 214             (setf str (+ str " || cond="
 215                                (cond
 216                                  ((eq 1 cc) "-foo-")
 217                                  ((> 3 2) "-3>2-")
 218                                  (nil "-nil-")
 219                                  (t "-t-"))))
 220             (let ((c2 (cons "a" (cons "b" nil))))
 221               (setf str (+ str " || pop1 =" (pop c2)))
 222               (setf str (+ str " || pop2 = (" (car c2) " . " (cdr c2) ")")))
 223
 224             (setf str (+ str " || dolist=" (dolist-test)))
 225             (incf str (+ " || dotimes=" (dotimes-test)))
 226             ;;(dotimes (a 5) (incf str a))
 227             (incf str (+ " || nth (0 1 2 3 4) 3=" (nth 3 (list 0 1 2 3 4))))
 228             (incf str (+ " || nthcdr (0 1 2 3 4) 3=" (list->str (nthcdr 3 (list 0 1 2 3 4)))))
 229             (incf str (+ " || last (0 1 2 3 4) 3=" (list->str (last (list 0 1 2 3 4)))))
 230             (incf str (+ " || last (0 1 . 2) 3=" (list->str (last (cons 0 (cons 1 2))))))
 231             (incf str (+ " || arest test=" (rest-test 1 2 3 4 5 6 )))
 232             #+nil(incf str (+ " || car 0=" (car 0)))
 233             (when nil
 234               (incf str (+ " || space test=" (space-test arg 10000000)))
 235               (incf str (+ " || car speed =" (car-speed-test arg 10000000))))
 236             #+nil(incf str (+ " || space test2=" (space-test2 arg 1000000)
 237                          (nth 1000 (blob arg))))
 238             (incf str (+ " || keyword =" :foo))
 239             (incf str (+ " || eq :foo :foo =" (eq :foo :foo)))
 240             (incf str (+ " || eql :foo :foo =" (eql :foo :foo)))
 241             (incf str (+ " || equal \"2\" 2 =" (equal "2" 2)))
 242             (incf str (+ " || '(1 a :b) =" (list->str '(1 a :b))))
 243             (incf str (+ " || #(1 2 3) =" #(1 2 3 )))
 244             (incf str (+ " || aref #(1 2 3) 1 =" (aref #(1 2 3) 1)))
 245             (incf str (+ " || aref \"piyo\" 1 =" (aref "piyo" 1)))
 246             (incf str (+ " || a-r-m-i ="
 247                          (array-row-major-index (%new* not-simple-array-type
 248                                                       #(2 3 4) nil nil
 249                                                       #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24)
 250                                                       0)
 251                                                 0 2 1)))
 252             (incf str (+ " || aref 0 2 1 ="
 253                          (aref (%new* not-simple-array-type
 254                                                       #(2 3 4) nil nil
 255                                                       #(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24)
 256                                                       0)
 257                                                 0 2 1)))
 258             (incf str (+ " || reverse #(1 2 3) =" (reverse #(1 2 3))))
 259             (incf str (+ " || reverse \"hoge\" =" (reverse "hoge")))
 260             (let ((foo 4))
 261               (when (and (> foo 0) (> (random 1.0) 0.2))
 262                 (incf str "||rand")))
 263             (incf str (+ " || nconc test="  (list->str (nconc (cons 1 2) (cons 3 4)))))
 264             (incf str (+ " || do test: 4,3,2=" (do/do*-tests)))
 265             (incf str (+ " || unused args: " (unused-args-test 1 2 3)))
 266             (incf str (+ " || pi: " %flash:+pi+))
 267             (%flash:trace (+ " || unused args: " (unused-args-test 1 2 3)))
 268 )
 269
 270           (setf (%flash.text:text foo) (+ str " || " (%flash:to-string (%array 1 2 3)))))
 271         (%flash.display:add-child arg canvas)
 272         (%flash.display:add-child arg foo)
 273         (%set-property this :tc arg)
 274         (%set-property this :canvas canvas)
 275         (frame nil)
 276         #+nil(:add-event-listener arg "enterFrame" (%get-lex :frame))
 277         (%flash.display:add-event-listener canvas "click" (%asm (:get-lex frame)))))
 278
 279     (swf-defmacro with-fill (gfx (color alpha &key line-style) &body body)
 280       `(progn
 281          ,@(when line-style
 282                  `((%flash.display:line-style ,gfx ,@line-style)))
 283          (%flash.display:begin-fill ,gfx ,color ,alpha)
 284          ,@body
 285          (%flash.display:end-fill ,gfx)))
 286
 287     (swf-defmemfun frame (evt)
 288       (let* ((canvas (%get-property this :canvas))
 289              (gfx (slot-value canvas '%flash.display:graphics))
 290              (matrix (%new %flash.geom:Matrix 0)))
 291
 292         (setf (%flash.display:opaque-background canvas) #x0d0f00)
 293         (%flash.display:clear gfx)
 294         (with-fill gfx (#x202600  0.5)
 295                    (%flash.display:draw-rect gfx 0 0 400 300 ))
 296         (%flash.geom:create-gradient-box matrix
 297                               400 300 0 0 0)
 298         (%flash.display:begin-gradient-fill gfx "radial"
 299                               (vector #x202600 #x0d0f00) ;; colors
 300                               (vector 1 1)               ;; alpha
 301                               (vector 0 255)             ;; ratios
 302                               matrix)
 303         (%flash.display:draw-rect gfx 0 0 400 300 )
 304         (%flash:trace "click")
 305         (%flash.display:end-fill gfx)))))