;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Basic definitions
;;;
;;; (c) 2005 Mark Wooding
;;;--------------------------------------------------------------------------
;;; Generating symbols.
+(export 'symbolicate)
+(defun symbolicate (&rest names)
+ "Return a symbol constructued by concatenating the NAMES.
+
+ The NAMES are coerced to strings, using the `string' function, so they may
+ be strings, characters, or symbols. The resulting symbol is interned in
+ the current `*package*'."
+ (intern (apply #'concatenate 'string (mapcar #'string names))))
+
(export 'with-gensyms)
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(progn ,@body)
(car (more (mapcar #'pairify (listify binds)))))))
-;;;--------------------------------------------------------------------------
-;;; Some simple yet useful control structures.
-
-(export 'nlet)
-(defmacro nlet (name binds &body body)
- "Scheme's named let."
- (multiple-value-bind (vars vals)
- (loop for bind in binds
- for (var val) = (pairify bind nil)
- collect var into vars
- collect val into vals
- finally (return (values vars vals)))
- `(labels ((,name ,vars
- ,@body))
- (,name ,@vals))))
-
-(export 'while)
-(defmacro while (cond &body body)
- "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
- `(loop (unless ,cond (return)) (progn ,@body)))
-
-(export 'until)
-(defmacro until (cond &body body)
- "If COND is true, evaluate to nil; otherwise evaluate BODY and try again."
- `(loop (when ,cond (return)) (progn ,@body)))
-
-(compile-time-defun do-case2-like (kind vform clauses)
- "Helper function for `case2' and `ecase2'."
- (with-gensyms (scrutinee argument)
- `(multiple-value-bind (,scrutinee ,argument) ,vform
- (declare (ignorable ,argument))
- (,kind ,scrutinee
- ,@(mapcar (lambda (clause)
- (destructuring-bind
- (cases (&optional varx vary) &rest forms)
- clause
- `(,cases
- ,@(if varx
- (list `(let ((,(or vary varx) ,argument)
- ,@(and vary
- `((,varx ,scrutinee))))
- ,@forms))
- forms))))
- clauses)))))
-
-(export 'caase2)
-(defmacro case2 (vform &body clauses)
- "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
- The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
- standard `case' clause has the form (CASES FORMS...). The `case2' form
- evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
- order, just like `case'. If there is a match, then the corresponding
- FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
- the SCRUTINEE (where specified). Note the bizarre defaulting behaviour:
- ARGVAR is less optional than SCRUVAR."
- (do-case2-like 'case vform clauses))
-
-(export 'ecase2)
-(defmacro ecase2 (vform &body clauses)
- "Like `case2', but signals an error if no clause matches the SCRUTINEE."
- (do-case2-like 'ecase vform clauses))
-
-(export 'setf-default)
-(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)))
-
;;;--------------------------------------------------------------------------
;;; Capturing places as symbols.
names gensyms))
,@body))))
+;;;--------------------------------------------------------------------------
+;;; Some simple yet useful control structures.
+
+(export 'nlet)
+(defmacro nlet (name binds &body body)
+ "Scheme's named let."
+ (multiple-value-bind (vars vals)
+ (loop for bind in binds
+ for (var val) = (pairify bind nil)
+ collect var into vars
+ collect val into vals
+ finally (return (values vars vals)))
+ `(labels ((,name ,vars
+ ,@body))
+ (,name ,@vals))))
+
+(export 'while)
+(defmacro while (cond &body body)
+ "If COND is false, evaluate to nil; otherwise evaluate BODY and try again."
+ `(loop (unless ,cond (return)) (progn ,@body)))
+
+(export 'until)
+(defmacro until (cond &body body)
+ "If COND is true, evaluate to nil; otherwise evaluate BODY and try again."
+ `(loop (when ,cond (return)) (progn ,@body)))
+
+(compile-time-defun do-case2-like (kind vform clauses)
+ "Helper function for `case2' and `ecase2'."
+ (with-gensyms (scrutinee argument)
+ `(multiple-value-bind (,scrutinee ,argument) ,vform
+ (declare (ignorable ,argument))
+ (,kind ,scrutinee
+ ,@(mapcar (lambda (clause)
+ (destructuring-bind
+ (cases (&optional varx vary) &rest forms)
+ clause
+ `(,cases
+ ,@(if varx
+ (list `(let ((,(or vary varx) ,argument)
+ ,@(and vary
+ `((,varx ,scrutinee))))
+ ,@forms))
+ forms))))
+ clauses)))))
+
+(export 'caase2)
+(defmacro case2 (vform &body clauses)
+ "VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
+ The CLAUSES have the form (CASES ([[SCRUVAR] ARGVAR]) FORMS...), where a
+ standard `case' clause has the form (CASES FORMS...). The `case2' form
+ evaluates the VFORM, and compares the SCRUTINEE to the various CASES, in
+ order, just like `case'. If there is a match, then the corresponding
+ FORMs are evaluated with ARGVAR bound to the ARGUMENT and SCRUVAR bound to
+ the SCRUTINEE (where specified). Note the bizarre defaulting behaviour:
+ ARGVAR is less optional than SCRUVAR."
+ (do-case2-like 'case vform clauses))
+
+(export 'ecase2)
+(defmacro ecase2 (vform &body clauses)
+ "Like `case2', but signals an error if no clause matches the SCRUTINEE."
+ (do-case2-like 'ecase vform clauses))
+
+(export 'setf-default)
+(defmacro setf-default (&rest specs)
+ "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."
+ `(progn ,@(do ((list nil)
+ (specs specs (cddr specs)))
+ ((endp specs) (nreverse list))
+ (unless (cdr specs)
+ (error "Odd number of arguments for `setf-default'."))
+ (push (with-places/gensyms ((place (car specs)))
+ `(or ,place (setf ,place ,(cadr specs))))
+ list))))
+
;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.
(export 'locp)
(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
"Locative data type. See `locf' and `ref'."
- (reader (slot-uninitialized) :type function)
- (writer (slot-uninitialized) :type function))
+ (reader (slot-uninitialized) :type function :read-only t)
+ (writer (slot-uninitialized) :type function :read-only t))
(export 'locf)
(defmacro locf (place &environment env)
~mdw / lisp / blobdiff