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-defun list-length (list)
  44     (let ((fast list)
  45           (length 0))
  46       (dolist (slow list)
  47         (when (endp fast) (return  length))
  48         (when (endp (cdr fast)) (return  (+ length 1)))
  49         (when (and (eq fast slow) (> length 0)) (return nil))
  50         (setf fast (cddr fast)))))
  51
  52   ;; LISTP
  53   (swf-defmemfun listp (a)
  54     (or (%typep a cons-type) (eq a nil)))
  55
  56
  57   ;; Function MAKE-LIST
  58
  59   ;; PUSH, POP in cl-conses
  60
  61   ;; FIRST - TENTH in cl-conses
  62
  63   (swf-defmemfun nth (n list)
  64     (car (dotimes (x n list)
  65            (setf list (cdr list)))))
  66
  67   ;; ENDP, NULL in cl-conses
  68   (swf-defmemfun nconc (&arest lists)
  69     (let* ((a (if (zerop (slot-value lists '%flash:length))
  70                  nil
  71                  (%aref-1 lists 0)))
  72           (end (last a)))
  73       (dotimes (i (1- (slot-value lists '%flash:length)) a)
  74         (let ((next (%aref-1 lists (1+ i))))
  75           (rplacd (last end) next)
  76           (setf end next)))))
  77
  78   ;;Function APPEND
  79
  80   ;;Function REVAPPEND, NRECONC
  81
  82   ;;Function BUTLAST, NBUTLAST
  83
  84   ;; fixme: add optional count arg
  85   (swf-defmemfun last (a)
  86       (if (endp a)
  87           nil
  88           (tagbody
  89            :start
  90              (unless (consp (cdr a))
  91                (return-from last a))
  92              (setf a (cdr a))
  93              (go :start))))
  94
  95   ;;Function LDIFF, TAILP
  96
  97   ;;Function NTHCDR
  98   (swf-defmemfun nthcdr (n list)
  99     (dotimes (a n list)
 100       (setf list (cdr list))))
 101
 102   (swf-defmemfun rest (a)
 103     (cdr a))
 104
 105   ;;Function MEMBER, MEMBER-IF, MEMBER-IF-NOT
 106
 107   ;;Function MAPC, MAPCAR, MAPCAN, MAPL, MAPLIST, MAPCON
 108
 109   ;;Function ACONS
 110
 111   ;;Function ASSOC, ASSOC-IF, ASSOC-IF-NOT
 112
 113   ;;Function COPY-ALIST
 114
 115   ;;Function PAIRLIS
 116
 117   ;;Function RASSOC, RASSOC-IF, RASSOC-IF-NOT
 118
 119   ;;Function GET-PROPERTIES
 120
 121   ;;Accessor GETF
 122
 123   ;;Macro REMF
 124
 125   ;;Function INTERSECTION, NINTERSECTION
 126
 127   ;;Function ADJOIN
 128
 129   ;;Macro PUSHNEW
 130
 131   ;;Function SET-DIFFERENCE, NSET-DIFFERENCE
 132
 133   ;;Function SET-EXCLUSIVE-OR, NSET-EXCLUSIVE-OR
 134
 135   ;;Function SUBSETP
 136
 137   ;;Function UNION, NUNION
 138
 139   ;;misc
 140
 141   (swf-defmacro %reverse-list (list)
 142     `(let ((reversed nil))
 143       (dolist (value ,list reversed)
 144         (push value reversed))))
 145
 146   ;; macro due to lack of &key in functions
 147   (swf-defmacro %reduce-list (function sequence &key key from-end (start 0) end (initial-value nil initial-value-p))
 148     `(let* ((list (if ,from-end
 149                       (nthcdr ,start (%reverse-list ,sequence))
 150                       (nthcdr ,start ,sequence)))
 151             (count 0)
 152             (result (cond
 153                       ((,initial-value-p) ,initial-value)
 154                       ((null list) (%funcall ,function nil))
 155                       (t (prog1
 156                              (car list)
 157                            (incf count)
 158                            (setf list (cdr list)))))))
 159        (dolist (a list result)
 160          (when (>= count ,end) (return result))
 161          (setf result (if ,key
 162                           (%funcall ,function nil result (%funcall ,key a))
 163                           (%funcall ,function nil result a))))))
 164
 165
 166 )