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 (let ((*symbol-table* *cl-symbol-table*))
   8
   9   (swf-defmacro %apply (function this-arg rest-array)
  10     `(%flash:apply ,function ,this-arg ,rest-array))
  11
  12   (swf-defmacro %funcall (function this-arg &rest rest)
  13     `(%flash:call ,function ,this-arg ,@rest))
  14
  15   (swf-defmacro return (value)
  16     `(return-from nil ,value))
  17
  18
  19   ;; partial implementation of setf, only handles setting local vars,
  20   ;;  so we can start using it while waiting on real implementation
  21   (swf-defmacro %setf-1 (place value)
  22     (print (if (and (consp place) (find-swf-property (car place)))
  23                `(%set-property ,(second place) ,(first place) ,value)
  24                `(%set-local ,place ,value))))
  25
  26   (swf-defmacro setf (&rest args)
  27     `(progn
  28        ,@(loop for (var value) on args by #'cddr
  29             collect `(%setf-1 ,var ,value))))
  30
  31   ;; partial implementation of psetf, only handles setting local vars,
  32   ;;  so we can start using it while waiting on real implementation
  33   (swf-defmacro psetf (&rest args)
  34     (let ((temps (loop repeat (/ (length args) 2)
  35                     collect (gensym))))
  36       `(let (,@(loop
  37                   for temp in temps
  38                   for (nil value) on args by #'cddr
  39                   collect `(,temp ,value)))
  40          ,@(loop
  41               for temp in temps
  42               for (var nil) on args by #'cddr
  43               collect `(setf ,var ,temp)))))
  44
  45   ;; setq and psetq just calling setf/psetf for now, after checking vars
  46   (swf-defmacro setq (&rest args)
  47     (loop for (var nil) on args by #'cddr
  48        unless (atom var)
  49        do (error "variable name is not a symbol in SETQ: ~s" var))
  50     `(setf ,@args))
  51
  52   (swf-defmacro psetq (&rest args)
  53     (loop for (var nil) on args by #'cddr
  54        unless (atom var)
  55        do (error "variable name is not a symbol in PSETQ: ~s" var))
  56     `(psetf ,@args))
  57
  58   (swf-defmemfun random (a)
  59     ;;todo: return int for int args
  60     ;;fixme: don't seem to be able to set seeds, so can't do random-state arg
  61     (* (%flash:random) a))
  62
  63   (swf-defmemfun 1- (a)
  64     (- a 1))
  65   (swf-defmemfun 1+ (a)
  66     (+ a 1))
  67
  68   (swf-defmemfun floor (number)
  69     ;; todo implement optional divisor arg (need multiple values)
  70     (%flash:floor number))
  71
  72   (swf-defmemfun cos (radians)
  73     (%flash:cos radians))
  74   (swf-defmemfun sin (radians)
  75     (%flash:sin radians))
  76   (swf-defmemfun tan (radians)
  77     (%flash:tan radians))
  78
  79   (swf-defmemfun min (&arest numbers)
  80     (%apply (function %flash:min) nil numbers))
  81
  82   (swf-defmemfun max (&arest numbers)
  83     (%apply (function %flash:max) nil numbers))
  84
  85   (swf-defmemfun eq (a b)
  86     (%asm (:get-local-1)
  87           (:get-local-2)
  88           (:strict-equals)))
  89
  90   (swf-defmemfun eql (a b)
  91     (%asm (:get-local-1)
  92           (:get-local-2)
  93           (:equals)))
  94
  95   #+nil  (swf-defmemfun error (datum &rest args) )
  96
  97   #+nil  (swf-defmemfun typep (object type)
  98     (%typep object type))
  99
 100   (swf-defmacro let* (bindings &body body)
 101     `(let (,(car bindings))
 102        ,@(if (cdr bindings)
 103              `((let* ,(cdr bindings) ,@body))
 104              body)))
 105
 106
 107 ;;; from sicl:
 108 ;;; sicl-conditionals.lisp: OR AND WHEN UNLESS COND CASE TYPECASE
 109 ;;; sicl-iteration.lisp: DOLIST DOTIMES
 110
 111 ;; temporary hack until SETF is implemented
 112
 113
 114   (swf-defmacro incf (place &optional (delta 1))
 115     `(setf ,place (+ ,place ,delta)))
 116
 117   (swf-defmemfun zerop (x)
 118     (eql x 0))
 119
 120   (swf-defmemfun vector (&arest objects)
 121     objects)
 122
 123   ;; fixme: figure out symbol stuff so this can be a function
 124   (swf-defmacro slot-value (object slot)
 125     (let ((slot-name (if (and (consp slot) (eq 'quote (car slot)))
 126                          (second slot)
 127                          slot)))
 128       `(%asm (:@ ,object)
 129              (:get-property , (find-swf-property slot-name)))))
 130 )
 131
 132 (let ((*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table* *player-symbol-table*))))
 133    (dump-defun-asm (&arest rest)
 134      (%apply (function %flash:max) nil rest)))