lib/cl-arrays.lisp

   1 (in-package #:avm2-compiler)
   2
   3 ;;; cl array functions
   4
   5 ;; using untyped arrays for now, so don't have the specialized arrays
   6 ;; required by the spec
   7
   8
   9 (let ((*symbol-table* *cl-symbol-table*))
  10
  11   (swf-defmacro aref (array &rest subscripts)
  12                 (let ((a (gensym)))
  13                   (if (= 1 (length subscripts))
  14                       `(let ((,a ,array))
  15                          (if (%typep ,a %flash:array)
  16                              (%aref-1 ,a ,(first subscripts))
  17                              (if (%typep ,a %flash:string)
  18                                  (%flash:char-at ,a 1)
  19                                  (%aref-n ,array ,@subscripts))))
  20                       `(%aref-n ,array ,@subscripts))))
  21
  22   (def-swf-class not-simple-array-type "not-simple-array" %flash:object
  23                  (%dimensions-array
  24                   %adjustable-p
  25                   %fill-pointer
  26                   %displaced-to
  27                   %displaced-offset)
  28                  ((dimensions adjustable fill-pointer displaced-to displaced-offset)
  29                   (%set-property this %dimensions-array dimensions)
  30                   (%set-property this %adjustable-p adjustable)
  31                   (%set-property this %fill-pointer fill-pointer)
  32                   (%set-property this %displaced-to displaced-to)
  33                   (%set-property this %displaced-offset displaced-offset)))
  34
  35
  36   (swf-defmemfun %make-simple-array (size)
  37     (%new* %flash:Array size))
  38
  39   (swf-defmemfun %make-simple-array-with-element (size initial-element)
  40     (let ((a (%new* %flash:Array size)))
  41       (dotimes (i size a)
  42         (%set-aref a i initial-element))))
  43
  44   (swf-defmemfun %array-row-major-index (array subscripts)
  45     (let ((dims (%dimensions-array array))
  46           (index 0))
  47       (unless (= (length subscripts) (length dims))
  48         (%error "wrong number of subscripts in array-row-major-index"))
  49       (dotimes (i (length subscripts) index)
  50         (setf index (* index (%aref-1 dims i)))
  51         (incf index (%aref-1 subscripts i)))))
  52
  53   (swf-defmemfun array-row-major-index (array &arest subscripts)
  54     (%array-row-major-index array subscripts))
  55
  56   (swf-defmemfun %aref-n (array &arest subscripts)
  57     (%aref-1 (%displaced-to array)
  58              (+ (%displaced-offset array)
  59                 (%array-row-major-index array subscripts))))
  60
  61   #+nil(swf-defmemfun make-array (dimensions &key element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset)
  62     (if (or adjustable fill-pointer displaced-index-offset displaced-to (> (list-length dimensions) 1))
  63         ;; non-simple array
  64         (let ((linear-size (car dimensions)))
  65           (dolist (dim (cdr dimensions))
  66             (setf linear-size (* linear-size dim)))
  67           (unless displaced-to
  68             (setf displaced-to (%make-simple-array linear-size))))
  69 )
  70 ))
  71
  72
  73 #+nil(let ((*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table* *player-symbol-table*))))
  74    (dump-defun-asm (&arest rest)
  75      'a))
  76 #+nil(let ((*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table* *player-symbol-table*))))
  77    (dump-defun-asm (&arest rest)
  78      :foo))
  79 #+nil(let ((*symbol-table* (make-instance 'symbol-table :inherit (list *cl-symbol-table* *player-symbol-table*))))
  80    (dump-defun-asm (&arest rest)
  81      '(1)))