lib/cl-conses2.lisp

   1 (in-package #:avm2-compiler)
   2
   3 ;;; higher level functions from conses dictionary
   4 ;;; (mainly things that need iteration constructs)
   5 ;;;
   6 ;;; not all match CL semantics very closely yet...
   7
   8 (let ((*symbol-table* *cl-symbol-table*))
   9
  10   ;; Function SUBLIS, NSUBLIS
  11
  12   ;; Function SUBST, SUBST-IF, SUBST-IF-NOT, NSUBST, NSUBST-IF, NSUBST-IF-NOT
  13
  14   ;; Function TREE-EQUAL
  15
  16   ;; fixme: write iterative version of copy-list
  17   (swf-defmemfun copy-list (list)
  18     (%flet (do-copy (list)
  19              (if (consp list)
  20                  (cons (car list) (do-copy (cdr list)))
  21                  list))
  22       (if (not (listp list))
  23           (%type-error "COPY-LIST" list)
  24           (call-%flet do-copy list))))
  25
  26   (swf-defmemfun list (&arest rest)
  27     (let ((list nil)
  28           (length (%get-property rest :length)))
  29       (dotimes (i length list)
  30         (push (%aref-1 rest (- length i 1)) list))))
  31
  32   (swf-defmemfun list* (&arest rest)
  33     (when (zerop (%get-property rest :length))
  34       (%error "not enough arguments"))
  35     (let* ((length (%get-property rest :length))
  36            (list (%aref-1 rest (1- length))))
  37       (dotimes (i (1- length) list)
  38         (push (%aref-1 rest (- length i 2)) list))))
  39
  40
  41
  42
  43   (swf-defmemfun list-length (list)
  44     (if (endp list)
  45         0
  46         (let ((fast list)
  47               (length 0))
  48           (dolist (slow list)
  49             (when (endp fast) (return length))
  50             (when (endp (cdr fast)) (return  (+ length 1)))
  51             (when (and (eq fast slow) (> length 0)) (return nil))
  52             (incf length 2)
  53             (setf fast (cddr fast))))))
  54
  55   ;; LISTP
  56   (swf-defmemfun listp (a)
  57     (or (%typep a cons-type) (eq a nil)))
  58
  59
  60   ;; Function MAKE-LIST
  61
  62   ;; PUSH, POP in cl-conses
  63
  64   ;; FIRST - TENTH in cl-conses
  65
  66   (swf-defmemfun nth (n list)
  67     (car (dotimes (x n list)
  68            (setf list (cdr list)))))
  69
  70   ;; ENDP, NULL in cl-conses
  71   (swf-defmemfun nconc (&arest lists)
  72     (let* ((a (if (zerop (slot-value lists '%flash:length))
  73                  nil
  74                  (%aref-1 lists 0)))
  75           (end (last a)))
  76       (dotimes (i (1- (slot-value lists '%flash:length)) a)
  77         (let ((next (%aref-1 lists (1+ i))))
  78           (rplacd (last end) next)
  79           (setf end next)))))
  80
  81   ;;Function APPEND
  82
  83   ;;Function REVAPPEND, NRECONC
  84
  85   ;;Function BUTLAST, NBUTLAST
  86
  87   ;; fixme: add optional count arg
  88   (swf-defmemfun last (a)
  89       (if (endp a)
  90           nil
  91           (tagbody
  92            :start
  93              (unless (consp (cdr a))
  94                (return-from last a))
  95              (setf a (cdr a))
  96              (go :start))))
  97
  98   ;;Function LDIFF, TAILP
  99
 100   ;;Function NTHCDR
 101   (swf-defmemfun nthcdr (n list)
 102     (dotimes (a n list)
 103       (setf list (cdr list))))
 104
 105   (swf-defmemfun rest (a)
 106     (cdr a))
 107
 108   ;;Function MEMBER, MEMBER-IF, MEMBER-IF-NOT
 109
 110   ;;Function MAPC, MAPCAR, MAPCAN, MAPL, MAPLIST, MAPCON
 111
 112   ;;Function ACONS
 113
 114   ;;Function ASSOC, ASSOC-IF, ASSOC-IF-NOT
 115
 116   ;;Function COPY-ALIST
 117
 118   ;;Function PAIRLIS
 119
 120   ;;Function RASSOC, RASSOC-IF, RASSOC-IF-NOT
 121
 122   ;;Function GET-PROPERTIES
 123
 124   ;;Accessor GETF
 125
 126   ;;Macro REMF
 127
 128   ;;Function INTERSECTION, NINTERSECTION
 129
 130   ;;Function ADJOIN
 131
 132   ;;Macro PUSHNEW
 133
 134   ;;Function SET-DIFFERENCE, NSET-DIFFERENCE
 135
 136   ;;Function SET-EXCLUSIVE-OR, NSET-EXCLUSIVE-OR
 137
 138   ;;Function SUBSETP
 139
 140   ;;Function UNION, NUNION
 141
 142   ;;misc
 143
 144   (swf-defmacro %reverse-list (list)
 145     `(let ((reversed nil))
 146       (dolist (value ,list reversed)
 147         (push value reversed))))
 148
 149   ;; macro due to lack of &key in functions
 150   (swf-defmacro %reduce-list (function sequence &key key from-end (start 0) end (initial-value nil initial-value-p))
 151     `(let* ((list (if ,from-end
 152                       (nthcdr ,start (%reverse-list ,sequence))
 153                       (nthcdr ,start ,sequence)))
 154             (count 0)
 155             (result (cond
 156                       ((,initial-value-p) ,initial-value)
 157                       ((null list) (%funcall ,function nil))
 158                       (t (prog1
 159                              (car list)
 160                            (incf count)
 161                            (setf list (cdr list)))))))
 162        (dolist (a list result)
 163          (when (>= count ,end) (return result))
 164          (setf result (if ,key
 165                           (%funcall ,function nil result (%funcall ,key a))
 166                           (%funcall ,function nil result a))))))
 167
 168
 169 )