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" 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           (:get-local-1)
  30           (:get-local-2)
  31           (:construct-prop cons-type 2)))
  32
  33 #||  (def-swf-class cons-type "cons" object (%car %cdr)
  34                  (()
  35                   ))
  36
  37   (swf-defmemfun cons (a b)
  38     (%asm (:find-property-strict cons-type)
  39           (:construct-prop cons-type 0)
  40           (:dup)
  41           (:get-local-1)
  42           (:set-property %car)
  43           (:dup)
  44           (:get-local-2)
  45           (:set-property %cdr)
  46           ))
  47 ||#
  48   (swf-defmemfun consp (a)
  49     (%typep a cons-type))
  50
  51   (swf-defmemfun atom (object)
  52     (not (consp object)))
  53
  54   (swf-defmemfun %type-error (fun arg)
  55     (%error (+ "type-error: unknown type in " fun ":" (%type-of arg))))
  56
  57   #+nil(swf-defmemfun car (a)
  58     (if (eq a :null)
  59         :null
  60         (if (consp a)
  61             (%asm (:get-local-1)
  62                   (:get-property %car))
  63             (%type-error "CAR" a))))
  64
  65   #+nil(swf-defmemfun cdr (a)
  66     (if (eq a :null)
  67         :null
  68         (if (consp a)
  69             (%asm (:get-local-1)
  70                   (:get-property %cdr))
  71             (%type-error "CDR" a))))
  72
  73
  74   (swf-defmemfun car (a)
  75     (if (eq a :null)
  76         :null
  77         (%asm (:get-local-1)
  78               (:get-property %car))))
  79
  80   (swf-defmemfun cdr (a)
  81     (if (eq a :null)
  82         :null
  83         (%asm (:get-local-1)
  84               (:get-property %cdr))))
  85
  86
  87   (swf-defmacro rplaca (cons object)
  88     (let ((temp (gensym "RPLACA-TEMP-")))
  89       `(let ((,temp ,cons))
  90          (progn
  91            (unless (consp ,temp) (%type-error "RPLACA" ,temp))
  92            (%set-property ,temp %car ,object)
  93            ,temp))))
  94
  95   (swf-defmacro rplacd (cons object)
  96     (let ((temp (gensym "REPLACD-TEMP-")))
  97       `(let ((,temp ,cons))
  98          (progn
  99            (unless (consp ,temp) (%type-error "RPLACD" ,temp))
 100            (%set-property ,temp %cdr ,object)
 101            ,temp))))
 102
 103
 104   (swf-defmemfun caar (x) (car (car x)))
 105   (swf-defmemfun cadr (x) (car (cdr x)))
 106   (swf-defmemfun cdar (x) (cdr (car x)))
 107   (swf-defmemfun cddr (x) (cdr (cdr x)))
 108   (swf-defmemfun caaar (x) (car (car (car x))))
 109   (swf-defmemfun caadr (x) (car (car (cdr x))))
 110   (swf-defmemfun cadar (x) (car (cdr (car x))))
 111   (swf-defmemfun caddr (x) (car (cdr (cdr x))))
 112   (swf-defmemfun cdaar (x) (cdr (car (car x))))
 113   (swf-defmemfun cdadr (x) (cdr (car (cdr x))))
 114   (swf-defmemfun cddar (x) (cdr (cdr (car x))))
 115   (swf-defmemfun cdddr (x) (cdr (cdr (cdr x))))
 116   (swf-defmemfun caaaar (x) (car (car (car (car x)))))
 117   (swf-defmemfun caaadr (x) (car (car (car (cdr x)))))
 118   (swf-defmemfun caadar (x) (car (car (cdr (car x)))))
 119   (swf-defmemfun caaddr (x) (car (car (cdr (cdr x)))))
 120   (swf-defmemfun cadaar (x) (car (cdr (car (car x)))))
 121   (swf-defmemfun cadadr (x) (car (cdr (car (cdr x)))))
 122   (swf-defmemfun caddar (x) (car (cdr (cdr (car x)))))
 123   (swf-defmemfun cadddr (x) (car (cdr (cdr (cdr x)))))
 124   (swf-defmemfun cdaaar (x) (cdr (car (car (car x)))))
 125   (swf-defmemfun cdaadr (x) (cdr (car (car (cdr x)))))
 126   (swf-defmemfun cdadar (x) (cdr (car (cdr (car x)))))
 127   (swf-defmemfun cdaddr (x) (cdr (car (cdr (cdr x)))))
 128   (swf-defmemfun cddaar (x) (cdr (cdr (car (car x)))))
 129   (swf-defmemfun cddadr (x) (cdr (cdr (car (cdr x)))))
 130   (swf-defmemfun cdddar (x) (cdr (cdr (cdr (car x)))))
 131   (swf-defmemfun cddddr (x) (cdr (cdr (cdr (cdr x)))))
 132
 133
 134   (swf-defmemfun copy-tree (tree)
 135     (if (consp tree)
 136         (cons (copy-tree (car tree)) (copy-tree (cdr tree)))
 137         tree))
 138
 139   (swf-defmemfun listp (a)
 140     (or (%typep a cons-type) (eq a nil)))
 141
 142   ;; fixme: implement pop according to spec
 143   (swf-defmacro pop (a)
 144     (let ((temp (gensym "POP-TEMP-")))
 145       `(progn
 146          (%asm (:comment "pop") (:push-null))
 147          (let ((,temp ,a))
 148            (prog1
 149                (car ,temp)
 150              (setf ,a (cdr ,temp)))))))
 151
 152   ;; fixme: implement PUSH according to spec
 153   (swf-defmacro push (item place)
 154     (let ((temp (gensym "PUSH-TEMP-")))
 155       `(progn
 156         (let ((,temp ,place))
 157           (setf ,place (cons ,item ,temp))))))
 158
 159
 160   (swf-defmemfun first (list) (car list))
 161   (swf-defmemfun second (list) (car (cdr list)))
 162   (swf-defmemfun third (list) (car (cddr list)))
 163   (swf-defmemfun fourth (list) (car (cdddr list)))
 164   (swf-defmemfun fifth (list) (car (cddddr list)))
 165   (swf-defmemfun sixth (list) (car (cdr (cddddr list))))
 166   (swf-defmemfun seventh (list) (car (cddr (cddddr list))))
 167   (swf-defmemfun eighth (list) (car (cdddr (cddddr list))))
 168   (swf-defmemfun ninth (list) (car (cddddr (cddddr list))))
 169   (swf-defmemfun tenth (list) (car (cdr (cddddr (cddddr list)))))
 170
 171
 172   (swf-defmemfun endp (a)
 173     (if (eq a nil)
 174         t
 175         (if (consp a)
 176             nil
 177             (%type-error "ENDP" a))))
 178
 179   (swf-defmemfun null (a)
 180     (eq a nil))
 181
 182 )
 183
 184 #+nil
 185 (dump-defun-asm ()
 186   (nconc (cons 1 2) (cons 3 4)))
 187
 188 #+nil
 189 (format t "~{~S~%~}"
 190         (avm2-asm::avm2-disassemble
 191          (avm2-asm::code
 192           (avm2-asm::with-assembler-context
 193             (avm2-asm::assemble-method-body
 194 (dump-defun-asm (obj)
 195                (let ((sum 0))
 196                  (dolist (a  obj)
 197                    (incf sum a))))
 198              ) ) )))