dl-list-template 2: electric boogaloo

dl.lisp

(ql:quickload 'adhoc-polymorphic-functions)
(use-package :adhoc-polymorphic-functions)


(deftype ind () `(integer 0 #.array-dimension-limit))

(defparameter *default-impl* (make-hash-table))



(defun %dimensions-comp (dimensions)
  (cond ((eql '* dimensions) 0)
        ((listp dimensions) (mapcar (lambda (x) (if (eql '* x) 0 x)) dimensions))
        (t dimensions)))


(defun default (type &optional environment)
  (multiple-value-bind (item knownp) (gethash type *default-impl*)
    (if knownp
        item
        (progn
          (setf type (sb-ext:typexpand type environment))
          (if (symbolp type)
              (case type
                ((bit fixnum integer rational) 0)
                ((float double-float single-float long-float real) 0.0)
                ((number complex) #c(0 0))
                ((character base-char) #\Nul)
                (standard-char #\a)
                ((symbol t) t)
                (keyword :t)
                (hash-table `(make-hash-table))
                ((list boolean atom null) nil)
                (pathname #P"")
                (function '(lambda (&rest args)
                            (declare (ignore args)
                             (optimize (speed 3) (safety 0) (debug 0) (space 0) (compilation-speed 0)))))
                (vector '(make-array 0 :adjustable t))
                (bit-vector '(make-array 0 :element-type 'bit :adjustable t))
                (string '(make-array 0 :element-type 'character :adjustable t :initial-element #\Nul))
                (simple-array (make-array 0)) ;;Maybe it should error here, since array dimension is nto specified?
                ;;What happens with just array? Or just sequence? I guess nothing
                (simple-string '(make-array 0 :element-type 'character :initial-element #\Nul))
                (simple-base-string '(make-array 0 :element-type 'base-char :initial-element #\Nul))
                (otherwise
                 (cond ((subtypep type 'structure-object environment)
                        (list (intern (concatenate 'string "MAKE-" (string type)))))
                       ((subtypep type 'standard-object environment)
                        `(make-instance ,type)))))
              (destructuring-bind (main . rest) type
                (case main
                  ((mod unsigned-byte singned-byte) 0)
                  ((integer eql member rational real float) (first rest))
                  (complex `(complex ,(default (first rest)) ,(default (first rest))))
                  (cons `(cons ,(default (first rest)) ,(default (first rest))))
                  (or (default (first rest)))
                  (vector `(make-array ',(if (= 2 (length rest))
                                             (%dimensions-comp (second rest))
                                             0)
                                       :adjustable t
                                       :element-type ',(or (first rest) t)
                                       :initial-element ,(if (first rest)
                                                             (default (first rest))
                                                             0)))
                  (bit-vector `(make-array ,(or (first rest) 0) :element-type 'bit :adjustable t))
                  (string `(make-array ',(if (= 2 (length rest))
                                             (%dimensions-comp (second rest))
                                             0)
                                       :element-type 'character
                                       :adjustable t
                                       :initial-element #\Nul))
                  (simple-array `(make-array ',(if (= 2 (length rest))
                                                   (%dimensions-comp (second rest))
                                                   0)
                                             :element-type ',(or (first rest) t)
                                             :initial-element ,(if (first rest)
                                                                   (default (first rest))
                                                                   0)))
                  (simple-string `(make-array ',(if (= 2 (length rest))
                                                    (%dimensions-comp (second rest))
                                                    0)
                                              :element-type 'character
                                              :initial-element #\Nul))
                  (simple-base-string `(make-array ',(if (= 2 (length rest))
                                                         (%dimensions-comp (second rest))
                                                         0)
                                                   :element-type 'base-char
                                                   :initial-element #\Nul))

                  (array `(make-array ',(if (= 2 (length rest))
                                            (%dimensions-comp (second rest))
                                            0)
                                      :element-type ',(or (first rest) t)
                                      :initial-element ,(if (first rest)
                                                            (default (first rest))
                                                            0))))))))))



(defparameter *paramterize-name* (make-hash-table :test #'equalp))

(defparameter *unparamterize-name* (make-hash-table :test #'equalp))


(define-polymorphic-function push-front (data container))
(define-polymorphic-function push-back (data container))
(define-polymorphic-function pop-front (container))
(define-polymorphic-function pop-back (container))
(define-polymorphic-function size (container))
(define-polymorphic-function empty-p (container))


(define-polymorphic-function prev (node) :overwrite t)
(define-polymorphic-function data (node) :overwrite t)
(define-polymorphic-function next (node) :overwrite t)

(define-polymorphic-function (setf prev) (new node) :overwrite t)
(define-polymorphic-function (setf data) (data node) :overwrite t)
(define-polymorphic-function (setf next) (new node) :overwrite t)

(define-polymorphic-function anchor (container) :overwrite t)
;(define-polymorphic-function node () :overwrite t)


(defun ensure-dl-list (type &optional (default (default type)))
  (eval `(define-double-linked-list ,type ,default)))

(defmacro define-double-linked-list (type &optional (default (default type)))
  (unless (gethash (cons 'dl-list (if (listp type) type (list type))) *unparamterize-name*)
    (let* ((node-type (cons 'dl-node (if (listp type) type (list type))))
           (dl-type  (cons 'dl-list (if (listp type) type (list type))))
           (node-code (gentemp "NODE"))
           (dl-code (gentemp "DL")))
      `(progn
         (eval-when (:compile-toplevel :load-toplevel :execute)
           (defstruct ,node-code
             (prev nil :type (or ,node-code null))
             (data ,default :type ,type)
             (next nil :type (or ,node-code null)))


           (defstruct ,dl-code
             (anchor (,(intern (format nil "MAKE-~s" node-code))) :type ,node-code))

           (setf (gethash ',node-type *unparamterize-name*) ',node-code
                 (gethash ',dl-type *unparamterize-name*) ',dl-code)


           (defpolymorph prev ((node ,node-code)) (or ,node-code null)
                         (,(intern (format nil "~s-PREV" node-code)) node))
           (defpolymorph data ((node ,node-code)) ,type
                         (,(intern (format nil "~s-DATA" node-code)) node))
           (defpolymorph next ((node ,node-code)) (or ,node-code null)
                         (,(intern (format nil "~s-NEXT" node-code)) node))
           (defpolymorph (setf prev) ((new ,node-code) (node ,node-code)) ,node-code
                         (setf (,(intern (format nil "~s-PREV" node-code)) node) new))
           (defpolymorph (setf data) ((new ,type) (node ,node-code)) ,type
                         (setf (,(intern (format nil "~s-DATA" node-code)) node) new))
           (defpolymorph (setf next) ((new ,node-code) (node ,node-code)) ,node-code
                         (setf (,(intern (format nil "~s-NEXT" node-code)) node) new))
           (defpolymorph anchor ((container ,dl-code)) ,node-code
                         (,(intern (format nil "~s-ANCHOR" dl-code)) container))

           (defmethod print-object ((dl ,dl-code) stream)
             (loop :initially (format stream "#D(")
                   :with node := (anchor dl)
                   :for next := (next node) :then (next next)
                   :until (eq next node)
                   :do (format stream "~s " (data next))
                   :finally (format stream ")")))

           (defpolymorph push-front ((data ,type) (dl-list ,dl-code)) ,type
                         (let* ((anchor (anchor dl-list))
                                (current (next anchor))
                                (new-node (,(intern (format nil "MAKE-~s" node-code))
                                            :data data :prev anchor :next current)))
                           (setf (prev current) new-node
                                 (next anchor) new-node)
                           data)))))))

(deftype dl-list (typename) (gethash (cons 'dl-list
                                           (if (listp typename) typename (list typename)))
                                     *unparamterize-name*))


(defun dl-list (type)
  (unless (gethash (cons 'dl-list (if (listp type) type (list type))) *unparamterize-name*)
    (ensure-dl-list type))
  (let* ((res (funcall (intern
                        (format nil "MAKE-~s"
                                (gethash (cons 'dl-list
                                               (if (listp type) type (list type)))
                                         *unparamterize-name*)))))
         (anchor (anchor res)))
    (setf (prev anchor) anchor
          (next anchor) anchor)
    res))


(define-compiler-macro dl-list (type)
  (let ((type (eval type))
        (res (gensym "RES"))
        (anchor (gensym "ANCHOR")))
    (unless (gethash (cons 'dl-list (if (listp type) type (list type))) *unparamterize-name*)
      (ensure-dl-list type))
    `(let* ((,res (,(intern
                     (format nil "MAKE-~s" (gethash (cons 'dl-list
                                                          (if (listp type) type (list type)))
                                                    *unparamterize-name*)))))
            (,anchor (anchor ,res)))
       (setf (prev ,anchor) ,anchor
             (next ,anchor) ,anchor)
       ,res)))