~ubuntu-branches/ubuntu/quantal/cl-kmrcl/quantal : revision 1

1

;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-

2

;;;; *************************************************************************

3

;;;; FILE IDENTIFICATION

4

;;;;

5

;;;; Name: gentils.lisp

6

;;;; Purpose: Main general utility functions for KMRCL package

7

;;;; Programmer: Kevin M. Rosenberg

8

;;;; Date Started: Apr 2000

9

;;;;

10

;;;; $Id: macros.lisp 9173 2004-04-29 15:16:56Z kevin $

11

;;;;

12

13

;;;;

14

;;;; KMRCL users are granted the rights to distribute and use this software

15

;;;; as governed by the terms of the Lisp Lesser GNU Public License

16

;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.

17

;;;; *************************************************************************

18

19

(in-package #:kmrcl)

20

21

(defmacro let-when ((var test-form) &body body)

22

`(let ((,var ,test-form))

23

(when ,var ,@body)))

24

25

(defmacro let-if ((var test-form) if-true &optional if-false)

26

`(let ((,var ,test-form))

27

(if ,var ,if-true ,if-false)))

28

29

;; Anaphoric macros

30

31

(defmacro aif (test then &optional else)

32

`(let ((it ,test))

33

(if it ,then ,else)))

34

35

(defmacro awhen (test-form &body body)

36

`(aif ,test-form

37

(progn ,@body)))

38

39

(defmacro awhile (expr &body body)

40

`(do ((it ,expr ,expr))

41

((not it))

42

,@body))

43

44

(defmacro aand (&rest args)

45

(cond ((null args) t)

46

((null (cdr args)) (car args))

47

(t `(aif ,(car args) (aand ,@(cdr args))))))

48

49

