From f5c78fb626927f439a261a3bd0a902d84b1efcf0 Mon Sep 17 00:00:00 2001 From: Bart Botta <00003b@gmail.com> Date: Fri, 12 Dec 2008 04:19:55 -0600 Subject: [PATCH] partially implement FUNCTION,APPLY,FUNCALL, use for MIN,MAX --- compile/compiler-context.lisp | 2 +- compile/ffi.lisp | 17 +++++++++++++++-- compile/special-forms.lisp | 29 +++++++++++++++++++++++++++++ lib/cl.lisp | 37 +++++++++++++++---------------------- test/test.lisp | 14 ++++++++++++-- 5 files changed, 72 insertions(+), 27 deletions(-) diff --git a/compile/compiler-context.lisp b/compile/compiler-context.lisp index 42563e9..a804410 100644 --- a/compile/compiler-context.lisp +++ b/compile/compiler-context.lisp @@ -86,7 +86,7 @@ (loop for i in (inherited-symbol-tables s) when (find-swf-class symbol i) return it)))) - (unless c (format t "couldn't find class ~s~%" symbol) (break)) + (unless c (format t "couldn't find class ~s~%" symbol) #+nil(break)) c)) ;;; handler for normal form evaluation, evaluate ARGS, and call diff --git a/compile/ffi.lisp b/compile/ffi.lisp index 8648fd1..e9c55b0 100644 --- a/compile/ffi.lisp +++ b/compile/ffi.lisp @@ -96,8 +96,6 @@ - - (define-special %call-property (object property &rest args) ;; (%call-property object property args) -> value ;;(format t "call property ~s . ~s ( ~s ) ~%" (first cdr) (second cdr) (third cdr)) @@ -122,6 +120,10 @@ append (scompile i)) ;; calculate args (:call-property ,property ,(length args)))) ;; call it +(define-special %get-property-without-object (property) + `((:find-property-strict ,property) + (:get-property ,property))) + ;;; not sure if these are needed or not, or if api is right, just @@ -147,6 +149,17 @@ append (scompile i)) ;; calculate args (:call-property ,property ,(length args)))) +;; used by stuff like Math.random(), etc +(define-special %get-lex-prop (object-name property) + ;; fixme: better name for this? + `((:get-lex ,(if (find-swf-class object-name) + (swf-name (find-swf-class object-name)) + object-name)) ;; find the object + (:get-property ,(if (find-swf-class property) + (swf-name (find-swf-class property)) + property)))) + + #+nil (define-special %get-lex (name) ;; (%get-lex object-name ) -> value diff --git a/compile/special-forms.lisp b/compile/special-forms.lisp index 3b8bd89..6123480 100644 --- a/compile/special-forms.lisp +++ b/compile/special-forms.lisp @@ -497,6 +497,35 @@ call with %flet-call, which sets up hidden return label arg ;;(scompile '(list* 1 2 3 4 5)) ;;(scompile '(list* 1)) +(define-special function (arg &optional object) + ;; fixme: not all branches tested yet... + (let ((tmp)) + (cond + ;; if OPERATOR is a known method, call with %call-property + ;; (prop obj args...) === obj.prop(args) + ((setf tmp (find-swf-method arg *symbol-table*)) + (break "f-s-m ~s" tmp) + (scompile `(%get-property ,(swf-name tmp) ,object ))) + + ;; if OPERATOR is a known static method, call with %call-lex-prop + ;; (prop obj args...) === obj.prop(args) + ((setf tmp (find-swf-static-method arg *symbol-table*)) + (scompile `(%get-lex-prop ,(first tmp) ,(second tmp)))) + + ;; todo: decide if we should do something for the pretend accessors? + + ;; normal function call, find-prop-strict + call-property + ((setf tmp (find-swf-function arg *symbol-table*)) + (break "f-s-f ~s" tmp) + (scompile `(%get-property-without-object ,tmp))) + + ;; default = normal call? + ;; fixme: might be nicer if we could detect unknown functions + (t + (scompile `(%get-property-without-object ,arg)))))) + + + #+nil(with-lambda-context () (scompile '(block foo 2 (if nil (return-from foo 4) 5) 3))) diff --git a/lib/cl.lisp b/lib/cl.lisp index bf77bad..d8de5a2 100644 --- a/lib/cl.lisp +++ b/lib/cl.lisp @@ -6,6 +6,12 @@ (let ((*symbol-table* *cl-symbol-table*)) + (swf-defmacro %apply (function this-arg rest-array) + `(%flash:apply ,function ,this-arg ,rest-array)) + + (swf-defmacro %funcall (function this-arg &rest rest) + `(%flash:call ,function ,this-arg ,@rest)) + (swf-defmacro return (value) `(return-from nil ,value)) @@ -63,15 +69,6 @@ ;; todo implement optional divisor arg (need multiple values) (%flash:floor number)) - #+nil(swf-defmemfun max (&rest numbers) - ;; fixme: need to figure out how to implement this... - (apply 'flash:max numbers)) - - #+nil(swf-defmemfun min (&rest numbers) - ;; fixme: need to figure out how to implement this... - (apply 'flash:min numbers)) - - (swf-defmemfun cos (radians) (%flash:cos radians)) (swf-defmemfun sin (radians) @@ -79,19 +76,11 @@ (swf-defmemfun tan (radians) (%flash:tan radians)) - (swf-defmemfun min (&arest rest) - (%asm (:get-lex "Math") - (:get-property "min") - (:push-null) - (:get-local 1) - (:call-property "apply" 2))) + (swf-defmemfun min (&arest numbers) + (%apply (function %flash:min) nil numbers)) - (swf-defmemfun max (&arest rest) - (%asm (:get-lex "Math") - (:get-property "max") - (:push-null) - (:get-local 1) - (:call-property "apply" 2))) + (swf-defmemfun max (&arest numbers) + (%apply (function %flash:max) nil numbers)) (swf-defmemfun eq (a b) (%asm (:get-local-1) @@ -138,4 +127,8 @@ slot))) `(%asm (:@ ,object) (:get-property , (find-swf-property slot-name))))) -) \ No newline at end of file +) + +(let ((*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table* *player-symbol-table*)))) + (dump-defun-asm (&arest rest) + (%apply (function %flash:max) nil rest))) diff --git a/test/test.lisp b/test/test.lisp index ec2dca6..fdf864b 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -6,7 +6,7 @@ :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) - (with-compilation-to-stream s ("frame1" `((0 "testClass")) :swf-version 10) + (with-compilation-to-stream s ("frame1" `((0 "testClass")) :swf-version 9) (def-swf-class :test-class "test-class" %flash.display::sprite (blob) (() @@ -94,6 +94,13 @@ (incf sum a)) (+ "[" (/ (- (%new %flash:date 0) now) 1000.0) "sec,sum=" sum "]"))) + (swf-defmemfun space-test2 (obj count) + (let ((now (%new %flash:date 0)) + (cons nil)) + (setf (blob obj) (dotimes (a count cons) + (push (+ "Hello World" a) cons))) + (+ "[" (/ (- (%new %flash:date 0) now) 1000.0) "sec]"))) + (swf-defmemfun unused-args-test (a b c) "ok") (swf-defmemfun list->str (l) @@ -134,7 +141,7 @@ (setf (%flash.text:background foo) t) (setf (%flash.text:background-color foo) (rgba 0.1 0.1 0.1 0.1)) (let ((str "abc...")) - (setf str (+ str (%flash:from-char-code 26085 26412 #x8a9e))) + ;;(setf str (+ str (%flash:from-char-code 26085 26412 #x8a9e))) (let ((cc (cons 0 2))) (setf str (+ str (cons 2 3))) (setf str (+ str "=(" (car cc) " " (cdr cc) ")")) @@ -226,6 +233,9 @@ (when nil (incf str (+ " || space test=" (space-test arg 10000000))) (incf str (+ " || car speed =" (car-speed-test arg 10000000)))) + #+nil(incf str (+ " || space test2=" (space-test2 arg 1000000) + (nth 1000 (blob arg)))) + (let ((foo 4)) (when (and (> foo 0) (> (random 1.0) 0.2)) (incf str "||rand"))) -- 2.11.4.GIT