lib/cl.lisp

   1 (in-package #:avm2-compiler)
   2
   3 ;;; implement functions/macros from CL package
   4 ;;;
   5 ;;; most probably don't match CL semantics very closely yet...
   6
   7
   8 ;;; define this here for now instead of special-forms.lisp, as it needs %flash
   9 (defmethod %quote ((object symbol))
  10   ;; fixme: need to intern symbols somewhere, this doesn't make symbols that are EQ (though they are EQL with current implementation, which probably means EQL should be EQUAL)
  11   (scompile `(%new* %flash:q-name
  12                     ,(package-name (symbol-package object))
  13                     ,(symbol-name object))))
  14
  15
  16 (let ((*symbol-table* *cl-symbol-table*))
  17
  18   (swf-defmacro %apply (function this-arg rest-array)
  19     `(%flash:apply ,function ,this-arg ,rest-array))
  20
  21   (swf-defmacro %funcall (function this-arg &rest rest)
  22     `(%flash:call ,function ,this-arg ,@rest))
  23
  24   (swf-defmacro return (value)
  25     `(return-from nil ,value))
  26
  27
  28   ;; partial implementation of setf, only handles setting local vars,
  29   ;;  so we can start using it while waiting on real implementation
  30   ;; adding hack for (setf foo) functions also (doesn't work yet though)
  31   (swf-defmacro %setf-1 (place value)
  32     (print (if (consp place)
  33                (cond
  34                  ((find-swf-property (first place))
  35                   `(%set-property ,(second place) ,(first place) ,value))
  36                  (t `((setf ,(first place)) ,(second place) ,(first place) ,value)))
  37                `(%set-local ,place ,value))))
  38
  39   (swf-defmacro setf (&rest args)
  40     `(progn
  41        ,@(loop for (var value) on args by #'cddr
  42             collect `(%setf-1 ,var ,value))))
  43
  44   ;; partial implementation of psetf, only handles setting local vars,
  45   ;;  so we can start using it while waiting on real implementation
  46   (swf-defmacro psetf (&rest args)
  47     (let ((temps (loop repeat (/ (length args) 2)
  48                     collect (gensym))))
  49       `(let (,@(loop
  50                   for temp in temps
  51                   for (nil value) on args by #'cddr
  52                   collect `(,temp ,value)))
  53          ,@(loop
  54               for temp in temps
  55               for (var nil) on args by #'cddr
  56               collect `(setf ,var ,temp)))))
  57
  58   ;; setq and psetq just calling setf/psetf for now, after checking vars
  59   (swf-defmacro setq (&rest args)
  60     (loop for (var nil) on args by #'cddr
  61        unless (atom var)
  62        do (error "variable name is not a symbol in SETQ: ~s" var))
  63     `(setf ,@args))
  64
  65   (swf-defmacro psetq (&rest args)
  66     (loop for (var nil) on args by #'cddr
  67        unless (atom var)
  68        do (error "variable name is not a symbol in PSETQ: ~s" var))
  69     `(psetf ,@args))
  70
  71   (swf-defmemfun random (a)
  72     ;;todo: return int for int args
  73     ;;fixme: don't seem to be able to set seeds, so can't do random-state arg
  74     (* (%flash:random) a))
  75
  76   (swf-defmemfun 1- (a)
  77     (- a 1))
  78   (swf-defmemfun 1+ (a)
  79     (+ a 1))
  80
  81   (swf-defmemfun floor (number)
  82     ;; todo implement optional divisor arg (need multiple values)
  83     (%flash:floor number))
  84
  85   (swf-defmemfun cos (radians)
  86     (%flash:cos radians))
  87   (swf-defmemfun sin (radians)
  88     (%flash:sin radians))
  89   (swf-defmemfun tan (radians)
  90     (%flash:tan radians))
  91
  92   (swf-defmemfun min (&arest numbers)
  93     (%apply (function %flash:min) nil numbers))
  94
  95   (swf-defmemfun max (&arest numbers)
  96     (%apply (function %flash:max) nil numbers))
  97
  98   (swf-defmemfun eq (a b)
  99     (%asm (:get-local-1)
 100           (:get-local-2)
 101           (:strict-equals)))
 102
 103   (swf-defmemfun eql (a b)
 104     (%asm (:get-local-1)
 105           (:get-local-2)
 106           ;; not quite right, since it compares all numbers by value
 107           ;; also compares strings, but since strings are immutable,
 108           ;; that is arguably OK
 109           (:strict-equals)))
 110
 111   (swf-defmemfun equal (a b)
 112     (%asm (:get-local-1)
 113           (:get-local-2)
 114           ;;even less correct than EQL, since it converts
 115           ;;string<->number<->Boolean, and a few other things
 116           (:equals)))
 117
 118   #+nil  (swf-defmemfun error (datum &rest args) )
 119
 120   #+nil  (swf-defmemfun typep (object type)
 121     (%typep object type))
 122
 123   (swf-defmacro let* (bindings &body body)
 124     `(let (,(car bindings))
 125        ,@(if (cdr bindings)
 126              `((let* ,(cdr bindings) ,@body))
 127              body)))
 128
 129
 130 ;;; from sicl:
 131 ;;; sicl-conditionals.lisp: OR AND WHEN UNLESS COND CASE TYPECASE
 132 ;;; sicl-iteration.lisp: DOLIST DOTIMES
 133
 134 ;; temporary hack until SETF is implemented
 135
 136
 137   (swf-defmacro incf (place &optional (delta 1))
 138     `(setf ,place (+ ,place ,delta)))
 139
 140   (swf-defmemfun zerop (x)
 141     (eql x 0))
 142
 143   (swf-defmemfun vector (&arest objects)
 144     objects)
 145
 146   ;; fixme: figure out symbol stuff so this can be a function
 147   (swf-defmacro slot-value (object slot)
 148     (let ((slot-name (if (and (consp slot) (eq 'quote (car slot)))
 149                          (second slot)
 150                          slot)))
 151       `(%asm (:@ ,object)
 152              (:get-property , (find-swf-property slot-name)))))
 153
 154
 155 )
 156
 157 #+nil(let ((*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table* *player-symbol-table*))))
 158    (dump-defun-asm (&arest rest)
 159      (%apply (function %flash:max) nil rest)))