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-defun atom (object)
  52     (not (consp object)))
  53
  54   (swf-defun %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-defun caar (x) (car (car x)))
 105   (swf-defun cadr (x) (car (cdr x)))
 106   (swf-defun cdar (x) (cdr (car x)))
 107   (swf-defun cddr (x) (cdr (cdr x)))
 108   (swf-defun caaar (x) (car (car (car x))))
 109   (swf-defun caadr (x) (car (car (cdr x))))
 110   (swf-defun cadar (x) (car (cdr (car x))))
 111   (swf-defun caddr (x) (car (cdr (cdr x))))
 112   (swf-defun cdaar (x) (cdr (car (car x))))
 113   (swf-defun cdadr (x) (cdr (car (cdr x))))
 114   (swf-defun cddar (x) (cdr (cdr (car x))))
 115   (swf-defun cdddr (x) (cdr (cdr (cdr x))))
 116   (swf-defun caaaar (x) (car (car (car (car x)))))
 117   (swf-defun caaadr (x) (car (car (car (cdr x)))))
 118   (swf-defun caadar (x) (car (car (cdr (car x)))))
 119   (swf-defun caaddr (x) (car (car (cdr (cdr x)))))
 120   (swf-defun cadaar (x) (car (cdr (car (car x)))))
 121   (swf-defun cadadr (x) (car (cdr (car (cdr x)))))
 122   (swf-defun caddar (x) (car (cdr (cdr (car x)))))
 123   (swf-defun cadddr (x) (car (cdr (cdr (cdr x)))))
 124   (swf-defun cdaaar (x) (cdr (car (car (car x)))))
 125   (swf-defun cdaadr (x) (cdr (car (car (cdr x)))))
 126   (swf-defun cdadar (x) (cdr (car (cdr (car x)))))
 127   (swf-defun cdaddr (x) (cdr (car (cdr (cdr x)))))
 128   (swf-defun cddaar (x) (cdr (cdr (car (car x)))))
 129   (swf-defun cddadr (x) (cdr (cdr (car (cdr x)))))
 130   (swf-defun cdddar (x) (cdr (cdr (cdr (car x)))))
 131   (swf-defun cddddr (x) (cdr (cdr (cdr (cdr x)))))
 132
 133
 134   (swf-defun 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   (swf-defmemfun endp (a)
 143     (if (eq a nil)
 144         t
 145         (if (consp a)
 146             nil
 147             (%type-error "ENDP" a))))
 148
 149   ;; fixme: implement pop according to spec
 150   (swf-defmacro pop (a)
 151     (let ((temp (gensym "POP-TEMP-")))
 152       `(progn
 153          (%asm (:comment "pop") (:push-null))
 154          (let ((,temp ,a))
 155            (prog1
 156                (car ,temp)
 157              (%set-local ,a (cdr ,temp)))))))
 158
 159   ;; fixme: implement PUSH according to spec
 160   (swf-defmacro push (item place)
 161     (let ((temp (gensym "PUSH-TEMP-")))
 162       `(progn
 163         (let ((,temp ,place))
 164           (%set-local ,place (cons ,item ,temp))))))
 165
 166
 167   (swf-defun first (list) (car list))
 168   (swf-defun second (list) (car (cdr list)))
 169   (swf-defun third (list) (car (cddr list)))
 170   (swf-defun fourth (list) (car (cdddr list)))
 171   (swf-defun fifth (list) (car (cddddr list)))
 172   (swf-defun sixth (list) (car (cdr (cddddr list))))
 173   (swf-defun seventh (list) (car (cddr (cddddr list))))
 174   (swf-defun eighth (list) (car (cdddr (cddddr list))))
 175   (swf-defun ninth (list) (car (cddddr (cddddr list))))
 176   (swf-defun tenth (list) (car (cdr (cddddr (cddddr list)))))
 177
 178 )