lib/cl-conses.lisp

   1 (in-package #:avm2-compiler)
   2
   3 ;;; implement lower level functions from conses dictionary
   4 ;;;
   5 ;;; not all match CL semantics very closely yet...
   6
   7 ;;; conses dictionary (14.2)
   8 ;;;
   9 ;;; not sure what best internal rep for conses is,
  10 ;;;  could use anonymous object
  11 ;;;  2 element array
  12 ;;;  instances of named class
  13 ;;;  ?
  14 ;;;
  15 ;;;  named class is probably easiest to recognize for type checking
  16 ;;;    so trying that first
  17 ;;;  anon object with car and cdr properties might also be nice, and
  18 ;;;    just allow any object with those to be used as a 'cons', but
  19 ;;;    wouldn't match CL sematics very well
  20 (let ((*symbol-table* *cl-symbol-table*))
  21   ;; todo: probably should figure out how to make this final/sealed/etc.
  22   (def-swf-class cons-type "cons" %flash:object (%car %cdr)
  23                  ((a b)
  24                   (%set-property this %car a)
  25                   (%set-property this %cdr b)))
  26
  27   (swf-defmemfun cons (a b)
  28     (%asm (:find-property-strict cons-type)
  29           (:@ a)
  30           (:@ b)
  31           (:construct-prop cons-type 2)))
  32
  33   (swf-defmemfun consp (a)
  34     (%typep a cons-type))
  35
  36   (swf-defmemfun atom (object)
  37     (not (consp object)))
  38
  39   (swf-defmemfun %type-error (fun arg)
  40     (%error (+ "type-error: unknown type in " fun ":" (%type-of arg))))
  41
  42   ;;; implementing CAR/CDR as special forms for performance, until
  43   ;;; compiler macros are available
  44   (swf-defmemfun car (a)
  45          (if (eq a :null)
  46              :null
  47              (if (consp a)
  48                  (%asm (:@ a)
  49                         (:coerce cons-type)
  50                         (:get-property %car))
  51                  (%type-error "CAR" a))))
  52
  53   (swf-defmemfun cdr (a)
  54          (if (eq a :null)
  55              :null
  56              (if (consp a)
  57                  (%asm (:@ a)
  58                        (:coerce cons-type)
  59                        (:get-property %cdr))
  60                  (%type-error "CDR" a))))
  61
  62
  63   (swf-defmacro rplaca (cons object)
  64     (let ((temp (gensym "RPLACA-TEMP-")))
  65       `(let ((,temp ,cons))
  66          (progn
  67            (unless (consp ,temp) (%type-error "RPLACA" ,temp))
  68            (%set-property ,temp %car ,object)
  69            ,temp))))
  70
  71   (swf-defmacro rplacd (cons object)
  72     (let ((temp (gensym "REPLACD-TEMP-")))
  73       `(let ((,temp ,cons))
  74          (progn
  75            (unless (consp ,temp) (%type-error "RPLACD" ,temp))
  76            (%set-property ,temp %cdr ,object)
  77            ,temp))))
  78
  79
  80   (swf-defmemfun caar (x) (car (car x)))
  81   (swf-defmemfun cadr (x) (car (cdr x)))
  82   (swf-defmemfun cdar (x) (cdr (car x)))
  83   (swf-defmemfun cddr (x) (cdr (cdr x)))
  84   (swf-defmemfun caaar (x) (car (car (car x))))
  85   (swf-defmemfun caadr (x) (car (car (cdr x))))
  86   (swf-defmemfun cadar (x) (car (cdr (car x))))
  87   (swf-defmemfun caddr (x) (car (cdr (cdr x))))
  88   (swf-defmemfun cdaar (x) (cdr (car (car x))))
  89   (swf-defmemfun cdadr (x) (cdr (car (cdr x))))
  90   (swf-defmemfun cddar (x) (cdr (cdr (car x))))
  91   (swf-defmemfun cdddr (x) (cdr (cdr (cdr x))))
  92   (swf-defmemfun caaaar (x) (car (car (car (car x)))))
  93   (swf-defmemfun caaadr (x) (car (car (car (cdr x)))))
  94   (swf-defmemfun caadar (x) (car (car (cdr (car x)))))
  95   (swf-defmemfun caaddr (x) (car (car (cdr (cdr x)))))
  96   (swf-defmemfun cadaar (x) (car (cdr (car (car x)))))
  97   (swf-defmemfun cadadr (x) (car (cdr (car (cdr x)))))
  98   (swf-defmemfun caddar (x) (car (cdr (cdr (car x)))))
  99   (swf-defmemfun cadddr (x) (car (cdr (cdr (cdr x)))))
 100   (swf-defmemfun cdaaar (x) (cdr (car (car (car x)))))
 101   (swf-defmemfun cdaadr (x) (cdr (car (car (cdr x)))))
 102   (swf-defmemfun cdadar (x) (cdr (car (cdr (car x)))))
 103   (swf-defmemfun cdaddr (x) (cdr (car (cdr (cdr x)))))
 104   (swf-defmemfun cddaar (x) (cdr (cdr (car (car x)))))
 105   (swf-defmemfun cddadr (x) (cdr (cdr (car (cdr x)))))
 106   (swf-defmemfun cdddar (x) (cdr (cdr (cdr (car x)))))
 107   (swf-defmemfun cddddr (x) (cdr (cdr (cdr (cdr x)))))
 108
 109
 110   (swf-defmemfun copy-tree (tree)
 111     (if (consp tree)
 112         (cons (copy-tree (car tree)) (copy-tree (cdr tree)))
 113         tree))
 114
 115   ;; fixme: implement pop according to spec
 116   (swf-defmacro pop (a)
 117     (let ((temp (gensym "POP-TEMP-")))
 118       `(progn
 119          (%asm (:comment "pop") (:push-null))
 120          (let ((,temp ,a))
 121            (prog1
 122                (car ,temp)
 123              (setf ,a (cdr ,temp)))))))
 124
 125   ;; fixme: implement PUSH according to spec
 126   (swf-defmacro push (item place)
 127     (let ((temp (gensym "PUSH-TEMP-")))
 128       `(progn
 129         (let ((,temp ,place))
 130           (setf ,place (cons ,item ,temp))))))
 131
 132
 133   (swf-defmemfun first (list) (car list))
 134   (swf-defmemfun second (list) (car (cdr list)))
 135   (swf-defmemfun third (list) (car (cddr list)))
 136   (swf-defmemfun fourth (list) (car (cdddr list)))
 137   (swf-defmemfun fifth (list) (car (cddddr list)))
 138   (swf-defmemfun sixth (list) (car (cdr (cddddr list))))
 139   (swf-defmemfun seventh (list) (car (cddr (cddddr list))))
 140   (swf-defmemfun eighth (list) (car (cdddr (cddddr list))))
 141   (swf-defmemfun ninth (list) (car (cddddr (cddddr list))))
 142   (swf-defmemfun tenth (list) (car (cdr (cddddr (cddddr list)))))
 143
 144
 145   (swf-defmemfun endp (a)
 146     (if (eq a nil)
 147         t
 148         (if (consp a)
 149             nil
 150             (%type-error "ENDP" a))))
 151
 152   (swf-defmemfun null (a)
 153     (eq a nil))
 154
 155 )
 156
 157 #+nil
 158 (dump-defun-asm ()
 159   (nconc (cons 1 2) (cons 3 4)))
 160
 161 #+nil
 162 (format t "~{~S~%~}"
 163         (avm2-asm::avm2-disassemble
 164          (avm2-asm::code
 165           (avm2-asm::with-assembler-context
 166             (avm2-asm::assemble-method-body
 167 (dump-defun-asm (obj)
 168                (let ((sum 0))
 169                  (dolist (a  obj)
 170                    (incf sum a))))
 171              ) ) )))