/usr/share/common-lisp/source/metatilities-base/dev/l0-utils.lisp is in cl-metatilities-base 20120909-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 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 | (in-package #:metatilities)
#-(or openmcl digitool ccl) ; already has this
(defun fixnump (arg)
"Same as (typep arg 'fixnum). A lot of Explorer code was written using this,
and it's easier to implement it than to change them all."
(typep arg 'fixnum))
;;;
;;; MACROS
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; NOTE: can't use WITH-UNIQUE-NAMES here
;;; XXX This is a lousy name. Don't export.
(defmacro with-standard-printing (&body forms &aux (package (gensym "PACKAGE")))
"Similar to WITH-STANDARD-IO-SYNTAX, but doesn't change packages."
`(let ((,package *package*))
(with-standard-io-syntax
(let ((*package* ,package))
,@forms))))
) ; eval-always
;;;
;;; PREDICATES
;;;
#-(or digitool openmcl ccl)
(defun neq (left right)
(not (eq left right)))
#-(or digitool openmcl ccl)
(declaim (inline neq))
#-(or digitool openmcl ccl)
(define-compiler-macro neq (left right)
`(not (eq ,left ,right)))
;;;
;;; FORMING SYMBOLS
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun form-symbol-in-package (package &rest names)
"Finds or interns a symbol in package whose name is formed by concatenating the pretty printed representation of the names together."
(with-standard-printing
(intern (format nil "~{~a~}" names)
package)))
(defun form-symbol (&rest names)
"Finds or interns a symbol in the current package whose name is formed by concatenating the pretty printed representation of the names together."
(with-standard-printing
(apply #'form-symbol-in-package *package* names)))
(defun form-keyword (&rest names)
"Finds or interns a symbol in the keyword package whose name is formed by concatenating the pretty printed representation of the names together."
(with-standard-printing
(apply #'form-symbol-in-package (load-time-value (find-package :keyword))
names)))
(defun form-uninterned-symbol (&rest names)
"Creates and returns an uninterned symbol whose name is formed by concatenating the pretty printed representation of the names together."
(with-standard-printing
(make-symbol (format nil "~{~a~}" names))))
) ; eval-always
(defun current-load-file ()
"Returns (if possible) the value of the file currently being loaded or from which
code is currently being evaluated."
#+allegro excl:*source-pathname*
#+digitool (if *load-pathname*
*load-pathname*
;; This makes it work in a fred buffer...
ccl:*loading-file-source-file*)
#-(or lucid allegro Genera Explorer digitool)
*load-pathname*)
(defmacro with-unique-names ((&rest vars) &body body)
"Binds the symbols in VARS to gensyms. cf with-gensyms."
(assert (every #'symbolp vars) () "Can't rebind an expression.")
`(let ,(mapcar #'(lambda (x) `(,x (gensym* ',x))) vars)
,@body))
(defun ensure-list (x)
"If `x` is a list then ensure-list returns it. Otherwise, this returns a singleton list containing `x`."
(if (listp x) x (list x)))
(defun ensure-function (thing)
(typecase thing
(function thing)
(symbol (symbol-function thing))))
;;; newsym
;;;
;;; Sometimes it's nice to have your gensyms mean something when
;;; you're reading the macroexpansion of some form. The problem
;;; is that if you give a prefix to GENSYM it remains the prefix
;;; until you change it.
(eval-when (:compile-toplevel :load-toplevel :execute)
;; the eval-when is because the newsym function is used in expanding
;; `with-variables' and other macros below.
(defvar *newsym-counter* 0
"Counter used by NEWSYM for generating print names.")
(defun newsym (&optional (prefix "X"))
"Create a new uninterned symbol whose print name begins with `prefix', which
may be a string or a symbol. This differs from `gensym' in that the prefix is
not sticky."
(unless (stringp prefix)
(setf prefix (string prefix)))
(make-symbol (format nil "~a~4,'0d" prefix (incf *newsym-counter*)))))
(defun export-exported-symbols (from-package to-package)
"Make the exported symbols in from-package be also exported from to-package."
(use-package from-package to-package)
(do-external-symbols (sym (find-package from-package))
(export sym to-package)))
(defgeneric length-at-least-p (thing length)
(:documentation "Returns true if thing has no fewer than length elements in it."))
(defmethod length-at-least-p ((thing sequence) length)
(>= (length thing) length))
(defmethod length-at-least-p ((thing cons) length)
(let ((temp thing))
(loop repeat (1- length)
while temp do
(setf temp (rest temp)))
(not (null temp))))
(defgeneric length-at-most-p (thing length)
(:documentation "Returns true if thing has no more than length elements in it."))
(defmethod length-at-most-p ((thing sequence) length)
(<= (length thing) length))
(defmethod length-at-most-p ((thing cons) length)
;;?? cf. length-at-least-p, this seems similar
(let ((temp thing))
(loop repeat length
while temp do
(setf temp (rest temp)))
(null temp)))
(declaim (inline length-1-list-p))
(defun length-1-list-p (x)
"Is x a list of length 1? Note that this is better than the naive \(= \(length x\) 1\) because we don't need to traverse the entire list..."
(and (consp x) (null (cdr x))))
(defun nearly-zero-p (x &optional (threshold 0.0001))
"Returns true if `x` is within threshold of 0d0."
(declare (optimize (speed 3) (space 3) (debug 0) (safety 0))
(dynamic-extent x threshold))
;; ABS conses
(if (< 0.0 x)
(> threshold x)
(> x threshold)))
#+Test
(timeit (:report t)
(loop repeat 100000 do
(nearly-zero-p 10.1)
(nearly-zero-p 0.00001)
(nearly-zero-p -0.00001)))
(defun nearly-equal-p (x y threshold)
"Returns true if x and y are within threshold of each other."
(declare (optimize (speed 3) (space 3) (debug 0) (safety 0))
(dynamic-extent x y threshold)
(type double-float x y threshold))
(let ((temp 0.0d0))
(declare (type double-float temp)
(dynamic-extent temp))
(cond ((> x y)
(setf temp (the double-float (- x y)))
(< temp threshold))
(t
(setf temp (the double-float (- y x)))
(< temp threshold)))))
#+Test
(timeit (:report t)
(loop repeat 100000 do
(nearly-equal-p 10.1 10.2 0.0001)
(nearly-equal-p 10.2342345 10.234234 0.0001)))
;;; dotted-pair-p
(defun dotted-pair-p (putative-pair)
"Returns true if and only if `putative-pair` is a dotted-list. I.e., if `putative-pair` is a cons cell with a non-nil cdr."
(and (consp putative-pair)
(cdr putative-pair)
(not (consp (cdr putative-pair)))))
#+No
;;?? move to test suite
(deftestsuite test-dotted-pair-p ()
()
(:tests
((ensure (dotted-pair-p '(a . b))))
((ensure (not (dotted-pair-p '(a b)))))
((ensure (not (dotted-pair-p :a))))
((ensure (not (dotted-pair-p '(a b . c)))))
((ensure (not (dotted-pair-p nil))))))
(defun apply-if-exists (function package &rest args)
"If the function `function` can be found in `package`, then apply it
to `args`.
Returns nil if `package` does not exist or if `function` does not name a
function in `package`. Otherwise, returns whatever `function` returns."
(call-if-exists 'apply function package args))
(defun funcall-if-exists (function package &rest args)
"If the function `function` can be found in `package`, then funcall it
on `args`.
Returns nil if `package` does not exist or if `function` does not name a
function in `package`. Otherwise, returns whatever `function` returns."
(call-if-exists 'funcall function package args))
(defun call-if-exists (call-with function package args)
"If the function `function` can be found in `package`, then call it
with `args`.
Returns nil if `package` does not exist or if `function` does not name a
function in `package`. Otherwise, returns whatever `function` returns."
(let ((package (find-package package)))
(when package
(let ((symbol (find-symbol (etypecase function
(string function)
(symbol (symbol-name function)))
package)))
(when (and symbol (fboundp symbol))
(if (eq call-with 'funcall)
(apply #'funcall symbol args)
(apply #'apply symbol args)))))))
(defun iterate-over-indexes (symbol-counts fn &optional (direction :left))
"Apply fn to lists of indexes generated from symbol counts. The counting is
done so that the first symbol varies most quickly unless the optional direction
parameter is set to :right."
(let* ((dimension (length symbol-counts))
(current-thing (make-list dimension :initial-element 0))
(index-start (ecase direction (:right (1- dimension)) (:left 0)))
(increment (ecase direction (:right -1) (:left 1)))
(index-test (ecase direction
(:right (lambda (i) (>= i 0)))
(:left (lambda (i) (< i dimension)))))
(index index-start))
(loop for i from 0 to
(1- (reduce #'* (remove-if (complement #'plusp) symbol-counts)))
do
(funcall fn current-thing)
(loop while (and (funcall index-test index)
(>= (incf (elt current-thing index))
(elt symbol-counts index))) do
(setf (elt current-thing index) 0)
(setf index (+ index increment))
finally
(setf index index-start)))))
#+Experimental
(defun ioi (lists fn &optional (direction :left))
(iterate-over-indexes
(mapcar #'length lists)
(lambda (indexes)
(funcall fn (mapcar #'elt lists indexes)))
direction))
#+Example
(ioi '((:a :b) (:g) (:d :e :f)) #'print :right)
|