File: list-of.lisp

package info (click to toggle)
cl-asdf-finalizers 20170403-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 104 kB
  • ctags: 46
  • sloc: lisp: 294; makefile: 13
file content (80 lines) | stat: -rw-r--r-- 2,995 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
#+xcvb (module (:depends-on ("initialization")))

(defpackage :list-of
  (:use :cl :asdf-finalizers)
  (:export
   #:list-of
   #:vector-of))

(in-package :list-of)

(defun sequence-of-predicate-for (type &optional (sequence-type 'list))
  (with-standard-io-syntax
    (let ((*package* (find-package :list-of)))
      (intern (format nil "~S-OF-~S-P" sequence-type type) :list-of))))

(defun list-of-predicate-for (type)
  (sequence-of-predicate-for type 'list))

(defun vector-of-predicate-for (type)
  (sequence-of-predicate-for type 'vector))

(defun list-of-type-predicate (type)
  #'(lambda (x)
      (loop :for c = x :then (cdr c) :while (consp c) :always (typep (car c) type)
	    :finally (return (null c)))))

(defun vector-of-type-predicate (type)
  #'(lambda (x)
      (and (typep x 'vector)
           (every #'(lambda (e) (typep e type)) x))))

(defun ensure-list-of-predicate (type &optional predicate)
  (unless predicate
    (setf predicate (list-of-predicate-for type)))
  (check-type predicate symbol)
  (unless (fboundp predicate)
    (setf (symbol-function predicate) (list-of-type-predicate type)))
  nil)

(defun ensure-vector-of-predicate (type &optional predicate)
  (unless predicate
    (setf predicate (vector-of-predicate-for type)))
  (check-type predicate symbol)
  (unless (fboundp predicate)
    (setf (symbol-function predicate) (vector-of-type-predicate type)))
  nil)

(deftype list-of (type)
  (case type
    ((t) 'list) ;; a (list-of t) is the same as a regular list.
    ((nil) 'null) ;; a (list-of nil) can have no elements, it's null.
    (otherwise
     (let ((predicate (list-of-predicate-for type)))
       (eval-at-toplevel ;; now, and amongst final-forms if enabled
	`(ensure-list-of-predicate ',type ',predicate)
	`(fboundp ',predicate) ;; hush unnecessary eval-at-toplevel warnings
	"Defining ~S outside of finalized Lisp code" `(list-of ,type))
       `(and list (satisfies ,predicate))))))

(deftype vector-of (type)
  (let ((spec-type (upgraded-array-element-type type)))
    (if (equal type spec-type)
        `(vector ,spec-type)
        (let ((predicate (vector-of-predicate-for type)))
          (eval-at-toplevel ;; now, and amongst final-forms if enabled
           `(ensure-vector-of-predicate ',type ',predicate)
           `(fboundp ',predicate) ;; hush unnecessary eval-at-toplevel warnings
           "Defining ~S outside of finalized Lisp code" `(vector-of ,type))
          `(and (vector ,spec-type) (satisfies ,predicate))))))

;; These are available in case you prefer to explicitly call declare-list-of and
;; declare-vector-of in your code-base rather than rely on finalizers.
;; They are not exported because we do not encourage it, but you can import them.
(defmacro declare-list-of (type)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (ensure-list-of-predicate ',type)))

(defmacro declare-vector-of (type)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (ensure-vector-of-predicate ',type)))