;;; 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.
-;;;
+;;;
;;; 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.
(:export #:unsigned-fixnum
#:compile-time-defun
#:show
- #:stringify #:mappend #:listify #:fix-pair #:pairify #:parse-body
+ #:stringify #:functionify #:mappend
+ #:listify #:fix-pair #:pairify
+ #:parse-body #:with-parsed-body
#:whitespace-char-p
#:slot-uninitialized
- #:nlet #:while #:until #:case2 #:ecase2
+ #:nlet #:while #:until #:case2 #:ecase2 #:setf-default
#:with-gensyms #:let*/gensyms #:with-places
#:locp #:locf #:ref #:with-locatives
#:update-place #:update-place-after
"Debugging tool: print the expression X and its values."
(let ((tmp (gensym)))
`(let ((,tmp (multiple-value-list ,x)))
- (format t "~&")
+ (fresh-line)
(pprint-logical-block (*standard-output* nil :per-line-prefix ";; ")
(format t
"~S = ~@_~:I~:[#<no values>~;~:*~{~S~^ ~_~}~]"
(typecase str
(string str)
(symbol (symbol-name str))
- (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 whitespace-char-p (ch)
"Return whether CH is a whitespace character or not."
(case ch
- ((#\space #\tab #\newline #\return #\vt
- #+cmu #\formfeed
- #+clisp #\page) t)
+ (#.(loop for i below char-code-limit
+ for ch = (code-char i)
+ unless (with-input-from-string (in (string ch))
+ (peek-char t in nil))
+ collect ch)
+ t)
(t nil)))
+(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
(and decls (list (cons 'declare decls)))
forms))))))))
+(defmacro with-parsed-body
+ ((bodyvar declvar &optional (docvar (gensym) docp)) form &body body)
+ "Parse FORM into a body, declarations and (maybe) a docstring; bind BODYVAR
+ to the body, DECLVAR to the declarations, and DOCVAR to (a list
+ containing) the docstring, and evaluate BODY."
+ `(multiple-value-bind
+ (,docvar ,declvar ,bodyvar)
+ (parse-body ,form :allow-docstring-p ,docp)
+ ,@(if docp nil `((declare (ignore ,docvar))))
+ ,@body))
+
#-cmu
(progn
(declaim (inline fixnump))
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
- (listify syms)))
+ (listify syms)))
,@body))
(defmacro let*/gensyms (binds &body body)
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)))))))
(if (null binds)
- `(progn ,@body)
- (car (more (mapcar #'pairify (listify binds)))))))
+ `(progn ,@body)
+ (car (more (mapcar #'pairify (listify binds)))))))
;;;--------------------------------------------------------------------------
;;; Some simple yet useful control structures.
collect val into vals
finally (return (values vars vals)))
`(labels ((,name ,vars
- ,@body))
+ ,@body))
(,name ,@vals))))
(defmacro while (cond &body body)
(list `(let ((,(or vary varx) ,argument)
,@(and vary
`((,varx ,scrutinee))))
- ,@forms))
+ ,@forms))
forms))))
clauses)))))
"Like `case2', but signals an error if no clause matches the SCRUTINEE."
(do-case2-like 'ecase vform clauses))
+(defmacro setf-default (&rest specs &environment env)
+ "Like setf, but only sets places which are currently nil.
+
+ The arguments are an alternating list of PLACEs and DEFAULTs. If a PLACE
+ is nil, the DEFAULT is evaluated and stored in the PLACE; otherwise the
+ default is /not/ stored. The result is the (new) value of the last
+ PLACE."
+ (labels ((doit (specs)
+ (cond ((null specs) nil)
+ ((null (cdr specs))
+ (error "Odd number of arguments for SETF-DEFAULT."))
+ (t
+ (let ((place (car specs))
+ (default (cadr specs))
+ (rest (cddr specs)))
+ (multiple-value-bind
+ (vars vals store-vals writer reader)
+ (get-setf-expansion place env)
+ `(let* ,(mapcar #'list vars vals)
+ (or ,reader
+ (multiple-value-bind ,store-vals ,default
+ ,writer))
+ ,@(and rest (list (doit rest))))))))))
+ (doit specs)))
+
;;;--------------------------------------------------------------------------
-;;; with-places
+;;; Capturing places as symbols.
(defmacro %place-ref (getform setform newtmp)
"Grim helper macro for with-places."
(if (null places)
`(progn ,@body)
(let*/gensyms (environment)
- (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.
(get-setf-expansion place env)
`(let* (,@(mapcar #'list valtmps valforms))
(make-loc (lambda () ,getform)
- (lambda (,@newtmps) ,setform)))))
+ (lambda (,@newtmps) ,setform)))))
(declaim (inline loc (setf loc)))
~mdw / lisp / blobdiff