├── COPYRIGHT ├── README.org ├── ckr-tables.asd ├── extend-match.lisp ├── lisp-critic.asd ├── lisp-critic.lisp ├── lisp-rules.lisp ├── tables.lisp └── write-wrap.lisp /COPYRIGHT: -------------------------------------------------------------------------------- 1 | Licence: MIT Licence 2 | Author: Chris Riesbeck 3 | 4 | Permission is hereby granted, free of charge, to any person obtaining 5 | a copy of this software and associated documentation files (the "Software"), 6 | to deal in the Software without restriction, including without limitation 7 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 8 | and/or sell copies of the Software, and to permit persons to whom the 9 | Software is furnished to do so, subject to the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 15 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 18 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 19 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 20 | OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * LISP-CRITIC - A Lisp code critiquing package. 2 | 3 | see https://courses.cs.northwestern.edu/325/exercises/critic.php#critic 4 | 5 | - Author: Chris Riesbeck 6 | - Licence: MIT Licence 7 | Permission is hereby granted, free of charge, to any person obtaining 8 | a copy of this software and associated documentation files (the "Software"), 9 | to deal in the Software without restriction, including without limitation 10 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 11 | and/or sell copies of the Software, and to permit persons to whom the 12 | Software is furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included 15 | in all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 18 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 20 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 21 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 22 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 23 | OTHER DEALINGS IN THE SOFTWARE. 24 | 25 | Load: 26 | #+BEGIN_SRC lisp 27 | (asdf:load-system :lisp-critic) 28 | #+END_SRC 29 | Example call: 30 | #+BEGIN_SRC lisp 31 | (critique 32 | (defun count-a (lst) 33 | (setq n 0) 34 | (dolist (x lst) 35 | (if (equal x 'a) 36 | (setq n (+ n 1)))) 37 | n)) 38 | #+END_SRC 39 | 40 | Example output: 41 | #+BEGIN_EXAMPLE 42 | ---------------------------------------------------------------------- 43 | 44 | SETS-GLOBALS: GLOBALS!! Don't use global variables, i.e., N N 45 | ---------------------------------------------------------------------- 46 | 47 | DOLIST-SETF: Don't use SETQ inside DOLIST to accumulate values for N. 48 | Use DO. Make N a DO variable and don't use SETQ etc at all. 49 | ---------------------------------------------------------------------- 50 | 51 | USE-EQL: Unless something special is going on, use EQL, not EQUAL. 52 | ---------------------------------------------------------------------- 53 | 54 | X-PLUS-1: Don't use (+ N 1), use (1+ N) for its value or (INCF N) to 55 | change N, whichever is appropriate here. 56 | ---------------------------------------------------------------------- 57 | #+END_EXAMPLE 58 | 59 | See the lisp-critic.lisp file for more information. 60 | To load LISP-CRITIC to the REPL, Type (USE-PACKAGE :LISP-CRITIC). 61 | 62 | To run the Lisp Critic on an entire file of code: 63 | #+BEGIN_SRC lisp 64 | (critique-file pathname) 65 | #+END_SRC lisp 66 | 67 | For example, 68 | #+BEGIN_SRC lisp 69 | (critique-file "~/riesbeck/cs325/chap9-exs.lisp") 70 | #+END_SRC lisp 71 | -------------------------------------------------------------------------------- /ckr-tables.asd: -------------------------------------------------------------------------------- 1 | (in-package #:asdf-user) 2 | 3 | (defsystem "ckr-tables" 4 | :description "A utility library to ease the use of hash-tables" 5 | :author "Chris Riesbeck" 6 | :maintainer "CHIBA Masaomi" 7 | :version "1.0" 8 | :license "MIT License" 9 | :components ((:file "tables"))) 10 | -------------------------------------------------------------------------------- /extend-match.lisp: -------------------------------------------------------------------------------- 1 | ;;;-*- Mode: Lisp; Package: EXTEND-MATCH -*- 2 | 3 | ;;; Updates: 4 | ;;; 5 | ;;; 10/11/2011 Added a warning about ?name as a pattern [CKR] 6 | ;;; 1/24/2006 Changed EQL to EQUAL in PAT-MATCH to handle strings [CKR] 7 | ;;; 1/21/2005 Changed to store extensions by name string, not symbols [CKR] 8 | ;;; 1/21/2005 Changed package to be Franz "modern" compatible [CKR] 9 | ;;; 3/5/2001 Add listp check to match-segment-extension. [CKR] 10 | 11 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 | ;;; Extensible Pattern Matcher 13 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 14 | 15 | ;;; See 16 | ;;; 17 | ;;; https://courses.cs.northwestern.edu/325/readings/extend-pat.php 18 | ;;; 19 | ;;; for information. 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | ;;; Packages 23 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 24 | 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 | ;;; Module Dependencies 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | 29 | (cl:defpackage #:extend-match 30 | (:use #:common-lisp) 31 | (:export #:pat-match #:bind-variable #:add-extension #:instantiate-pattern) 32 | ) 33 | 34 | (in-package #:extend-match) 35 | 36 | 37 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 38 | ;;; Design note: 39 | ;;; 40 | ;;; Technically, we could treat any list of the form (name ...) 41 | ;;; where name is in a pattern extension table as a pattern extension. 42 | ;;; This however would mean that 43 | ;;; 44 | ;;; - misspelling the name of a pattern extension would cause 45 | ;;; a match failure, but no error message, and 46 | ;;; - unintentionally using the name of a pattern extension 47 | ;;; would cause unexpected match results 48 | ;;; - later definition of extensions could break previously 49 | ;;; working patterns 50 | ;;; 51 | ;;; Therefore, all pattern extension names must start with 52 | ;;; a question mark (?) and anything starting with a question 53 | ;;; mark is presumed to be a pattern extension. 54 | 55 | 56 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 57 | ;;; Global variables 58 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 59 | 60 | (defvar *known-pattern-types* '(:single :segment :none)) 61 | 62 | 63 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 | ;;; Variable name stuff 65 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 66 | 67 | (defconstant var-prefix 68 | (if (boundp 'var-prefix) 69 | (symbol-value 'var-prefix) 70 | "?")) 71 | 72 | (defun pat-var-p (form) 73 | (or (single-pat-var-p form) 74 | (segment-pat-var-p form))) 75 | 76 | (defun single-pat-var-p (form) 77 | (and (consp form) 78 | (eql (pat-function (first form)) 'match-variable))) 79 | 80 | (defun segment-pat-var-p (form) 81 | (and (consp form) 82 | (eql (pat-function (first form)) 'match-segment-variable))) 83 | 84 | (defun pat-var-name (pat) (second pat)) 85 | 86 | (defun var-type-name-p (pat) 87 | (and (symbolp pat) 88 | (prefix-p var-prefix (symbol-name pat)))) 89 | 90 | (defun prefix-p (seq1 seq2 &key (test #'eql)) 91 | (and (<= (length seq1) (length seq2)) 92 | (every test seq1 seq2))) 93 | 94 | 95 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 96 | ;;; Extension tables 97 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 98 | 99 | (defvar *pattern-types* (make-hash-table :test 'equal)) 100 | (defvar *pattern-functions* (make-hash-table :test 'equal)) 101 | 102 | (defun pat-function (name) 103 | (and (symbolp name) 104 | (gethash (symbol-name name) *pattern-functions*))) 105 | 106 | (defsetf pat-function (name) (value) 107 | `(setf (gethash (symbol-name ,name) *pattern-functions*) 108 | ,value)) 109 | 110 | (defun pat-type (name) 111 | (and (symbolp name) 112 | (gethash (symbol-name name) *pattern-types*))) 113 | 114 | (defsetf pat-type (name) (value) 115 | `(setf (gethash (symbol-name ,name) *pattern-types*) 116 | ,value)) 117 | 118 | (defun add-extension (name type function) 119 | (unless (var-type-name-p name) 120 | (error "Not a valid variable type name: ~S" name)) 121 | (unless (member type *known-pattern-types*) 122 | (error "Not a valid extension type: ~S" type)) 123 | 124 | (let ((old-type (pat-type name))) 125 | (unless (or (null old-type) 126 | (eql old-type type)) 127 | (warn "Redefining ~A pattern extension ~S as ~A" 128 | old-type name type))) 129 | (setf (pat-type name) type) 130 | (setf (pat-function name) function)) 131 | 132 | (defun pat-extension-p (pat) 133 | (and (consp pat) 134 | (var-type-name-p (first pat)))) 135 | 136 | (defun segment-pat-extension-p (pat) 137 | (and (consp pat) 138 | (eql (pat-type (first pat)) :segment))) 139 | 140 | 141 | 142 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 | ;;; The matcher 144 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 145 | 146 | (defun pat-match (pat form &optional (blists '(nil))) 147 | (cond ((null blists) nil) 148 | ((pat-extension-p pat) 149 | (match-extension pat form blists)) 150 | ((var-type-name-p pat) 151 | (warn "Undefined pattern form ~S" pat)) 152 | ((equal pat form) blists) 153 | ((atom pat) nil) 154 | ((segment-pat-extension-p (first pat)) 155 | (match-segment-extension pat form blists)) 156 | ((atom form) nil) 157 | (t (pat-match (cdr pat) (cdr form) 158 | (pat-match (car pat) (car form) blists))))) 159 | 160 | (defun match-extension (pat form blists) 161 | (let ((fn (pat-function (first pat)))) 162 | (when (null fn) 163 | (warn "Undefined pattern extension ~S" pat)) 164 | (case (pat-type (first pat)) 165 | (:single (funcall fn (rest pat) form blists)) 166 | (:none (funcall fn (rest pat) blists))))) 167 | 168 | (defun match-segment-extension (pats form blists) 169 | (and (listp form) 170 | (let ((pat (first pats)) 171 | (rest-pats (rest pats))) 172 | (let ((fn (pat-function (first pat)))) 173 | (when (null fn) 174 | (warn "Undefined pattern extension ~S" pat)) 175 | (funcall fn (rest pat) rest-pats form blists))))) 176 | 177 | 178 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 | ;;; Instantiating patterns 180 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 181 | 182 | ;;; More complex than in pat-match.lisp, because we have two 183 | ;;; kinds of variables and variables are not simple symbols. 184 | 185 | (defun instantiate-pattern (form blist) 186 | (cond ((pat-var-p form) (instantiate-var form blist)) 187 | ((atom form) form) 188 | (t (instantiate-cons form blist)))) 189 | 190 | (defun instantiate-cons (form blist) 191 | (let ((inst-first (instantiate-pattern (first form) blist)) 192 | (inst-rest (instantiate-pattern (rest form) blist))) 193 | (cond ((segment-pat-var-p (first form)) 194 | (append inst-first inst-rest)) 195 | (t (cons inst-first inst-rest))))) 196 | 197 | (defun instantiate-var (form blist) 198 | (let ((binding (get-binding (pat-var-name form) blist))) 199 | (cond ((null binding) form) 200 | (t (binding-value binding))))) 201 | 202 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 203 | ;;; Binding stuff 204 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 205 | 206 | ;;; Exactly the same as in pat-match.lisp 207 | 208 | (defun bind-variable (name input blists) 209 | (cond ((null blists) nil) 210 | ((null name) blists) 211 | ((null (rest blists)) 212 | (extend-bindings name input blists)) 213 | (t (mapcan #'(lambda (blist) 214 | (copy-list 215 | (extend-bindings name input (list blist)))) 216 | blists)))) 217 | 218 | (defun extend-bindings (name input blists) 219 | (let ((binding (get-binding name (first blists)))) 220 | (cond ((null binding) 221 | (add-binding name input blists)) 222 | ((equal (binding-value binding) input) 223 | blists) 224 | (t nil)))) 225 | 226 | (defun get-binding (name bindings) 227 | (assoc name bindings)) 228 | 229 | (defun add-binding (name input blists) 230 | (list (acons name input (first blists)))) 231 | 232 | (defun binding-variable (binding) (first binding)) 233 | 234 | (defun binding-value (binding) (rest binding)) 235 | 236 | 237 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 238 | ;;; Pattern extensions 239 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 240 | 241 | ;;; Usage: (? [name]). (?) is for anonymous matching 242 | 243 | (add-extension '? :single 'match-variable) 244 | 245 | (defun match-variable (args input blists) 246 | (destructuring-bind (&optional name) args 247 | (bind-variable name input blists))) 248 | 249 | 250 | ;;; Usage: (?* [name]). (?*) is for anonymous matching 251 | 252 | (add-extension '?* :segment 'match-segment-variable) 253 | 254 | (defun match-segment-variable (args pats input blists) 255 | (destructuring-bind (&optional name) args 256 | (do* ((tail input (rest tail)) 257 | (new-blists (match-tail tail name pats input blists) 258 | (append (match-tail tail name pats input blists) 259 | new-blists))) 260 | ((null tail) new-blists)))) 261 | 262 | (defun match-tail (tail name pats input blists) 263 | (let ((blists (pat-match pats tail blists))) 264 | (if (null blists) 265 | nil 266 | (bind-variable name (ldiff input tail) blists)))) 267 | 268 | 269 | ;;; Usage: (?and pat1 pat2 ...) 270 | ;;; 271 | ;;; Matches if all the patterns match with a common 272 | ;;; set of bindings. Equivalent to (pat-match pat1 273 | ;;; input (pat-match pat2 input ...)) 274 | 275 | (add-extension '?and :single 'match-and) 276 | 277 | (defun match-and (args input blists) 278 | (cond ((null blists) nil) 279 | ((null args) blists) 280 | (t (match-and (rest args) input 281 | (pat-match (first args) input blists))))) 282 | 283 | ;;; Usage: (?is predicate) 284 | ;;; 285 | ;;; Matches if (funcall predicate input) returns true. 286 | 287 | (add-extension '?is :single 'match-predicate) 288 | 289 | (defun match-predicate (args input blists) 290 | (destructuring-bind (pred) args 291 | (and (not (null blists)) 292 | (funcall pred input) 293 | blists))) 294 | 295 | ;;; Usage: (?match pat1 pat2) -- pat1 will be matched against 296 | ;;; the instantiation of pat2 297 | 298 | (add-extension '?match :none 'match-match) 299 | 300 | (defun match-match (args blists) 301 | (destructuring-bind (pat input-pat) args 302 | (loop for blist in blists 303 | append (pat-match pat (instantiate-pattern input-pat blist) 304 | blists)))) 305 | 306 | 307 | ;;; Usage: (?not pat) 308 | ;;; 309 | ;;; Matches if (pat-match pat input) returns false. 310 | 311 | (add-extension '?not :single 'match-not) 312 | 313 | (defun match-not (args input blists) 314 | (destructuring-bind (pat) args 315 | (cond ((null blists) nil) 316 | ((pat-match pat input blists) nil) 317 | (t blists)))) 318 | 319 | 320 | ;;; Usage: (?or pat1 pat2 ...) 321 | ;;; 322 | ;;; This returns all successful matches with any 323 | ;;; of the patterns. E.g., 324 | ;;; 325 | ;;; ? (pat-match '(?or (?is numberp) (? x)) 1) 326 | ;;; (NIL ((X 1))) 327 | ;;; 328 | ;;; because (?is numberp) matches and returns the 329 | ;;; empty binding list, and (? x) also matches. 330 | 331 | (add-extension '?or :single 'match-or) 332 | 333 | (defun match-or (args input blists) 334 | (cond ((null blists) nil) 335 | ((null args) nil) 336 | (t (append (pat-match (first args) input blists) 337 | (match-or (rest args) input blists))))) 338 | 339 | 340 | (provide "extend-match") 341 | -------------------------------------------------------------------------------- /lisp-critic.asd: -------------------------------------------------------------------------------- 1 | ;;;; lisp-critic.asd 2 | 3 | (cl:in-package :asdf) 4 | 5 | (defsystem :lisp-critic 6 | :version "1.1" 7 | :description "LISP-CRITIC - A Lisp code critiquing package." 8 | :long-description "The Lisp Critic scans your code for instances of bad Lisp programming practice. The Lisp Critic works for all Lisp code, even if there are no test cases. Use the Critic with all your code, whether it's an exercise, an assignment, or something you invented on your own. 9 | see more - https://courses.cs.northwestern.edu/325/exercises/critic.php#critic" 10 | :author "Chris Riesbeck" 11 | :maintainer "CHIBA Masaomi" 12 | :license "MIT Licence" 13 | :serial t 14 | :depends-on (#:ckr-tables) 15 | :components ((:file "extend-match") 16 | (:file "write-wrap") 17 | (:file "lisp-critic") 18 | (:file "lisp-rules"))) 19 | 20 | -------------------------------------------------------------------------------- /lisp-critic.lisp: -------------------------------------------------------------------------------- 1 | ;;;-*- Mode: Lisp; Package: LISP-CRITIC -*- 2 | 3 | #| 4 | Copyright (C) 1997-2005 Christopher K. Riesbeck 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining 7 | a copy of this software and associated documentation files (the "Software"), 8 | to deal in the Software without restriction, including without limitation 9 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | and/or sell copies of the Software, and to permit persons to whom the 11 | Software is furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included 14 | in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 17 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 19 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | |# 24 | 25 | ;;; A Lisp code critiquing package. 26 | ;;; Author: Chris Riesbeck 27 | ;;; 28 | ;;; Update history: 29 | ;;; 30 | ;;; 12/2/19 added NAME-STARTS-WITH [CKR] 31 | ;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR] 32 | ;;; 08/30/05 added license notice [CKR] 33 | ;;; 3/10/05 fixed REMOVE-LISP-PATTERN to remove responses [CKR] 34 | ;;; 1/29/2005 exported more functions to support web editor [CKR] 35 | ;;; 1/27/2005 removed internal global *PATTERN-NAMES* [CKR] 36 | ;;; 1/26/2005 exported ADD-LISP-PATTERN, REMOVE-LISP-PATTERN [CKR] 37 | ;;; 1/22/2005 fixed stupid bug in *TOP-LEVEL* handling [CKR] 38 | ;;; 1/21/2005 re-implemented special ?TOP-LEVEL pattern [CKR] 39 | ;;; 1/21/05 Removed unnecessary pattern extension exports [CKR] 40 | ;;; 1/3/03 made DEFPACKAGE compatible with Allegro Modern [CKR] 41 | ;;; 1/3/03 removed duplicates in SETS-FREE-VARS [CKR] 42 | ;;; 1/3/03 merged DEFINE-LISP-PATTERN and DEFINE-RESPONSE [CKR] 43 | ;;; 12/28/01 fixed bugs caused by dotted pairs in code [CKR] 44 | ;;; 2/1/01 added NAME-ENDS-WITH pattern [CKR] 45 | ;;; 1/15/01 added code to catch (critique 'name) [CKR] 46 | ;;; 12/17/98 sped up printing [CKR] 47 | ;;; 10/6/98 added a check for no rules [CKR] 48 | ;;; 11/18/97 upped length threshold by 5 [CKR] 49 | ;;; 11/18/97 added N parameter for ?REPEAT [CKR] 50 | ;;; 10/21/97 added LABELS and FLET to CODE-VARS [CKR] 51 | ;;; 10/2/97 simplified a FORMAT string for XlispStat [CKR] 52 | ;;; 10/2/97 exported ?and etc from extend-match [CKR] 53 | 54 | 55 | #| 56 | 1. Load TABLES, WRITE-WRAP, EXTEND-MATCH, LISP-CRITIC and 57 | BAD-LISP.RULES 58 | 59 | 2. Type (USE-PACKAGE :LISP-CRITIC) -- DON'T FORGET THIS! 60 | 61 | 3. Critique your code with CRITIQUE-DEFINITION. 62 | 63 | Example call: 64 | 65 | (critique 66 | (defun count-a (lst) 67 | (setq n 0) 68 | (dolist (x lst) 69 | (if (equal x 'a) 70 | (setq n (+ n 1)))) 71 | n)) 72 | 73 | Example output: 74 | 75 | ---------------------------------------------------------------------- 76 | 77 | SETS-GLOBALS: GLOBALS!! Don't use global variables, i.e., N N 78 | ---------------------------------------------------------------------- 79 | 80 | DOLIST-SETF: Don't use SETQ inside DOLIST to accumulate values for N. 81 | Use DO. Make N a DO variable and don't use SETQ etc at all. 82 | ---------------------------------------------------------------------- 83 | 84 | USE-EQL: Unless something special is going on, use EQL, not EQUAL. 85 | ---------------------------------------------------------------------- 86 | 87 | X-PLUS-1: Don't use (+ N 1), use (1+ N) for its value or (INCF N) to 88 | change N, whichever is appropriate here. 89 | ---------------------------------------------------------------------- 90 | 91 | 92 | 93 | If you get a CRITIQUE-DEFINITION undefined error, it's because you 94 | forgot the USE-PACKAGE. Do this to fix things: 95 | 96 | (UNINTERN 'CRITIQUE-DEFINITION) 97 | 98 | (USE-PACKAGE :LISP-CRITIC) 99 | 100 | |# 101 | 102 | (cl:defpackage #:lisp-critic 103 | (:use #:common-lisp #:tables #:extend-match #:write-wrap) 104 | (:import-from #:extend-match #:match-and) 105 | (:export #:critique #:critique-file #:critique-definition 106 | #:apply-critique-rule 107 | #:lisp-critic-version 108 | #:add-lisp-pattern #:define-lisp-pattern #:remove-lisp-pattern 109 | #:get-pattern #:get-response #:get-pattern-names 110 | #:response-args #:response-format-string 111 | #:clear-critique-db) 112 | ) 113 | 114 | (in-package #:lisp-critic) 115 | 116 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 117 | ;;; Global variables and tables 118 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 119 | 120 | 121 | (deftable get-pattern) 122 | (deftable get-response) 123 | 124 | (defparameter *length-threshold* 55) 125 | 126 | (deftable get-local-vars-fn) 127 | (deftable get-assigned-vars-fn) 128 | 129 | (defvar *critic-version* 1.1) 130 | 131 | ;;; used by ?TOP-LEVEL ,set by FIND-CRITIQUE 132 | (defvar *top-level* nil) 133 | 134 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 135 | 136 | ;;; (LISP-CRITIC-VERSION [n]) => version or boolean 137 | ;;; If no argument is given, returns current critic version 138 | ;;; If a number n is given, returns true if critic is at least 139 | ;;; version n or higher. 140 | 141 | (defun lisp-critic-version (&optional n) 142 | (if (null n) 143 | *critic-version* 144 | (>= *critic-version* n))) 145 | 146 | 147 | (defun clear-critique-db () 148 | (clear-table (get-pattern)) 149 | (clear-table (get-response)) 150 | nil) 151 | 152 | (defparameter *output-width* 70) 153 | 154 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 155 | 156 | (defstruct (critique 157 | (:type list) 158 | (:constructor new-critique (name blist code))) 159 | name blist code) 160 | 161 | (defstruct (response 162 | (:type list) 163 | (:constructor new-response (format-string args))) 164 | format-string args) 165 | 166 | 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 168 | ;;; Defining Lisp patterns 169 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 170 | 171 | 172 | (defmacro define-lisp-pattern (name pattern format-string &rest args) 173 | (unless (symbolp name) 174 | (error "Non-symbolic Lisp pattern name ~S" name)) 175 | `(add-lisp-pattern ',name ',pattern ,format-string ',args)) 176 | 177 | (defun add-lisp-pattern (name pat format-string args) 178 | (setf (get-pattern name) pat) 179 | (setf (get-response name) (new-response format-string args)) 180 | name) 181 | 182 | (defun get-pattern-names () 183 | (let ((l nil)) 184 | (map-table #'(lambda (name pat) 185 | (declare (ignore pat)) 186 | (push name l)) 187 | (get-pattern)) 188 | (sort l #'string<))) 189 | 190 | (defun remove-lisp-pattern (name) 191 | (remove-key name (get-pattern)) 192 | (remove-key name (get-response))) 193 | 194 | 195 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 196 | ;;; CRITIQUE, -DEFINITION, CRITIQUE-FILE 197 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 198 | 199 | (defmacro critique (form) 200 | `(critique-definition ',form)) 201 | 202 | ;;; A common bug is (critique 'foo) which becomes 203 | ;;; (critique-definition (quote (quote foo)) -- so we check 204 | ;;; for that specially. 205 | 206 | (defun critique-definition 207 | (defn &optional (out *standard-output*) (names (get-pattern-names))) 208 | (cond ((or (atom defn) 209 | (and (eql (car defn) 'quote) 210 | (or (atom (cadr defn)) 211 | (and (eql (caadr defn) 'quote) 212 | (atom (cadadr defn)))))) 213 | (format t "~&Can't critique ~S -- I need the actual definition~%" 214 | defn)) 215 | ((null names) 216 | (format t "~&You forgot to load bad-lisp.rules~%")) 217 | (t 218 | (print-critique-responses (generate-critiques defn names) out))) 219 | (values)) 220 | 221 | (defun critique-file 222 | (file &optional (out *standard-output*) (names (get-pattern-names))) 223 | (with-open-file (in file) 224 | (let ((eof (list nil))) 225 | (do ((code (read in nil eof) (read in nil eof))) 226 | ((eq code eof) (values)) 227 | (print-separator out #\*) 228 | (let ((*print-right-margin* *output-width*)) 229 | (pprint code out)) 230 | (critique-definition code out names))))) 231 | 232 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 233 | 234 | (defun generate-critiques (code names) 235 | (loop for name in names 236 | append (apply-critique-rule name code))) 237 | 238 | (defun apply-critique-rule (name code) 239 | (find-critiques name (get-pattern name) code :blists '(nil) :top-level t)) 240 | 241 | (defun print-critique-responses (critiques 242 | &optional (stream *standard-output*)) 243 | (let ((*print-pretty* nil)) 244 | (when critiques 245 | (print-separator stream)) 246 | (dolist (critique critiques) 247 | (print-critique-response critique stream)))) 248 | 249 | 250 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 251 | ;;; FIND-CRITIQUES 252 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 253 | 254 | (defun find-critiques (name pat code &key (blists '(nil)) ((:top-level *top-level*) *top-level*)) 255 | (let ((new-blists (critique-match pat code blists))) 256 | (cond ((not (null new-blists)) 257 | (make-critiques name new-blists code)) 258 | ((atom code) nil) 259 | (t 260 | (or (find-critiques name pat (car code) :blists blists) 261 | (find-critiques name pat (cdr code) :blists blists)))))) 262 | 263 | 264 | (defun critique-match (pat code blists) 265 | (pat-match pat code blists)) 266 | 267 | (defun make-critiques (name blists code) 268 | (mapcar #'(lambda (blist) (new-critique name blist code)) 269 | blists)) 270 | 271 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 272 | ;;; Critique message printing 273 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 274 | 275 | (defun print-critique-response (critique 276 | &optional (stream *standard-output*)) 277 | (let ((name (critique-name critique)) 278 | (blist (critique-blist critique)) 279 | (code (critique-code critique))) 280 | (let ((response (get-response name))) 281 | (cond ((null response) 282 | (let ((*print-lines* 2) (*print-pretty* t) 283 | (*print-right-margin* *output-width*)) 284 | (format stream "~&~A: Code: ~W" name code))) 285 | (t 286 | (write-wrap stream 287 | (make-response-string name response blist) 288 | *output-width*))) 289 | (print-separator stream)))) 290 | 291 | (defun make-response-string (name response blist) 292 | (declare (ignore name)) 293 | (format nil "~&~?" 294 | (response-format-string response) 295 | (instantiate-pattern (response-args response) 296 | blist))) 297 | 298 | ;;; the following can be done with 299 | ;;; 300 | ;;; (format stream "~&~V,,,V<~:*~A~>~%" *output-width* ch) 301 | ;;; 302 | ;;; but XlispStat 3.50 doesn't handle that and everyone has 303 | ;;; to run to Steele to see what it does. 304 | 305 | 306 | (defun print-separator (&optional (stream *standard-output*) 307 | (ch #\-)) 308 | (format stream "~&~A~%" 309 | (make-string *output-width* :initial-element ch))) 310 | 311 | 312 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 313 | ;;; Matcher extensions 314 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 315 | 316 | 317 | ;;; General extensions -- useful lots of places 318 | 319 | ;;; (?CONTAINS pat) -- matches anything containing something matching 320 | ;;; pat 321 | 322 | (add-extension '?contains :single 'match-contains) 323 | 324 | (defun match-contains (args input blists) 325 | (destructuring-bind (pat) args 326 | (find-match pat input blists))) 327 | 328 | (defun find-match (pat input blists) 329 | (or (pat-match pat input blists) 330 | (and (consp input) 331 | (or (find-match pat (first input) blists) 332 | (find-match pat (rest input) blists))))) 333 | 334 | 335 | ;;; (?REPEAT pat [n]) -- matches N or more occurrences of pat; 336 | ;;; N defaults to 1 337 | 338 | (add-extension '?repeat :segment 'match-repeat) 339 | 340 | (defun match-repeat (args pats input blists) 341 | (and (not (null input)) 342 | (destructuring-bind (pat &optional (n 1)) args 343 | (match-repeat-pat n pat pats input blists)))) 344 | 345 | (defun match-repeat-pat (n pat pats input blists) 346 | (unless (null input) 347 | (let ((blists (pat-match pat (first input) blists))) 348 | (cond ((null blists) nil) 349 | ((> n 1) 350 | (match-repeat-pat (1- n) pat pats (rest input) blists)) 351 | (t (append (pat-match pats (rest input) blists) 352 | (match-repeat-pat n pat pats (rest input) blists) 353 | )))))) 354 | 355 | 356 | ;;; (?OPTIONAL pat) -- matches zero or one occurrences of pat 357 | 358 | (add-extension '?optional :segment 'match-optional) 359 | 360 | (defun match-optional (args pats input blists) 361 | (let ((skip-blists (pat-match pats input blists)) 362 | (no-skip-blists 363 | (and (not (null input)) 364 | (pat-match pats (rest input) 365 | (pat-match (first args) (first input) blists))))) 366 | (cond ((null skip-blists) no-skip-blists) 367 | ((null no-skip-blists) skip-blists) 368 | (t (append skip-blists no-skip-blists))))) 369 | 370 | 371 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 372 | ;;; Extensions useful for critiquing Lisp code 373 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 374 | 375 | ;;; (?NAME-CONTAINS string) -- matches a symbol containing 376 | ;;; the given string (case is ignored) 377 | 378 | (add-extension '?name-contains :single 'match-name-contains) 379 | 380 | (defun match-name-contains (args input blists) 381 | (destructuring-bind (substring) args 382 | (and (symbolp input) 383 | (search substring (symbol-name input) 384 | :test #'char-equal) 385 | blists))) 386 | 387 | ;;; (?NAME-ENDS-WITH string) -- matches a symbol ending with 388 | ;;; the given string (case is ignored) 389 | 390 | (add-extension '?name-ends-with :single 'match-name-ends-with) 391 | 392 | (defun match-name-ends-with (args input blists) 393 | (destructuring-bind (substring) args 394 | (and (symbolp input) 395 | (string-ends-with (symbol-name input) substring) 396 | blists))) 397 | 398 | (defun string-ends-with (str substr) 399 | (let ((strlen (length str)) 400 | (substrlen (length substr))) 401 | (and (> strlen substrlen) 402 | (string-equal str substr :start1 (- strlen substrlen))))) 403 | 404 | ;;; (?NAME-STARTS-WITH string) -- matches a symbol starting with 405 | ;;; the given string (case is ignored) 406 | 407 | (add-extension '?name-starts-with :single 'match-name-starts-with) 408 | 409 | (defun match-name-starts-with (args input blists) 410 | (destructuring-bind (substring) args 411 | (and (symbolp input) 412 | (string-starts-with-p (symbol-name input) substring) 413 | blists))) 414 | 415 | (defun string-starts-with-p (str substr) 416 | (let ((strlen (length str)) 417 | (substrlen (length substr))) 418 | (and (>= strlen substrlen) 419 | (string-equal str substr :end1 substrlen)))) 420 | 421 | (add-extension '?user-defined-name-starts-with :single 'match-user-defined-name-starts-with) 422 | 423 | (defun standard-symbolp (sym) 424 | (and (symbolp sym) 425 | (eql (load-time-value (find-package "CL")) 426 | (symbol-package sym)))) 427 | 428 | (defun match-user-defined-name-starts-with (args input blists) 429 | (destructuring-bind (substring) args 430 | (and (symbolp input) 431 | (not (standard-symbolp input)) 432 | (string-starts-with-p (symbol-name input) substring) 433 | blists))) 434 | 435 | ;;; (?EQL-PRED [name]) -- matches a Lisp equality predicate 436 | ;;; (except =) and binds name to it, if given 437 | 438 | (add-extension '?eql-pred :single 'match-eql-pred) 439 | 440 | (defun match-eql-pred (args input blists) 441 | (destructuring-bind (&optional name) args 442 | (and (member input '(eq eql equal equalp)) 443 | (bind-variable name input blists)))) 444 | 445 | 446 | ;;; (?TOO-LONG [name]) -- matches if code is too long 447 | ;;; (LIST-COUNT > *LENGTH-THRESHOLD*) and binds name 448 | ;; to LIST-COUNT, if given 449 | 450 | (add-extension '?too-long :single 'match-too-long) 451 | 452 | (defun match-too-long (args input blists) 453 | (destructuring-bind (&optional name) args 454 | (let ((badness (get-length-badness input))) 455 | (when (> badness 0) 456 | (bind-variable name 457 | (get-badness-phrase badness) 458 | blists))))) 459 | 460 | 461 | (defun get-length-badness (code) 462 | (let ((code-length (list-count code))) 463 | (/ (- code-length *length-threshold*) 464 | *length-threshold*))) 465 | 466 | #| doesn't handle dotted pairs 467 | 468 | (defun list-count (form) 469 | (cond ((atom form) 0) 470 | (t (reduce #'+ form 471 | :key #'list-count 472 | :initial-value (length form))))) 473 | |# 474 | 475 | (defun list-count (form) 476 | (cond ((null form) 0) 477 | ((atom form) 1) 478 | (t (+ (list-count (car form)) 479 | (list-count (cdr form)))))) 480 | 481 | (defun get-badness-phrase (badness) 482 | (cond ((<= badness 1/4) "a little") 483 | ((<= badness 1/2) "somewhat") 484 | ((<= badness 3/4) "") 485 | (t "way"))) 486 | 487 | 488 | ;;; (?SETS-FREE-VARS [name]) -- matches any Lisp code containing 489 | ;;; assignments to free variables -- binds name to a list of the 490 | ;;; free variables if given 491 | ;;; 492 | ;;; For all that there's lot of code here, it's still very crude. 493 | ;;; Most of the code is to handle all the ways Common Lisp can 494 | ;;; assign and create variables. 495 | 496 | (add-extension '?sets-free-vars :single 'match-sets-free-vars) 497 | 498 | (defun match-sets-free-vars (args input blists) 499 | (destructuring-bind (&optional name) args 500 | (let ((vars (remove-duplicates (find-assigned-free-vars input)))) 501 | (if (null vars) nil 502 | (bind-variable name vars blists))))) 503 | 504 | ;;; Usage: (?top-level pat1 pat2 ...) 505 | ;;; 506 | ;;; Matches if (pat-match pat input) is true at the top-level 507 | ;;; of input, i.e, no nesting. 508 | 509 | (add-extension '?top-level :single 'match-top-level) 510 | 511 | (defun match-top-level (args input blists) 512 | (and *top-level* 513 | (match-and args input blists))) 514 | 515 | 516 | 517 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 518 | ;;; Getting assigned free variables 519 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 520 | 521 | ;;; Very quick and dirty. Doesn't know real 522 | ;;; scope rules, assumes anything nested is scoped, e.g., 523 | ;;; 524 | ;;; (do ((x (setq x 2) ...)) ...) 525 | ;;; 526 | ;;; is not considered a free variable assignment. 527 | 528 | (defun find-assigned-free-vars (code &optional env-stack) 529 | (or (code-assigned-free-vars code env-stack) 530 | (and (consp code) 531 | (let ((new-stack (cons code env-stack))) 532 | (loop for l = code then (cdr l) 533 | until (atom l) 534 | append (find-assigned-free-vars (car l) new-stack)))))) 535 | 536 | (defun code-assigned-free-vars (code &optional env-stack) 537 | (let ((vars (code-assigned-vars code))) 538 | (cond ((null vars) nil) 539 | (t (get-free-vars vars env-stack))))) 540 | 541 | (defun get-free-vars (vars env-stack) 542 | (cond ((null env-stack) vars) 543 | ((null vars) nil) 544 | (t (get-free-vars (remove-local-vars vars (first env-stack)) 545 | (rest env-stack))))) 546 | 547 | (defun remove-local-vars (vars code-env) 548 | (let ((local-vars (code-vars code-env))) 549 | (cond ((null local-vars) vars) 550 | (t (set-difference vars local-vars))))) 551 | 552 | 553 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 554 | ;;; Getting assigned variables 555 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 556 | 557 | (defun code-assigned-vars (code) 558 | (unless (atom code) 559 | (let ((fn (get-assigned-vars-fn (first code)))) 560 | (cond ((null fn) nil) 561 | (t (remove-if-not #'symbolp (funcall fn code))))))) 562 | 563 | (dolist (fn '(psetf psetq rotatef setf setq shiftf)) 564 | (setf (get-assigned-vars-fn fn) 565 | #'(lambda (code) 566 | (do ((tail (cdr code) (cddr tail)) 567 | (vars nil (cons (first tail) vars))) 568 | ((null tail) vars))))) 569 | 570 | (dolist (fn '(decf incf pop)) 571 | (setf (get-assigned-vars-fn fn) 572 | #'(lambda (code) (list (second code))))) 573 | 574 | (dolist (fn '(push pushnew)) 575 | (setf (get-assigned-vars-fn fn) 576 | #'(lambda (code) (list (third code))))) 577 | 578 | 579 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 580 | ;;; Getting new local variables 581 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 582 | 583 | 584 | (defun code-vars (code) 585 | (unless (atom code) 586 | (let ((fn (get-local-vars-fn (first code)))) 587 | (cond ((null fn) nil) 588 | (t (funcall fn code)))))) 589 | 590 | (defun get-vars (vars-list) 591 | (loop for var-form in vars-list 592 | for var = (get-var var-form) 593 | unless (member var lambda-list-keywords) 594 | collect var)) 595 | 596 | (defun get-var (var-form) 597 | (cond ((atom var-form) var-form) 598 | (t (get-var (car var-form))))) 599 | 600 | 601 | (dolist (fn '(defmacro defun)) 602 | (setf (get-local-vars-fn fn) 603 | #'(lambda (code) (get-vars (third code))))) 604 | 605 | (dolist (fn '(destructuring-bind do do* lambda let let* 606 | multiple-value-bind)) 607 | (setf (get-local-vars-fn fn) 608 | #'(lambda (code) (get-vars (second code))))) 609 | 610 | (dolist (fn '(dolist dotimes with-open-file with-open-stream)) 611 | (setf (get-local-vars-fn fn) 612 | #'(lambda (code) (list (get-var (second code)))))) 613 | 614 | (dolist (fn '(flet labels)) 615 | (setf (get-local-vars-fn fn) 616 | #'(lambda (code) 617 | (loop for def in (second code) 618 | append (second def))))) 619 | 620 | (setf (get-local-vars-fn 'loop) 'get-loop-vars) 621 | 622 | (defun get-loop-vars (code) 623 | (cond ((atom code) nil) 624 | (t (let ((tail (member-if #'loop-binder-p code))) 625 | (cond ((null tail) nil) 626 | (t (cons (get-var (second tail)) 627 | (get-loop-vars (cddr tail))))))))) 628 | 629 | (defun loop-binder-p (x) 630 | (and (symbolp x) 631 | (member x '(for with and) :test #'string=))) 632 | 633 | 634 | 635 | (provide "lisp-critic") 636 | 637 | #| 638 | CHANGE LOG 639 | 640 | 12/17/98 sped up --- printing [CKR] 641 | Problem: the --- lines printed very slowly in ACL 3 Lite 642 | Cause: - were printed one character at a time 643 | Change: made a --- string first then printed 644 | 645 | 7/10/97 simplified named patterns [CKR] 646 | Problem: function names like (pattern-pattern ...) 647 | Cause: named patterns kept in list 648 | Change: replaced with get-pattern table and separate 649 | name list to maintain order of patterns (though 650 | order's not important right now) 651 | |# 652 | -------------------------------------------------------------------------------- /lisp-rules.lisp: -------------------------------------------------------------------------------- 1 | ;;;-*- Mode: Lisp; Package: LISP-CRITIC -*- 2 | 3 | #| 4 | Copyright (c) 1997-2005 Christopher K. Riesbeck 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining 7 | a copy of this software and associated documentation files (the "Software"), 8 | to deal in the Software without restriction, including without limitation 9 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | and/or sell copies of the Software, and to permit persons to whom the 11 | Software is furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included 14 | in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 17 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 19 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | |# 24 | 25 | ;;; Rules for the Lisp Critic. 26 | ;;; Author: Chris Riesbeck 27 | ;;; 28 | ;;; Update history: 29 | ;;; 30 | ;;; 12/1/2020 added NEEDLESS-WHEN [CKR] 31 | ;;; 12/2/2019 added CHECK-PREFIX and HELPER-SUFFIX [CKR] 32 | ;;; 3/23/2019 changed LENGTH=NUM [defaultxr] 33 | ;;; 10/13/2017 generalized SETF-PUSH to include SETQ [CKR] 34 | ;;; 12/07/2015 added DO* to SETF-IN-DO, expanded text of COND-WITHOUT-DEFAULT [CKR] 35 | ;;; 09/28/2015 added PROGN-IN-DO-BODY and PROGN-IN-DO-EXIT [CKR] 36 | ;;; 10/22/2014 added CONCATENATE LIST [CKR] 37 | ;;; 12/09/2013 added CONS-LIST [CKR] 38 | ;;; 10/2011/2011 added ROUND to FLOOR-WITH-/ [CKR] 39 | ;;; 10/2011/2011 added CEILING to FLOOR-WITH-/ [CKR] 40 | ;;; 10/06/2011 added INCF-1 [CKR] 41 | ;;; 10/04/2011 added LIST-LENGTH [CKR] 42 | ;;; 09/29/2011 added PROGN-SINGLE-FORM [CKR] 43 | ;;; 09/28/2011 generalized EQUAL-WITH-NIL [CKR] 44 | ;;; 09/24/2011 added NOT-CONSP [CKR] 45 | ;;; 11/24/2009 fixed typo in CONS-CONS-ACONS text [CKR] 46 | ;;; 10/01/2009 added ADD-ZERO [CKR] 47 | ;;; 09/29/2009 fixed NTH-ON-LIST [CKR] 48 | ;;; 09/29/2009 added LIST to TYPEP-PRIMITIVE [CKR] 49 | ;;; 11/2/2008 added CONS-CONS-ACONS [CKR] 50 | ;;; 2/4/2007 added DEFMACRO to SETS-GLOBALS [CKR] 51 | ;;; 2/15/2006 added NEEDLESS-SHIFTF, rewrote COND-WITHOUT-DEFAULT [CKR] 52 | ;;; 2/13/2006 added GREATER-DIFFERENCE-0 [CKR] 53 | ;;; 2/9/2006 modified MAKE-PATHNAME-FILE critique [CKR] 54 | ;;; 2/8/2006 added EXPORT-KEYWORD, RETURN-FROM-BLOCK-DEFUN [CKR] 55 | ;;; 2/4/2006 added LAMBDA for IDENTITY [CKR] 56 | ;;; 2/4/2006 fixed VERBOSE-GENERIC-VAR-NAME to exempt keywords [CKR] 57 | ;;; 2/2/2006 expanded comment in EQL-ON-NUMBERS [CKR] 58 | ;;; 2/1/2006 added SETF-INCF-VALUE and SETF-DECF-VALUE [CKR] 59 | ;;; 1/31/2006 added CONS-CONS-LIST* [CKR] 60 | ;;; 1/25/2006 added WHEN-IN-DO [CKR] 61 | ;;; 1/24/2006 added COPY-ARRAY and FORMAT-CONSTANT-STRING, remove NULL-FOR-ENDP [CKR] 62 | ;;; 1/13/2006 fixed LET-ATOMS format bug [CKR] 63 | ;;; 1/11/2006 replaced RPLACD-OR-RPLACA with separate rules [CKR] 64 | ;;; 1/11/2006 fixed comment in LENGTH=NUM [CKR] 65 | ;;; 1/11/2006 added IF-NO-ELSE [CKR] 66 | ;;; 1/6/2006 added TYPEP-PRIMITIVE [CKR] 67 | ;;; 1/6/2006 added QUOTE-TRUE [CKR] 68 | ;;; 09/18/2005 replaced Academic Free License with MIT Licence [CKR] 69 | ;;; 08/30/2005 added license notice [CKR] 70 | ;;; 3/15/2005 added NEEDLESS-COND, NEEDLESS-COND-NOT [CKR] 71 | ;;; 3/11/2005 added NOT-ATOM [CKR] 72 | ;;; 3/7/2005 added MULTIPLE-VALUE-LIST [CKR] 73 | ;;; 3/7/2005 fixed LET-ATOMS to also catch (LET ((X)) ...) [CKR] 74 | ;;; 1/31/2005 fixed NESTED-COND-ELSE-COND [CKR] 75 | ;;; 1/24/2005 Added NESTED-AND-OR [CKR] 76 | ;;; 1/22/2005 Edited various critique texts [CKR] 77 | ;;; 1/20/2005 fixed USE-EQL to test for '(...) arguments [CKR] 78 | ;;; 1/20/2005 fixed COND-INSTEAD-OF-CASE to only match EQL [CKR] 79 | ;;; 1/7/2003 fixed X-PLUS-1 and X-MINUS-1 to ignore numbers [CKR] 80 | ;;; 1/5/2003 fixed require/use-package code [CKR] 81 | ;;; 1/3/2003 merged DEFINE-LISP-PATTERN and DEFINE-RESPONSE [CKR] 82 | ;;; 3/9/2002 added NEEDLESS-PUSH, fixed NEEDLESS-SETF [CKR] 83 | ;;; 2/7/2002 changed NEEDLESS-AND, NEEDLESS-OR [CKR] 84 | ;;; 12/28/2001 changed package to CS325-USER [CKR] 85 | ;;; 3/1/2001 fixed AND -> ?AND in IF-FOR-NOT [CKR] 86 | ;;; 3/1/2001 added missing ?NOT NIL to IF->OR and COND->OR [CKR] 87 | ;;; 2/23/2001 added DEFMACRO to FUNCTION-TOO-LONG [CKR] 88 | ;;; 2/6/2001 added DO*-SINGLE-VAR, IF->OR, COND->OR [CKR] 89 | ;;; 1/30/2001 added VERBOSE-GENERIC-VAR-NAME [CKR] 90 | ;;; 1/29/2001 added ?-FOR-PREDICATE [CKR] 91 | ;;; 1/22/2001 changed LENGTH=NUM response to distinguish vectors from lists [CKR] 92 | ;;; 1/22/2001 added top-level constraint to SETS-GLOBALS and NEEDLESS-SETF [CKR] 93 | ;;; 1/22/2001 added UNUSED-MAPCAR-VALUE [CKR] 94 | ;;; 1/22/2001 added DOLIST and DOTIMES to PROGN-IN-WHEN [CKR] 95 | ;;; 1/17/2001 changed SETF-INCF and SETF-DECF to include SETQ [CKR] 96 | ;;; 1/15/2001 added SETF-INCF and SETF-DECF [CKR] 97 | ;;; 1/15/2001 added NULL-THEN-LISTP, modified LISTP-FOR-CONSP [CKR] 98 | ;;; 1/12/2001 added NEEDLESS-AND-T and NEEDLESS-OR-NIL [CKR] 99 | ;;; 11/25/1998 added CAR-CDR [CKR] 100 | ;;; 11/25/1998 added LET to PROGN-IN-LAMBDA [CKR] 101 | ;;; 11/22/1998 changed nested conditional handling to use 102 | ;;; NESTED-COND-ELSE-COND and NESTED-COND-ELSE-COND [CKR] 103 | ;;; 11/11/1998 added LET*-SINGLE [CKR] 104 | ;;; 10/28/1998 added NESTED-ELSE-COND [CKR] 105 | ;;; 10/28/1998 fixed DO-WITH-BODY to handle multiexpression DO-bodies [CKR] 106 | ;;; 10/28/1998 added plurals to MISSPELLED-OCCURRENCE [CKR] 107 | ;;; 10/26/1998 added APPEND-LIST2-LIST [CKR] 108 | ;;; 10/26/1998 added PUSH to SETF-IN-DO-INC [CKR] 109 | ;;; 10/25/1998 added PROGN-IN-WHEN, PROGN-IN-DEFUN, PROGN-IN-LAMBDA [CKR] 110 | ;;; 10/14/1998 added more misspellings to MISSPELLED-OCCURRENCE [CKR] 111 | ;;; 10/14/1998 generalized NESTED-IF's to check for COND's [CKR] 112 | ;;; 10/1/1998 fixed QNIL (missing ?*'s) [CKR] 113 | ;;; 9/29/1998 added PROGN-IN-COND, SETF-IN-DO-INC [CKR] 114 | ;;; 12/4/1997 added QUOTE-KEYWORD [CKR] 115 | ;;; 12/2/1997 added FLOOR-WITH-/ [CKR] 116 | ;;; 12/2/1997 added keywords and longer message to the EOF rule [CKR] 117 | ;;; 12/2/1997 added COND-ELSE-NO-EXP [CKR] 118 | ;;; 11/30/1997 turned off QNIL inside DEFMACRO [CKR] 119 | ;;; 11/24/1997 added APPLY-FOR-FUNCALL [CKR] 120 | ;;; 11/21/1997 added = to LENGTH=NUM [CKR] 121 | ;;; 11/18/1997 added LET-ATOMS [CKR] 122 | ;;; 11/18/1997 fixed COND-INSTEAD-OF-CASE [CKR] 123 | ;;; 11/16/1997 added FIND-MEMBER-FOR-ASSOC [CKR] 124 | ;;; 11/15/1997 fixed responses for WHEN-FOR-UNLESS [CKR] 125 | ;;; 11/14/1997 partially fixed COND-INSTEAD-OF-CASE [CKR] 126 | ;;; 11/14/1997 added several IF and COND patterns [CKR] 127 | ;;; 11/14/1997 removed erroneous mode line [CKR] 128 | ;;; 11/11/1997 fixed X-PLUS-1 to do (+ 1 X) [CKR] 129 | ;;; 11/7/1997 fixed EQL-WITH-NULL and APPEND-LIST-LOOP [CKR] 130 | ;;; 11/4/1997 fixed 2 EOF rules with same name [CKR] 131 | ;;; 10/17/1997 fixed progn-in-if pattern [CKR] 132 | ;;; 10/17/1997 made do-with-body and do-setf smarter [CKR] 133 | ;;; 10/14/1997 added append-list-list and nested-defuns [CKR] 134 | ;;; 10/11/1997 added append-list-recursion [CKR] 135 | ;;; 10/2/1997 added require and in-package [CKR] 136 | 137 | 138 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 139 | 140 | (in-package #:lisp-critic) 141 | 142 | 143 | ;;; Should add: 144 | ;;; Catch (format t "..." arg) where "..." takes no arguments 145 | ;;; Catch all nested conditional combinations between IF and COND 146 | 147 | (define-lisp-pattern copy-array 148 | (copy-array (?)) 149 | "There is no COPY-ARRAY in Standard Common Lisp. You have to create ~ 150 | an empty array and fill it as needed.") 151 | 152 | (define-lisp-pattern function-too-long 153 | (?and ((?or defun defmacro) (?*)) (?too-long how-much)) 154 | "Definition is ~A too long! A \"little\" is probably OK, \"somewhat\" ~ 155 | might be OK, if this is a really complicated problem, but code that is ~ 156 | \"too long\" or \"way too long\" can almost certainly be improved." 157 | (? how-much)) 158 | 159 | (define-lisp-pattern nested-defuns 160 | (defun (?*) 161 | (?contains (defun (?*))) 162 | (?*)) 163 | "DEFUN's don't nest in CL like they do in Scheme. 164 | They're always top-level. FLET and LABELS can define local 165 | functions, but you don't need them here.") 166 | 167 | (define-lisp-pattern sets-globals 168 | (?top-level ((?or defun defmacro) (?*)) (?sets-free-vars vars)) 169 | "GLOBALS!! Don't use global variables, i.e.,~{ ~S~}" 170 | (? vars)) 171 | 172 | (define-lisp-pattern sets-parameters 173 | (defun (?) ((?*) (? var) (?*)) 174 | (?*) 175 | (?contains ((?or setq setf incf decf) (? var) (?*))) 176 | (?*)) 177 | "It's bad style to reassign input parameters like ~S ~ 178 | -- and often useless." 179 | (? var)) 180 | 181 | (define-lisp-pattern eql-on-numbers 182 | (?and ((?eql-pred eql) (? arg1) (? arg2)) 183 | (?or (?match (?is numberp) (? arg1)) 184 | (?match (?is numberp) (? arg2)))) 185 | "Don't use (~S ~S ~S) to compare numbers, use =. = handles floating point numbers ~ 186 | correctly, and signals an error if passed a non-number." 187 | (? eql) (? arg1) (? arg2)) 188 | 189 | (define-lisp-pattern equal-with-nil 190 | (?and ((?eql-pred eql) (? arg1) (? arg2)) 191 | (?or (?match (?or nil (quote nil)) (? arg1)) 192 | (?match (?or nil (quote nil)) (? arg2)))) 193 | "Don't use ~S to compare ~S with ~S. Use NULL" 194 | (? eql) (? arg1) (? arg2)) 195 | 196 | (define-lisp-pattern typep-primitive 197 | (typep (?) (quote (?or integer number string cons atom list))) 198 | "For basic types, specific predicates, such as integerp and so on, are simpler than typep.") 199 | 200 | (define-lisp-pattern cond-without-default 201 | (cond (?*) ((?not t) (?*))) 202 | "If the return value of a COND is being used, then be sure to ~ 203 | have an ELSE branch, i.e., (T ...). If it's not being used, use ~ 204 | WHEN or UNLESS.") 205 | 206 | (define-lisp-pattern cond-test-no-exp 207 | (cond (?*) ((? test)) (?) (?*)) 208 | "Try to avoid COND branches with tests and no actions. ~ 209 | They're easy to misread. Try (OR ~S ...) instead." 210 | (? test)) 211 | 212 | (define-lisp-pattern cond-else-no-exp 213 | (cond (?*) ((? test))) 214 | "Try to avoid COND branches with tests and no actions. ~ 215 | They're easy to misread. Try (T ~S) instead." 216 | (? test)) 217 | 218 | 219 | (define-lisp-pattern setq-in-do 220 | (do ((?*) ((? var) (? init)) (?*)) 221 | (?) 222 | (?contains (setq (? var) (? incr)))) 223 | "Most SETQ's of a DO variable, like ~S, are better done ~ 224 | with (DO (... (~S ~S ~S)...) ...)" 225 | (? var) (? var) (? init) (? incr)) 226 | 227 | (define-lisp-pattern setf-in-do-inc 228 | ((?and (?or do do*) (? fn)) 229 | ((?*) 230 | ((? var) (?) ((?and (?or setq setf incf decf push) (? setf)) 231 | (?*))) 232 | (?*)) 233 | (?*)) 234 | "~S is unnecessary in the increment part of a ~S clause. Why? What should ~ 235 | you write?" 236 | (? setf) 237 | (? fn)) 238 | 239 | (define-lisp-pattern if-no-else 240 | (if (?) (?)) 241 | "You have an IF with no else branch. If the return value of the IF ~ 242 | matters, you should explicitly say what the else returns, e.g., NIL. ~ 243 | If the return value doesn't matter, use WHEN or UNLESS.") 244 | 245 | (define-lisp-pattern nested-and-or 246 | ((?and (?or and or) (? fn)) (?*) ((? fn) (?*)) (?*)) 247 | "Why nest an ~S inside an ~S?" (? fn) (? fn)) 248 | 249 | (define-lisp-pattern nested-ifs 250 | (if (?) ((?or cond if) (?*)) (?*)) 251 | "Avoid nested IF's. Use AND, if possible, or a single COND.") 252 | 253 | (define-lisp-pattern nested-cond-else-cond 254 | (cond (?*) (t ((?and (?or cond if) (? form)) (?*)))) 255 | "Why nest a ~S in the ELSE branch of a COND when one flat COND ~ 256 | will work instead?" 257 | (? form)) 258 | 259 | (define-lisp-pattern nested-if-else-cond 260 | (if (?) (?) ((?and (?or cond if) (? form)) (?*))) 261 | "Why nest a ~S in the ELSE branch of an IF when one flat COND ~ 262 | will work instead?" 263 | (? form)) 264 | 265 | (define-lisp-pattern needless-cond 266 | (cond ((?) t) (t nil)) 267 | "There's an unnecessary COND here.") 268 | 269 | (define-lisp-pattern needless-cond-not 270 | (cond ((?) nil) (t t)) 271 | "There's a COND here that can be replaced with something simpler (not IF).") 272 | 273 | (define-lisp-pattern needless-if 274 | (?or (if (?) t nil) (if (?) t)) 275 | "No IF is needed here.") 276 | 277 | (define-lisp-pattern needless-when 278 | ((?and (?or when unless) (? x)) (?) (?or t nil)) 279 | "No ~S is needed here." 280 | (? x)) 281 | 282 | (define-lisp-pattern if->or 283 | (if (?) t (?not nil)) 284 | "Instead of (IF test T else), just write (OR test else)" 285 | ) 286 | 287 | (define-lisp-pattern cond->or 288 | (cond ((?) t) (t (?not nil))) 289 | "Instead of (COND (test T) (T else)), just write (OR test else)" 290 | ) 291 | 292 | (define-lisp-pattern needless-and-t 293 | (and (?*) t) 294 | "Why do you think you need that T at the end of the AND?") 295 | 296 | (define-lisp-pattern needless-or-nil 297 | (or (?*) nil) 298 | "Why do you think you need that NIL at the end of the OR?") 299 | 300 | (define-lisp-pattern needless-and 301 | (and (?)) 302 | "Why do you think you need that AND?") 303 | 304 | (define-lisp-pattern needless-or 305 | (or (?)) 306 | "Why do you think you need that OR?") 307 | 308 | (define-lisp-pattern if-for-not 309 | (?and (if (?) nil t) (? form)) 310 | "No need for ~S. Just use (NOT ...))." 311 | (? form)) 312 | 313 | (define-lisp-pattern if-for-unless 314 | (if (not (? test)) (?)) 315 | "Instead of (IF (NOT ~S) ...) use (UNLESS ~S ...)." 316 | (? test) (? test)) 317 | 318 | (define-lisp-pattern progn-in-if 319 | (if (? test) (?*) (progn (?*)) (?*)) 320 | "Don't use IF and PROGN, use COND") 321 | 322 | (define-lisp-pattern progn-in-cond 323 | (cond (?*) ((? test) (?*) (progn (?*)) (?*)) (?*)) 324 | "You never need a PROGN after the test in a COND branch.") 325 | 326 | (define-lisp-pattern progn-in-defun 327 | ((?and (?or defun defmacro) (? fn)) (?) (?) (progn (?*))) 328 | "You never need a PROGN at the start of the body of a ~S." (? FN)) 329 | 330 | (define-lisp-pattern progn-in-do-body 331 | ((?and (?or do do*) (? fn)) (?) (?) (progn (?*))) 332 | "You never need a PROGN at the start of the body of a ~S." 333 | (? fn)) 334 | 335 | (define-lisp-pattern progn-in-do-exit 336 | ((?and (?or do do*) (? fn)) (?) ((?) (progn (?*))) (?*)) 337 | "You don't need a PROGN for the exit clause of a ~S." 338 | (? fn)) 339 | 340 | (define-lisp-pattern progn-in-lambda 341 | ((?and (?or lambda let) (? fn)) (?) (progn (?*))) 342 | "You never need a PROGN at the start of the body of a ~S." 343 | (? fn)) 344 | 345 | (define-lisp-pattern progn-in-when 346 | ((?and (?or when unless dotimes dolist) (? fn)) (?) (progn (?*))) 347 | "You never need a PROGN at the start of the body of a ~S" (? FN)) 348 | 349 | (define-lisp-pattern progn-single-form 350 | (progn (?)) 351 | "Why do you think you need a PROGN?") 352 | 353 | (define-lisp-pattern setf-push 354 | ((?and (?or setq setf) (? setf)) (? x) (cons (? y) (? x))) 355 | "Instead of (~S ~S (CONS ...)), use PUSH." 356 | (? setf) (? x)) 357 | 358 | (define-lisp-pattern cond-instead-of-case 359 | (cond (?repeat ((eql (? var) '(?)) (?*)) 2) 360 | (?optional (t (?*)))) 361 | "Don't use COND with repeated (EQL ~S ...) branches, use CASE." 362 | (? var)) 363 | 364 | (define-lisp-pattern lambda-for-identity 365 | (lambda ((? x)) (? x)) 366 | "You don't need that LAMBDA. Common Lisp has a function that does the same thing.") 367 | 368 | (define-lisp-pattern let-atoms 369 | (let ((?*) (?or (?and (?is atom) (? var)) ((? var))) (?*)) (?*)) 370 | "Always initialize LET variables like ~S with (~S NIL), not just ~S or (~S). It's too ~ 371 | easy to misread what's being initialized to what." 372 | (? var) (? var) (? var) (? var)) 373 | 374 | (define-lisp-pattern let*-single 375 | (let* ((?)) (?*)) 376 | "There's no need for LET* here. Use LET unless you can't.") 377 | 378 | (define-lisp-pattern do-with-body 379 | (do (?) 380 | (?) 381 | (?*) 382 | (?contains 383 | (?or ((?and (?or setq setf incf decf) (? fn)) 384 | (?and (?is symbolp) (? var)) 385 | (?*)) 386 | ((?and push (? fn)) (?) (and (?is symbolp) (? var))))) 387 | (?*)) 388 | "Don't use a DO body to collect values. 389 | Incorporate the body into the DO variable update list.") 390 | 391 | (define-lisp-pattern do*-single-var 392 | (do* ((?)) (?*)) 393 | "DO* says \"later variable clauses depend on earlier ones.\" Clearly that's not true here so use DO." 394 | ) 395 | 396 | (define-lisp-pattern format-constant-string 397 | (format t (?or "~A" "~a") (?is stringp)) 398 | "There's a simpler way to print a constant string.") 399 | 400 | (define-lisp-pattern qnil 401 | (defun (?) (?) (?*) (?contains '(?and (?or t nil) (? const))) (?*)) 402 | "Don't quote ~S. ~:*~S is a constant and doesn't need quoting. [If you ~ 403 | wrote '() to initialize a list, that's OK. It's impossible for the ~ 404 | Lisp Critic to distinguish '() from 'NIL internally.]" 405 | (? const)) 406 | 407 | (define-lisp-pattern qnumber 408 | '(?and (?is numberp) (? n)) 409 | "Don't quote numbers like ~S. Numbers are constants and don't need quoting." 410 | (? n)) 411 | 412 | (define-lisp-pattern quote-keyword 413 | '(?and (?is keywordp) (? key)) 414 | "Don't quote keywords like ~S. Keywords are constants and don't need quoting." 415 | (? key)) 416 | 417 | (define-lisp-pattern using-print 418 | ((?or princ prin1 print) (?*)) 419 | "In general, FORMAT is used for most printing, because it's more flexible.") 420 | 421 | (define-lisp-pattern car-cdr 422 | (car (cdr (?))) 423 | "Use CADR (or CADDR or ...) or SECOND (or THIRD or ...), not (CAR (CDR ...)).") 424 | 425 | (define-lisp-pattern nth-for-cdr 426 | (nth 1 (?)) 427 | "(NTH 1 ...) is clumsy. Use REST or CDR.") 428 | 429 | (define-lisp-pattern nth-on-list 430 | (nth (?not (?is numberp)) (?)) 431 | "(NTH ...) is expensive. Lists are not arrays.~%~ 432 | Hint: use FIRST, REST, and/or a pointer to access elements of a list") 433 | 434 | (define-lisp-pattern dolist-setf 435 | (dolist (?) 436 | (?contains 437 | (?or ((?and (?or setq setf incf decf) (? fn)) 438 | (?and (?is symbolp) (? var)) 439 | (?*)) 440 | ((?and push (? fn)) (?) (and (?is symbolp) (? var)))))) 441 | "Don't use ~S inside DOLIST to accumulate values for ~S.~%~ 442 | Use DO. Make ~S a DO variable and don't use SETQ etc at all." 443 | (? fn) (? var) (? var)) 444 | 445 | (define-lisp-pattern substitute-use 446 | (substitute (?*)) 447 | "Because SUBSTITUTE creates new lists, it is expensive and used rarely.") 448 | 449 | (define-lisp-pattern rplaca 450 | (rplaca (? var) (?)) 451 | "Instead of (RPLACA ~S ...) use (SETF (CAR ~S) ...)." 452 | (? var) (? var)) 453 | 454 | (define-lisp-pattern rplacd 455 | (rplacd (? var) (?)) 456 | "Instead of (RPLACD ~S ...) use (SETF (CDR ~S) ...)." 457 | (? var) (? var)) 458 | 459 | (define-lisp-pattern misspelled-occurrence 460 | (?or occurance occurrance occurence occurances occurrances occurences) 461 | "You must be a real computer scientist. None of them can spell occurrence.") 462 | 463 | (define-lisp-pattern cons-with-nil 464 | (cons (? x) nil) 465 | "~S is silly -- ~ 466 | what's the right way to make a list of ~S?" 467 | (cons (? x) nil) (? x)) 468 | 469 | (define-lisp-pattern cons-list 470 | (?and (cons (?) (list (?*))) (? x)) 471 | "Why CONS in ~S" (? x)) 472 | 473 | (define-lisp-pattern append-list-loop 474 | (do ((?*) 475 | ((?) (?) (?contains (append (? x) (list . (? y))))) 476 | (?*)) 477 | (?*) ) 478 | "Avoid ~S in loops. It takes N squared CONSes to build a list ~ 479 | N long when only N are needed.~%~ 480 | Hint: build ~S backwards with CONS and then REVERSE." 481 | (append (? x) (list . (? y))) (? x)) 482 | 483 | (define-lisp-pattern append-list-recursion 484 | (defun (? fn) (?) 485 | (?*) 486 | (?and (?contains (? fn)) 487 | (?contains (append (? x) (list (? y))))) 488 | (?*)) 489 | "Avoid ~S in recursive loops. It takes N squared CONSes to build a list ~ 490 | N long when only N are needed." 491 | (append (? x) (list (? y)))) 492 | 493 | (define-lisp-pattern append-list-list 494 | (append (list (? x)) (? y)) 495 | "~S is silly. What's the right way to add something 496 | to the front of a list?" 497 | (append (list (? x)) (? y))) 498 | 499 | (define-lisp-pattern append-list2-list 500 | (append (list (? x) (?) (?*)) (? y)) 501 | "(APPEND (LIST ~S ...) ~S) is inefficient. It makes a list then copies it. ~ 502 | Instead, do (CONS ~S (CONS ... ~S)) or (LIST* ~S ... ~S)." 503 | (? x) (? y) (? x) (? y) (? x) (? y)) 504 | 505 | (define-lisp-pattern concatenate-list 506 | (concatenate 'list (?*)) 507 | "CONCATENATE is not needed for list construction. There are lots of more commonly used ~ 508 | functions, like CONS and APPEND.") 509 | 510 | (define-lisp-pattern cons-cons-acons 511 | (cons (cons (?) (?)) (?)) 512 | "Consing onto an alist can be a little simpler with ACONS.") 513 | 514 | (define-lisp-pattern cons-cons-list* 515 | (cons (?) (cons (?) (?))) 516 | "When you have nested CONSes, it might be simpler to use LIST*.") 517 | 518 | (define-lisp-pattern use-eql 519 | ((?and (?or equal equalp eq) (? equal)) (?not '((?*))) (?not '((?*)))) 520 | "Unless something special is going on, use EQL, not ~S." 521 | (? equal)) 522 | 523 | (define-lisp-pattern add-zero 524 | (?or (+ 0 (?)) (+ (?) 0)) 525 | "Add zero? Think about it...") 526 | 527 | (define-lisp-pattern incf-1 528 | ((?or incf decf) (?) 1) 529 | "The default for INCF and DECF is 1 so it's redundant to include it.") 530 | 531 | (define-lisp-pattern x-plus-1 532 | (?or (+ (?and (?not (?is numberp)) (? var)) 1) (+ 1 (?and (?not (?is numberp)) (? var)))) 533 | "Don't use ~S, use ~S for its value or ~S to change ~S, ~ 534 | whichever is appropriate here." 535 | (+ (? var) 1) (1+ (? var)) (incf (? var)) (? var)) 536 | 537 | (define-lisp-pattern x-minus-1 538 | (- (?and (?not (?is numberp)) (? var)) 1) 539 | "Don't use ~S, use ~S for its value or ~S to change ~S, ~ 540 | whichever is appropriate here." 541 | (- (? var) 1) (1- (? var)) (decf (? var)) (? var)) 542 | 543 | (define-lisp-pattern floor-with-/ 544 | ((?and (?or ceiling floor round) (? fn)) (/ (?) (?))) 545 | "You don't need ~S and /. ~S with two arguments does a divide already." 546 | (? fn) (? fn)) 547 | 548 | (define-lisp-pattern quote-false 549 | 'false 550 | "Don't use 'FALSE for NIL. Believe it or not, 'FALSE is true in Lisp!") 551 | 552 | (define-lisp-pattern quote-true 553 | 'true 554 | "Don't use 'TRUE for true. Just use T (lowercased). That's the normal default true value.") 555 | 556 | (define-lisp-pattern return-done 557 | 'done 558 | "Don't return 'DONE. Return values aren't for people, they're ~ 559 | for Lisp code, and DONE means nothing to Lisp code. Just return T ~ 560 | or NIL.") 561 | 562 | (define-lisp-pattern apply-for-funcall 563 | (apply (? fn) (list (?*))) 564 | "(APPLY ~S (LIST ...)) makes a list for no reason. How can you call ~ 565 | ~S with those arguments directly?" 566 | (? fn) (? fn)) 567 | 568 | (define-lisp-pattern optionals 569 | (defun (? fun-name) ((?*) &optional (?) (?) (?*)) (?*)) 570 | "Multiple optional arguments get confusing. Use &KEY for ~S." 571 | (? fun-name)) 572 | 573 | (define-lisp-pattern list-length 574 | (list-length ?) 575 | "LIST-LENGTH is slower than LENGTH because it has to worry about circular lists. ~ 576 | Use LENGTH unless circular lists are expected (rare).") 577 | 578 | (define-lisp-pattern length=num 579 | (?or 580 | ((?and (?or (?eql-pred) = < <= > >=) (? pred)) 581 | (length (? exp)) 582 | (?and (?is numberp) (? n))) 583 | ((?and (?or (?eql-pred) = < <= > >=) (? pred)) 584 | (?and (?is numberp) (? n)) 585 | (length (? exp))) 586 | ) 587 | "If ~S is a list, not a vector, don't use ~S and LENGTH. LENGTH has to ~ 588 | CDR down the entire list. Use (NULL (CDR ...)) with the appropriate number of ~ 589 | CDR's. 590 | e.g. 591 | \(DO ((U (CDR U)) (I (1- ) (1- I))) 592 | ((ZEROP I) (NULL (CDR U)))) 593 | That will run in constant time, independent of list length. 594 | Or consider using ALEXANDRIA:LENGTH=." 595 | (? exp) (? pred)) 596 | 597 | (define-lisp-pattern null-then-listp 598 | (cond (?*) 599 | ((null (? exp)) (?*)) 600 | (?*) 601 | ((listp (? exp)) (?*)) 602 | (?*)) 603 | "Testing for LISTP ~S after testing for NULL ~S is like testing ~ 604 | for X <= Y after testing for X = Y. It's redundant and misleading." 605 | (? exp) (? exp)) 606 | 607 | (define-lisp-pattern not-consp 608 | (not (consp (?))) 609 | "NOT CONSP is equvalent to what basic predicate?") 610 | 611 | (define-lisp-pattern listp-for-consp 612 | (cond (?*) 613 | ((listp (? exp)) 614 | (?*) 615 | (?contains ((?and (?or car first cdr rest) (? fn)) (? exp))) 616 | (?*)) 617 | (?*)) 618 | "LISTP is not sufficient to guarantee that ~S of ~S is legal." 619 | (? fn) (? exp)) 620 | 621 | (define-lisp-pattern when-in-do 622 | (do ((?*) ((?) (?) ((?or when unless) (?*))) (?*)) (?*)) 623 | "WHEN and UNLESS are not appropriate when the return value is needed. ~ 624 | WHEN and UNLESS are for when you conditionally want to do some actions.") 625 | 626 | (define-lisp-pattern when-for-unless 627 | (when (not (? x)) (?*)) 628 | "(UNLESS ~S ...) is better than (WHEN (NOT ~S) ...)." 629 | (? x) (? x)) 630 | 631 | (define-lisp-pattern unless-for-when 632 | (unless (not (? x)) (?*)) 633 | "(WHEN ~S ...) is better than (UNLESS (NOT ~S) ...)." 634 | (? x) (? x)) 635 | 636 | (define-lisp-pattern find-member-for-assoc 637 | ((?and (?or find member) (? fn)) (?*) :key (?or 'car #'car)) 638 | "When working with lists of pairs, use ASSOC, not ~S and CAR. That's what ~ 639 | ASSOC was built for!" 640 | (? fn)) 641 | 642 | (define-lisp-pattern constant-bad-eof 643 | (read (?) nil (?and (?or nil t '(?) (?is keywordp)) (? eof)) (?*)) 644 | "~S is a bad end of file marker. Any constant expression might be ~ 645 | in the file and cause a premature exit. You need to generate a unique marker ~ 646 | at run-time." 647 | (? eof)) 648 | 649 | (define-lisp-pattern constant-bad-eof-var 650 | (let ((?*) ((? var) (?and (?or nil t '(?)) (? eof))) (?*)) 651 | (?contains (read (?) nil (? var) (?*)))) 652 | "~S is a bad end of file marker (and being in a variable doesn't ~ 653 | help any). What if ~:*~S is in the file?" 654 | (? eof)) 655 | 656 | (define-lisp-pattern uses-open 657 | (open (?*)) 658 | "Don't use OPEN. If an error occurs, the file will never be ~ 659 | closed. Use WITH-OPEN-FILE -- simpler and safer.") 660 | 661 | (define-lisp-pattern with-open-close 662 | (with-open-file ((? stream) (?*)) (?contains (close (? stream)))) 663 | "Don't close a stream open with WITH-OPEN-FILE. That will be ~ 664 | done automatically.") 665 | 666 | (define-lisp-pattern make-pathname-file 667 | (defun (?) ((?*) (? file) (?*)) 668 | (?contains (make-pathname :name (? file)))) 669 | "Careful! (MAKE-PATHNAME :NAME ~S ...) is only correct if ~S ~ 670 | is just the file name and you're constructing a full path. If ~S can be ~ 671 | a full pathname, like c:/foo/baz.lisp, ~ 672 | MAKE-PATHNAME may create file with those characters in its name! Normally ~ 673 | you should just use the pathname passed in." 674 | (? file) (? file) (? file)) 675 | 676 | (define-lisp-pattern evil-eval 677 | (eval (?*)) 678 | "EVAL may not always be evil, but it's almost certainly not the best answer.") 679 | 680 | (define-lisp-pattern uses-prog 681 | (prog (?*)) 682 | "PROG is obsolete. There are other ways to code.") 683 | 684 | (define-lisp-pattern needless-setf 685 | (?top-level 686 | (defun (?*) 687 | (?or ((?and (?or setf incf decf) (? fn)) 688 | (?and (?is symbolp) (? var)) 689 | (?*)) 690 | (cond (?*) 691 | ((?*) ((?and (?or setf incf decf) (? fn)) 692 | (?and (?is symbolp) (? var)) 693 | (?*))) 694 | (?*)) 695 | (if (?) 696 | (?*) 697 | ((?and (?or setf incf decf) (? fn)) 698 | (?and (?is symbolp) (? var)) 699 | (?*)) 700 | (?*)) 701 | (let (?) 702 | (?*) 703 | (?or ((?and (?or setf incf decf) (? fn)) 704 | (?and (?is symbolp) (? var)) 705 | (?*)) 706 | (cond (?*) 707 | ((?*) ((?and (?or setf incf decf) (? fn)) 708 | (?and (?is symbolp) (? var)) 709 | (?*))) 710 | (?*)) 711 | (if (?) 712 | (?*) 713 | ((?and (?or setf incf decf) (? fn)) 714 | (?and (?is symbolp) (? var)) 715 | (?*)) 716 | (?*)))) 717 | ) 718 | )) 719 | "Why do you think you need that ~S on ~S?" (? FN) (? VAR)) 720 | 721 | (define-lisp-pattern needless-push 722 | (?top-level 723 | (defun (?*) 724 | (?or ((?and (?or push pushnew) (? fn)) 725 | (?) 726 | (?and (?is symbolp) (? var))) 727 | (cond (?*) 728 | ((?*) ((?and (?or push pushnew) (? fn)) 729 | (?) 730 | (?and (?is symbolp) (? var)))) 731 | (?*)) 732 | (if (?) 733 | (?*) 734 | ((?and (?or push pushnew) (? fn)) 735 | (?) 736 | (?and (?is symbolp) (? var))) 737 | (?*)) 738 | (let (?) 739 | (?*) 740 | (?or ((?and (?or push pushnew) (? fn)) 741 | (?) 742 | (?and (?is symbolp) (? var))) 743 | (cond (?*) 744 | ((?*) ((?and (?or push pushnew) (? fn)) 745 | (?) 746 | (?and (?is symbolp) (? var)))) 747 | (?*)) 748 | (if (?) 749 | (?*) 750 | ((?and (?or push pushnew) (? fn)) 751 | (?) 752 | (?and (?is symbolp) (? var))) 753 | (?*)))) 754 | ) 755 | )) 756 | "Why do you think you need that ~S on ~S?" (? FN) (? VAR)) 757 | 758 | (define-lisp-pattern needless-shiftf 759 | (shiftf (?) (?)) 760 | "There's no need for SHIFTF when there's just 2 arguments.") 761 | 762 | (define-lisp-pattern setf-incf 763 | ((?and (?or setq setf) (? fn)) (? exp) (1+ (? exp))) 764 | "Instead of ~S plus 1+, just use INCF." (? FN)) 765 | 766 | (define-lisp-pattern setf-decf 767 | ((?and (?or setq setf) (? fn)) (? exp) (1- (? exp))) 768 | "Instead of ~S plus 1-, just use DECF." (? FN)) 769 | 770 | (define-lisp-pattern setf-incf-value 771 | ((?and (?or setq setf) (? fn)) (? var) 772 | (?or (+ (? var) (? val)) (+ (? val) (? var)))) 773 | "INCF would be simpler to add ~S to ~S than ~S" (? val) (? var) (? FN)) 774 | 775 | (define-lisp-pattern setf-decf-value 776 | ((?and (?or setq setf) (? fn)) (? var) 777 | (- (? var) (? val))) 778 | "DECF would be simpler to subtract ~S from ~S than ~S" (? val) (? var) (? FN)) 779 | 780 | 781 | 782 | ;;; Name related critiques 783 | 784 | (define-lisp-pattern verbose-generic-var-name 785 | ((?or defmacro defmethod defun) (?) (?optional (?)) 786 | ((?*) (?and (?or number input-list output-list data) (? var)) (?*)) 787 | (?*)) 788 | "~S is very generic. If this variable really is that generic, ~ 789 | use a standard short name like L for a list, I for a counter, ~ 790 | N for integer, and X and Y for real numbers. If this variable ~ 791 | holds a value with more semantics, use a more specific name." 792 | (? var)) 793 | 794 | (define-lisp-pattern misspells-occurrences 795 | (?or (?name-contains "occurances") 796 | (?name-contains "occurences")) 797 | "You misspelled 'occurrences.'") 798 | 799 | (define-lisp-pattern ?-for-predicate 800 | (?name-ends-with "?") 801 | "In Common Lisp, use -p to end predicate names, not ? as in Scheme.'") 802 | 803 | (define-lisp-pattern check-prefix 804 | (?user-defined-name-starts-with "check") 805 | "check is not a helpful prefix. It doesn't say what happens after checking. ~ 806 | If this is a predicate, use a property-p name to say what it tests for.") 807 | 808 | (define-lisp-pattern helper-suffix 809 | (?name-ends-with "helper") 810 | "Helper is not helpful name. A function name should primarily describe ~ 811 | what is returned, and maybe with what input.") 812 | 813 | (define-lisp-pattern unused-mapcar-value 814 | (let (?*) (mapcar (?*)) (?) (?*)) 815 | "MAPCAR is building a list that's not used. Use MAPC instead.") 816 | 817 | (define-lisp-pattern multiple-value-list 818 | (multiple-value-list (?)) 819 | "Multiple values were invented to avoid the need to cons lists. ~ 820 | So most uses of multiple-value-list to make a list are a mistake. ~ 821 | Use multiple-value-bind (or possibly multiple-value-setq) instead. ~ 822 | They do not cons.") 823 | 824 | (define-lisp-pattern not-atom 825 | (not (atom (?))) 826 | "Instead of (NOT (ATOM ...)) just write (CONSP ...).") 827 | 828 | (define-lisp-pattern export-keyword 829 | (:export (?is keywordp) (?*)) 830 | "Don't specify symbols to export using keywords. This puts copies of those symbols ~ 831 | into the keyword package as well, wasting space.") 832 | 833 | (define-lisp-pattern return-from-block-defun 834 | (defun (? fn) (?) 835 | (?contains (block (? label) 836 | (?*) (?contains (return-from (? label) (?))) (?*)))) 837 | "It may be simpler to just RETURN-FROM ~S directly, rather than creating ~ 838 | nested BLOCK." (? fn)) 839 | 840 | (define-lisp-pattern greater-difference-0 841 | (> (- (? x) (? y)) 0) 842 | "Instead of (> (- x y) 0), just write (> x y).") 843 | -------------------------------------------------------------------------------- /tables.lisp: -------------------------------------------------------------------------------- 1 | ;;; A simple table utility 2 | ;;; ---------------------------------------------------------------------- 3 | ;;; - File: tables.lisp 4 | ;;; - Author: Chris Riesbeck 5 | 6 | #| 7 | Copyright (c) 2006 Christopher K. Riesbeck 8 | 9 | Permission is hereby granted, free of charge, to any person obtaining 10 | a copy of this software and associated documentation files (the "Software"), 11 | to deal in the Software without restriction, including without limitation 12 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 13 | and/or sell copies of the Software, and to permit persons to whom the 14 | Software is furnished to do so, subject to the following conditions: 15 | 16 | The above copyright notice and this permission notice shall be included 17 | in all copies or substantial portions of the Software. 18 | 19 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 20 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 21 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 22 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 23 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 24 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 25 | OTHER DEALINGS IN THE SOFTWARE. 26 | |# 27 | 28 | ;;; ---------------------------------------------------------------------- 29 | ;;; Defining a table function 30 | ;;; ---------------------------------------------------------------------- 31 | 32 | ;;; (DEFTABLE name) => name 33 | ;;; 34 | ;;; DEFTABLE defines name to be a table function such that 35 | ;;; 36 | ;;; - (name key) retrieves a value for key, if any 37 | ;;; - (SETF (name key) value) stores a value for key 38 | ;;; - (name) returns the internal table associated with name; 39 | ;;; this is useful when manipulating tables (see below). 40 | ;;; 41 | ;;; The table is empty when name is defined (or redefined). 42 | ;;; 43 | ;;; Examples: 44 | ;;; 45 | ;;; > (deftable AGE-of) 46 | ;;; AGE-OF 47 | ;;; > (age-of 'john) 48 | ;;; NIL 49 | ;;; > (setf (age-of 'john) 22) 50 | ;;; 22 51 | ;;; > (age-of 'john) 52 | ;;; 22 53 | ;;; 54 | ;;; Note: DEFTABLE is a top-level form, like DEFUN. It is not for 55 | ;;; creating local table functions. The following is wrong: 56 | ;;; 57 | ;;; (defun foo (...) 58 | ;;; (deftable baz) 59 | ;;; ...) 60 | ;;; 61 | ;;; If you want a local table, use MAKE-HASH-TABLE and GETHASH. 62 | 63 | 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | ;;; Packages 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 | 68 | (cl:defpackage #:tables 69 | (:use #:common-lisp) 70 | (:export #:clear-table #:deftable #:in-table-p #:map-table #:remove-key) 71 | ) 72 | 73 | (in-package #:tables) 74 | 75 | 76 | ;;; ---------------------------------------------------------------------- 77 | ;;; Implementation notes: 78 | ;;; 79 | ;;; - I avoided (DEFUN (SETF fn) ...) so as not to require CL 2 80 | ;;; - I used PROGN to make the DEFSETF top-level for MacIntosh 81 | ;;; Common Lisp. 82 | 83 | (defmacro deftable (fn) 84 | (let ((set-fn (gentemp))) 85 | `(eval-when (:compile-toplevel :load-toplevel :execute) 86 | (let* ((fn ',fn) 87 | (table (get-table fn))) 88 | (defun ,fn (&optional (key nil key-given-p)) 89 | (if key-given-p 90 | (gethash key table) 91 | table)) 92 | (defun ,set-fn (arg1 &optional (arg2 nil arg2-p)) 93 | (cond (arg2-p 94 | (setf (gethash arg1 table) arg2)) 95 | (t (set-table fn arg1))))) 96 | (defsetf ,fn ,set-fn) 97 | ',fn))) 98 | 99 | (defvar *tables* (make-hash-table) 100 | "Table of DEFTABLE functions.") 101 | 102 | (defun get-table (name) 103 | (or (gethash name *tables*) 104 | (set-table name (make-hash-table)))) 105 | 106 | (defun set-table (name table) 107 | (if (hash-table-p table) 108 | (setf (gethash name *tables*) table) 109 | (error "~S not a table" table))) 110 | 111 | ;;; ---------------------------------------------------------------------- 112 | ;;; Manipulating tables 113 | ;;; ---------------------------------------------------------------------- 114 | 115 | ;;; Certain functions need explicit access to the internal table. To 116 | ;;; get this table, call the table function with no arguments, e.g., 117 | ;;; (AGE-OF). This returns the internal table for AGE-OF, which 118 | ;;; can then be passed to a table manipulation function. 119 | ;;; 120 | ;;; Example: The following clears the AGE-OF table. 121 | ;;; 122 | ;;; > (clear-table (age-of)) 123 | ;;; 124 | ;;; The nature of the internal table is implementation-dependent. 125 | 126 | ;;; (IN-TABLE-P key table) => T or NIL 127 | ;;; Returns true if key has a value in the table. 128 | ;;; (REMOVE-KEY key table) => T or NIL 129 | ;;; Removes any entry for key in the table, and returns true 130 | ;;; if there was one. 131 | ;;; (CLEAR-TABLE table) => table 132 | ;;; Removes all entries from the table. 133 | ;;; (MAP-TABLE function table) => NIL 134 | ;;; Calls (function key value) for every key and value in the table. 135 | ;;; The order in which keys are found is implementation-dependent. 136 | 137 | ;;; ---------------------------------------------------------------------- 138 | ;;; Implementation notes: 139 | ;;; 140 | ;;; - I avoided MULTIPLE-VALUE-BIND for Xlisp compatibility. 141 | 142 | (let ((flag (list nil))) 143 | (defun in-table-p (key table) 144 | (not (eq flag (gethash key table flag))))) 145 | 146 | (defun remove-key (key table) (remhash key table)) 147 | 148 | (defun clear-table (table) (clrhash table)) 149 | 150 | (defun map-table (fn table) (maphash fn table)) 151 | 152 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 153 | 154 | #|(in-package #+:cltl2 :common-lisp-user #-:cltl2 :user)|# 155 | 156 | #|(provide "tables")|# 157 | 158 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 | ;;; Change log 160 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 | 162 | #| 163 | 1/3/03 [CKR] 164 | Problem: wouldn't load in Allegro Modern 165 | Cause: uppercase export strings 166 | Change: use #:symbol hack 167 | 168 | 9/13/95 [CKR] 169 | Problem: the package was not getting common-lisp in some CL2's 170 | Cause: CLTL2 is not a defined feature in all CL2's 171 | Change: Use (OR (find-package ...) (find-package ...)) form. 172 | 173 | 11/3/94 [CKR] 174 | Problem: :lisp/:common-lisp conflicts 175 | Change: added #+:cltl2 forms 176 | 177 | 10/19/94 [CKR] 178 | Problem: PROVIDE undefined function error. 179 | Cause: (make-package :tables :use '(:common-lisp)) 180 | Change: Insert (in-package :common-lisp-user) before (provide ...) 181 | 182 | 10/19/94 [CKR] 183 | Problem: EXPORT undefined function error. 184 | Cause: (make-package :tables) 185 | Change: (make-package :tables :use '(:common-lisp)). 186 | 187 | 7/27/94 [CKR] 188 | Problem: If name is a function, (DEFTABLE name) would cause an error. 189 | Cause: Calling (name) doesn't do the right thing. 190 | Change: Store name->table associations in the table *TABLES*. 191 | 192 | 12/1/93 [CKR] 193 | Problem: If several packages used TABLES, they each loaded separate 194 | copies of TABLES. 195 | Cause: No TABLES package (because all functions were exported) that 196 | they could use. 197 | Change: Set up TABLES package. 198 | 199 | 11/4/92 [CKR] 200 | Problem: In some Lisps, e.g., MCL, the DEFSETF in DEFTABLE wasn't 201 | happening at the right time in compiled code. 202 | Cause: DEFSETF, a top-level form, was inside the LET. 203 | Change: Put DEFSETF outside the LET, in a PROGN. 204 | 205 | 9/30/92 [CKR] 206 | Problem: IN-TABLE-P returned multiple values instead of just T or NIL 207 | Cause: IN-TABLE-P defined as a simple call to GETHASH 208 | Change: Use (NOT (EQ flag (GETHASH ... flag))) 209 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 210 | |# 211 | -------------------------------------------------------------------------------- /write-wrap.lisp: -------------------------------------------------------------------------------- 1 | ;;;-*- Mode: Lisp; Package: WRITE-WRAP -*- 2 | 3 | #| 4 | Copyright (c) 2003 Christopher K. Riesbeck 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining 7 | a copy of this software and associated documentation files (the "Software"), 8 | to deal in the Software without restriction, including without limitation 9 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 10 | and/or sell copies of the Software, and to permit persons to whom the 11 | Software is furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included 14 | in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 17 | OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 19 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | |# 24 | 25 | ;;; Updates: 26 | ;;; 1/3/03 made DEFPACKAGE compatible with Allegro Modern [CKR] 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;;; Packages 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | 32 | (cl:defpackage #:write-wrap 33 | (:use #:common-lisp) 34 | (:export #:write-wrap) 35 | ) 36 | 37 | (in-package #:write-wrap) 38 | 39 | ;;; (WRITE-WRAP stream string width &optional indent first-indent) 40 | ;;; writes string to stream, split into width-size lengths, breaking 41 | ;;; at returns and spaces in the string, if possible, indenting every 42 | ;;; line indent spaces (default = 0), except the first line which is 43 | ;;; indented first-indent spaces (default = indent). 44 | ;;; 45 | ;;; Note: to generate a string simply use with-output-to-string 46 | ;;; (WITH-OUTPUT-TO-STRING (s) (WRITE-WRAP s ...)) 47 | ;;; 48 | ;;; Had to turn off *PRINT-PRETTY* because Franz turns it on 49 | ;;; by default and if you turn it off globally, it breaks the IDE 50 | ;;; in 6.0! 51 | 52 | (defun write-wrap (stream strng width 53 | &key indent (first-indent indent)) 54 | (let ((*print-pretty* nil)) 55 | (do* ((end (length strng)) 56 | (indent-string (when (and indent (> indent 0)) 57 | (make-string indent 58 | :initial-element #\space))) 59 | (first-indent-string (when (and first-indent (> first-indent 0)) 60 | (make-string first-indent 61 | :initial-element #\space))) 62 | (start 0 (1+ next)) 63 | (next (break-pos strng start end width) 64 | (break-pos strng start end width)) 65 | (margin first-indent-string indent-string)) 66 | ((null next)) 67 | (when margin (write-string margin stream)) 68 | (write-string strng stream :start start :end next) 69 | (terpri stream)))) 70 | 71 | 72 | ;;; (whitespace-p char) is true if ch is whitespace. 73 | 74 | (defun whitespace-p (ch) 75 | (member ch '(#\linefeed #\newline #\return #\space #\tab))) 76 | 77 | ;;; (break-pos string start end width) returns the position to break string 78 | ;;; at, guaranteed to be no more than width characters. If there's a` 79 | ;;; return, its position is used, else the last space before the width 80 | ;;; cutoff, else width. If the end comes before width, then end is 81 | ;;; returned. 82 | 83 | (defun break-pos (strng start end width) 84 | (unless (or (null start) (>= start end)) 85 | (let ((limit (min (+ start width) end))) 86 | (or (position #\newline strng :start start :end limit) 87 | (and (= end limit) end) 88 | (position #\space strng :start start :end limit :from-end t) 89 | limit)))) ;;insert warning here, if desired 90 | 91 | 92 | #| 93 | ;;; (non-whitespace-pos string &optional start) returns the position of 94 | ;;; the first non-whitespace character in string, after start, if any. 95 | 96 | ;;; Not used now but was used before to set and update START in WRITE-WRAP 97 | ;;; to skip spaces. The current WRITE-WRAP keeps user spacing, except 98 | ;;; when replacing a space with a line break. 99 | 100 | (defun non-whitespace-pos (strng &optional (start 0)) 101 | (position-if-not #'whitespace-p strng :start start)) 102 | 103 | |# 104 | 105 | (provide "write-wrap") 106 | --------------------------------------------------------------------------------