;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
"Debugging tool: print the expression X and its values."
(let ((tmp (gensym)))
`(let ((,tmp (multiple-value-list ,x)))
"Debugging tool: print the expression X and its values."
(let ((tmp (gensym)))
`(let ((,tmp (multiple-value-list ,x)))
(pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
(format t
"~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]"
(pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
(format t
"~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]"
- (t (with-output-to-string (s)
- (princ str s)))))
+ (t (princ-to-string str))))
+
+(defun functionify (func)
+ "Convert the function-designator FUNC to a function."
+ (declare (type (or function symbol) func))
+ (etypecase func
+ (function func)
+ (symbol (symbol-function func))))
(defun mappend (function list &rest more-lists)
"Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding
(defun mappend (function list &rest more-lists)
"Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding
+(defmacro defconstant* (name value &key doc test)
+ "Define a constant, like `defconstant'. The TEST is an equality test used
+ to decide whether to override the current definition, if any."
+ (let ((temp (gensym)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((,temp ,value))
+ (unless (and (boundp ',name)
+ (funcall ,(or test ''eql) (symbol-value ',name) ,temp))
+ (defconstant ,name ,value ,@(and doc (list doc))))
+ ',name))))
+
(declaim (ftype (function nil ()) slot-unitialized))
(defun slot-uninitialized ()
"A function which signals an error. Can be used as an initializer form in
(declaim (ftype (function nil ()) slot-unitialized))
(defun slot-uninitialized ()
"A function which signals an error. Can be used as an initializer form in
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
each VAR is bound to a gensym, and in the final expansion, each of those
gensyms will be bound to the corresponding VALUE."
(labels ((more (binds)
each VAR is bound to a gensym, and in the final expansion, each of those
gensyms will be bound to the corresponding VALUE."
(labels ((more (binds)
- (let ((tmp (gensym "TMP")) (bind (car binds)))
- `((let ((,tmp ,(cadr bind))
- (,(car bind) (gensym ,(symbol-name (car bind)))))
- `(let ((,,(car bind) ,,tmp))
- ,,@(if (cdr binds)
- (more (cdr binds))
- body)))))))
+ (let ((tmp (gensym "TMP")) (bind (car binds)))
+ `((let ((,tmp ,(cadr bind))
+ (,(car bind) (gensym ,(symbol-name (car bind)))))
+ `(let ((,,(car bind) ,,tmp))
+ ,,@(if (cdr binds)
+ (more (cdr binds))
+ body)))))))
;;;--------------------------------------------------------------------------
;;; Some simple yet useful control structures.
;;;--------------------------------------------------------------------------
;;; Some simple yet useful control structures.
- (labels
- ((more (places)
- (let ((place (car places)))
- (with-gensyms (tmp valtmps valforms
- newtmps setform getform)
- `((let ((,tmp ,(cadr place))
- (,(car place)
- (gensym ,(symbol-name (car place)))))
- (multiple-value-bind
- (,valtmps ,valforms
- ,newtmps ,setform ,getform)
- (get-setf-expansion ,tmp
- ,environment)
- (list 'let*
- (mapcar #'list ,valtmps ,valforms)
- `(symbol-macrolet ((,,(car place)
- (%place-ref ,,getform
- ,,setform
- ,,newtmps)))
- ,,@(if (cdr places)
- (more (cdr places))
- body))))))))))
- (car (more (mapcar #'pairify (listify places))))))))
+ (labels
+ ((more (places)
+ (let ((place (car places)))
+ (with-gensyms (tmp valtmps valforms
+ newtmps setform getform)
+ `((let ((,tmp ,(cadr place))
+ (,(car place)
+ (gensym ,(symbol-name (car place)))))
+ (multiple-value-bind
+ (,valtmps ,valforms
+ ,newtmps ,setform ,getform)
+ (get-setf-expansion ,tmp
+ ,environment)
+ (list 'let*
+ (mapcar #'list ,valtmps ,valforms)
+ `(symbol-macrolet ((,,(car place)
+ (%place-ref ,,getform
+ ,,setform
+ ,,newtmps)))
+ ,,@(if (cdr places)
+ (more (cdr places))
+ body))))))))))
+ (car (more (mapcar #'pairify (listify places))))))))
;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.
;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.
-(defmacro update-place (op place arg &environment env)
- "Update PLACE with the value of OP PLACE ARG, returning the new value."
+(defmacro update-place (op place &rest args &environment env)
+ "Update PLACE with (OP PLACE . ARGS), returning the new value."
- `(setf ,place (,op ,place ,arg))))
+ `(setf ,place (,op ,place ,@args))))
-(defmacro update-place-after (op place arg &environment env)
- "Update PLACE with the value of OP PLACE ARG, returning the old value."
+(defmacro update-place-after (op place &rest args &environment env)
+ "Update PLACE with (OP PLACE . ARGS), returning the old value."
- (setf ,place (,op ,x ,arg))
+ (setf ,place (,op ,x ,@args))
(get-setf-expansion place env)
`(let* (,@(mapcar #'list valtmps valforms))
(make-loc (lambda () ,getform)
(get-setf-expansion place env)
`(let* (,@(mapcar #'list valtmps valforms))
(make-loc (lambda () ,getform)