(defmacro acond (&rest clauses)

50

(if (null clauses)

51

nil

52

(let ((cl1 (car clauses))

53

(sym (gensym)))

54

`(let ((,sym ,(car cl1)))

55

(if ,sym

56

(let ((it ,sym)) ,@(cdr cl1))

57

(acond ,@(cdr clauses)))))))

58

59

(defmacro alambda (parms &body body)

60

`(labels ((self ,parms ,@body))

61

#'self))

62

63

(defmacro aif2 (test &optional then else)

64

(let ((win (gensym)))

65

`(multiple-value-bind (it ,win) ,test

66

(if (or it ,win) ,then ,else))))

67

68

(defmacro awhen2 (test &body body)

69

`(aif2 ,test

70

(progn ,@body)))

71

72

(defmacro awhile2 (test &body body)

73

(let ((flag (gensym)))

74

`(let ((,flag t))

75

(while ,flag

76

(aif2 ,test

77

(progn ,@body)

78

(setq ,flag nil))))))

79

80

(defmacro acond2 (&rest clauses)

81

(if (null clauses)

82

nil

83

(let ((cl1 (car clauses))

84

(val (gensym))

85

(win (gensym)))

86

`(multiple-value-bind (,val ,win) ,(car cl1)

87

(if (or ,val ,win)

88

(let ((it ,val)) ,@(cdr cl1))

89

(acond2 ,@(cdr clauses)))))))

90

91

(defmacro mac (expr)

92

"Expand a macro"

93

`(pprint (macroexpand-1 ',expr)))

94

95

(defmacro print-form-and-results (form)

96

`(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))

97

98

99

;;; Loop macros

100

101

(defmacro until (test &body body)

102

`(do ()

103

(,test)

104

,@body))

105

106

(defmacro while (test &body body)

107

`(do ()

108

((not ,test))

109

,@body))

110

111

(defmacro for ((var start stop) &body body)

112

(let ((gstop (gensym)))

113

`(do ((,var ,start (1+ ,var))

114

(,gstop ,stop))

115

((> ,var ,gstop))

116

,@body)))

117

118

(defmacro with-each-stream-line ((var stream) &body body)

119

(let ((eof (gensym))

120

(eof-value (gensym))

121

(strm (gensym)))

122

`(let ((,strm ,stream)

123

(,eof ',eof-value))

124

(do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))

125

((eql ,var ,eof))

126

,@body))))

127

128

(defmacro with-each-file-line ((var file) &body body)

129

(let ((stream (gensym)))

130

`(with-open-file (,stream ,file :direction :input)

131

(with-each-stream-line (,var ,stream)

132

,@body))))

133

134

135

(defmacro in (obj &rest choices)

136

(let ((insym (gensym)))

137

`(let ((,insym ,obj))

138

(or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))

139

choices)))))

140

141

(defmacro mean (&rest args)

142

`(/ (+ ,@args) ,(length args)))

143

144

(defmacro with-gensyms (syms &body body)

145

`(let ,(mapcar #'(lambda (s) `(,s (gensym)))

146

syms)

147

,@body))

148

149

150

(defmacro time-iterations (n &body body)

151

(let ((i (gensym))

152

(count (gensym)))

153

`(progn

154

(let ((,count ,n))

155

(format t "~&Test with ~d iterations: ~W" ,count (quote ,body))

156

(let ((t1 (get-internal-real-time)))

157

(dotimes (,i ,count)

158

,@body)

159

(let* ((t2 (get-internal-real-time))

160

(secs (coerce (/ (- t2 t1)

161

internal-time-units-per-second)

162

'double-float)))

163

(format t "~&Total time: ")

164

(print-seconds secs)

165

(format t ", time per iteration: ")

166

(print-seconds (coerce (/ secs ,n) 'double-float))))))))

167

168

(defmacro mv-bind (vars form &body body)

169

`(multiple-value-bind ,vars ,form

170

,@body))

171

172

;; From USENET

173

(defmacro deflex (var val &optional (doc nil docp))

174

"Defines a top level (global) lexical VAR with initial value VAL,

175

which is assigned unconditionally as with DEFPARAMETER. If a DOC

176

string is provided, it is attached to both the name |VAR| and the

177

name *STORAGE-FOR-DEFLEX-VAR-|VAR|* as a documentation string of

178

kind 'VARIABLE. The new VAR will have lexical scope and thus may

179

be shadowed by LET bindings without affecting its global value."

180

(let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-)))

181

(s1 (symbol-name var))

182

(p1 (symbol-package var))

183

(s2 (load-time-value (symbol-name '#:*)))

184

(backing-var (intern (concatenate 'string s0 s1 s2) p1)))

185

`(progn

186

(defparameter ,backing-var ,val ,@(when docp `(,doc)))

187

,@(when docp

188

`((setf (documentation ',var 'variable) ,doc)))

189

(define-symbol-macro ,var ,backing-var))))

190

191

(defmacro def-cached-vector (name element-type)

192

(let ((get-name (concat-symbol "get-" name "-vector"))

193

(release-name (concat-symbol "release-" name "-vector"))

194

(table-name (concat-symbol "*cached-" name "-table*"))

195

(lock-name (concat-symbol "*cached-" name "-lock*")))

196

`(eval-when (:compile-toplevel :load-toplevel :execute)

197

(defvar ,table-name (make-hash-table :test 'equal))

198

(defvar ,lock-name (kmrcl::make-lock ,name))

199

200

(defun ,get-name (size)

201

(kmrcl::with-lock-held (,lock-name)

202

(let ((buffers (gethash (cons size ,element-type) ,table-name)))

203

(if buffers

204

(let ((buffer (pop buffers)))

205

(setf (gethash (cons size ,element-type) ,table-name) buffers)

206

buffer)

207

(make-array size :element-type ,element-type)))))

208

209

(defun ,release-name (buffer)

210

(kmrcl::with-lock-held (,lock-name)

211

(let ((buffers (gethash (cons (array-total-size buffer)

212

,element-type)

213

,table-name)))

214

(setf (gethash (cons (array-total-size buffer)

215

,element-type) ,table-name)

216

(cons buffer buffers))))))))

217

218

(defmacro def-cached-instance (name)

219

(let* ((new-name (concat-symbol "new-" name "-instance"))

220

(release-name (concat-symbol "release-" name "-instance"))

221

(cache-name (concat-symbol "*cached-" name "-instance-table*"))

222

(lock-name (concat-symbol "*cached-" name "-instance-lock*")))

223

`(eval-when (:compile-toplevel :load-toplevel :execute)

224

(defvar ,cache-name nil)

225

(defvar ,lock-name (kmrcl::make-lock ',name))

226

227

(defun ,new-name ()

228

(kmrcl::with-lock-held (,lock-name)

229

(if ,cache-name

230

(pop ,cache-name)

231

(make-instance ',name))))

232

233

(defun ,release-name (instance)

234

(kmrcl::with-lock-held (,lock-name)

235

(push instance ,cache-name))))))

236

237

(defmacro with-ignore-errors (&rest forms)

238

`(progn

239

,@(mapcar

240

(lambda (x) (list 'ignore-errors x))

241

forms)))

242

243

(defmacro ppmx (form)

244

"Pretty prints the macro expansion of FORM."

245

`(let* ((exp1 (macroexpand-1 ',form))

246

(exp (macroexpand exp1))

247

(*print-circle* nil))

248

(cond ((equal exp exp1)

249

(format t "~&Macro expansion:")

250

(pprint exp))

251

(t (format t "~&First step of expansion:")

252

(pprint exp1)

253

(format t "~%~%Final expansion:")

254

(pprint exp)))

255

(format t "~%~%")

256

(values)))

257

258

(defmacro defconst (symbol value &optional doc)

259

`(defconstant ,symbol (if (boundp ',symbol)

260

(symbol-value ',symbol)

261

,value)

262

,@(when doc (list doc))))