/usr/share/acl2-8.0dfsg/books/hacking/defstruct-parsing.lisp is in acl2-books-source 8.0dfsg-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 | (in-package "ACL2-HACKER")
(program)
(set-state-ok t)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; defstruct parsing
;
(defun defstruct-conc-name (name options)
(cond ((endp options)
(string-append (symbol-name name) "-"))
((eq ':conc-name (car options))
"")
((and (consp (car options))
(eq ':conc-name (caar options)))
(let ((arglst (cdar options)))
(if (and (consp arglst)
(symbolp (car arglst))
(car arglst))
(symbol-name (car arglst))
"")))
(t
(defstruct-conc-name name (cdr options)))))
(defun defstruct-constructor-name-lst1 (name options sofar nilseen)
(cond ((endp options)
(cond (sofar
sofar)
(nilseen
nil)
(t
(list (intern-in-package-of-symbol
(string-append "MAKE-" (symbol-name name))
name)))))
((and (consp (car options))
(eq ':constructor (caar options))
(consp (cdar options)))
(cond ((null (cadar options))
(defstruct-constructor-name-lst1 name
(cdr options)
sofar
t))
((symbolp (cadar options))
(defstruct-constructor-name-lst1 name
(cdr options)
(cons (cadar options) sofar)
nilseen))
(t ; bad
(defstruct-constructor-name-lst1 name
(cdr options)
sofar
nilseen))))
(t
(defstruct-constructor-name-lst1 name (cdr options) sofar nilseen))))
(defun defstruct-constructor-name-lst (name options)
(defstruct-constructor-name-lst1 name options nil nil))
(defun defstruct-copier-name-lst1 (name options sofar nilseen)
(cond ((endp options)
(cond (sofar
sofar)
(nilseen
nil)
(t
(list (intern-in-package-of-symbol
(string-append "COPY-" (symbol-name name))
name)))))
((and (consp (car options))
(eq ':copier (caar options))
(consp (cdar options)))
(cond ((null (cadar options))
(defstruct-copier-name-lst1 name
(cdr options)
sofar
t))
((symbolp (cadar options))
(defstruct-copier-name-lst1 name
(cdr options)
(cons (cadar options) sofar)
nilseen))
(t ; bad
(defstruct-copier-name-lst1 name
(cdr options)
sofar
nilseen))))
(t
(defstruct-copier-name-lst1 name (cdr options) sofar nilseen))))
(defun defstruct-copier-name-lst (name options)
(defstruct-copier-name-lst1 name options nil nil))
; :include ignored!
; :initial-offset unimportant
; :named unimportant
(defun defstruct-predicate-name-lst1 (name options sofar nilseen)
(cond ((endp options)
(cond (sofar
sofar)
(nilseen
nil)
(t
(list (intern-in-package-of-symbol
(string-append (symbol-name name) "-P")
name)))))
((and (consp (car options))
(eq ':predicate (caar options))
(consp (cdar options)))
(cond ((null (cadar options))
(defstruct-predicate-name-lst1 name
(cdr options)
sofar
t))
((symbolp (cadar options))
(defstruct-predicate-name-lst1 name
(cdr options)
(cons (cadar options) sofar)
nilseen))
(t ; bad
(defstruct-predicate-name-lst1 name
(cdr options)
sofar
nilseen))))
(t
(defstruct-predicate-name-lst1 name (cdr options) sofar nilseen))))
(defun defstruct-predicate-name-lst (name options)
(defstruct-predicate-name-lst1 name options nil nil))
; :print-function, :print-object unimportant
; :type assumed unimportant
(defun defstruct-accessors (conc-name descs package-of-symbol)
(if (endp descs)
nil
(let* ((desc (car descs))
(name (if (consp desc) (car desc) desc)))
(if (symbolp name)
(cons (if (equal conc-name "")
name
(intern-in-package-of-symbol
(string-append conc-name (symbol-name name))
package-of-symbol))
(defstruct-accessors conc-name (cdr descs) package-of-symbol))
;; bad:
(defstruct-accessors conc-name (cdr descs) package-of-symbol)))))
(defun defstruct-name-and-fns (form)
(if (not (and (consp form)
(eq (car form) 'defstruct)
(consp (cdr form))
(or (symbolp (cadr form))
(and (consp (cadr form))
(symbolp (caadr form))))))
nil
(let* ((name-and-options (cadr form))
(name (if (consp name-and-options)
(car name-and-options)
name-and-options))
(options (if (consp name-and-options)
(cdr name-and-options)
nil))
(slot-descs (if (and (consp (cddr form))
(stringp (caddr form)))
(cdddr form)
(cddr form)))
(conc-name (defstruct-conc-name name options))
(top-fns (append (defstruct-constructor-name-lst name options)
(defstruct-copier-name-lst name options)
(defstruct-predicate-name-lst name options)))
(accessors (defstruct-accessors conc-name slot-descs name)))
(cons name (append top-fns accessors)))))
;
; end of defstruct parsing
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|