(defpackage #:mdw.base
(:use #:common-lisp)
- (:export #:unsigned-fixnum
- #:compile-time-defun
- #:show
- #:stringify #:functionify #:mappend
- #:listify #:fix-pair #:pairify
- #:parse-body #:with-parsed-body
- #:whitespace-char-p
- #:slot-uninitialized
- #:nlet #:while #:until #:case2 #:ecase2 #:setf-default
- #:with-gensyms #:let*/gensyms #:with-places
- #:locp #:locf #:ref #:with-locatives
- #:update-place #:update-place-after
- #:incf-after #:decf-after
- #:fixnump)
#+cmu (:import-from #:extensions #:fixnump))
(in-package #:mdw.base)
;;;--------------------------------------------------------------------------
;;; Useful types.
+(export 'unsigned-fixnum)
(deftype unsigned-fixnum ()
"Unsigned fixnums; useful as array indices and suchlike."
`(mod ,most-positive-fixnum))
;;;--------------------------------------------------------------------------
;;; Some simple macros to get things going.
+(export 'compile-time-defun)
(defmacro compile-time-defun (name args &body body)
"Define a function which can be used by macros during the compilation
process."
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ,name ,args ,@body)))
+(export 'show)
(defmacro show (x)
"Debugging tool: print the expression X and its values."
(let ((tmp (gensym)))
(terpri)
(values-list ,tmp))))
+(export 'stringify)
(defun stringify (str)
"Return a string representation of STR. Strings are returned unchanged;
symbols are converted to their names (unqualified!). Other objects are
(symbol (symbol-name str))
(t (princ-to-string str))))
+(export 'functionify)
(defun functionify (func)
"Convert the function-designator FUNC to a function."
(declare (type (or function symbol) func))
(function func)
(symbol (symbol-function func))))
+(export 'mappend)
(defun mappend (function list &rest more-lists)
"Apply FUNCTION to corresponding elements of LIST and MORE-LISTS, yielding
a list. Return the concatenation of all the resulting lists. Like
mapcan, but nondestructive."
(apply #'append (apply #'mapcar function list more-lists)))
+(export 'listify)
(compile-time-defun listify (x)
"If X is a (possibly empty) list, return X; otherwise return (list X)."
(if (listp x) x (list x)))
((cddr x) (error "Too many elements for a pair."))
(t (values (car x) (cadr x))))))
+(export 'fix-pair)
(compile-time-defun fix-pair (x &optional (y nil defaultp))
"Return two values extracted from X. It works as follows:
(A) -> A, Y
where Y defaults to A if not specified."
(do-fix-pair x y defaultp))
+(export 'pairify)
(compile-time-defun pairify (x &optional (y nil defaultp))
"As for fix-pair, but returns a list instead of two values."
(multiple-value-call #'list (do-fix-pair x y defaultp)))
+(export 'whitespace-char-p)
(defun whitespace-char-p (ch)
"Return whether CH is a whitespace character or not."
(case ch
t)
(t nil)))
+(export 'defconstant*)
(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."
(defconstant ,name ,value ,@(and doc (list doc))))
',name))))
+(export 'slot-uninitialized)
(declaim (ftype (function nil ()) slot-unitialized))
(defun slot-uninitialized ()
"A function which signals an error. Can be used as an initializer form in
structure definitions without doom ensuing."
(error "No initializer for slot."))
+(export 'parse-body)
(compile-time-defun parse-body (body &key (allow-docstring-p t))
"Given a BODY (a list of forms), parses it into three sections: a
docstring, a list of declarations (forms beginning with the symbol
(and decls (list (cons 'declare decls)))
forms))))))))
+(export 'with-parsed-body)
(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
,@(if docp nil `((declare (ignore ,docvar))))
,@body))
+(export 'fixnump)
#-cmu
(progn
(declaim (inline fixnump))
;;;--------------------------------------------------------------------------
;;; Generating symbols.
+(export 'with-gensyms)
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
`(let (,@(mapcar (lambda (sym) `(,sym (gensym ,(symbol-name sym))))
(listify syms)))
,@body))
+(export 'let*/gensyms)
(defmacro let*/gensyms (binds &body body)
"A macro helper. BINDS is a list of binding pairs (VAR VALUE), where VALUE
defaults to VAR. The result is that BODY is evaluated in a context where
;;;--------------------------------------------------------------------------
;;; Some simple yet useful control structures.
+(export 'nlet)
(defmacro nlet (name binds &body body)
"Scheme's named let."
(multiple-value-bind (vars vals)
,@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)))
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
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.
"Grim helper macro for with-places."
(values nil nil newtmp setform getform))
+(export 'with-places)
(defmacro with-places (clauses &body body &environment env)
"Define symbols which refer to `setf'-able places.
(symbol-macrolet (,@(nreverse macro-binds))
,@body))))
+(export 'with-places/gensyms)
(defmacro with-places/gensyms (clauses &body body)
"A kind of a cross between `with-places' and `let*/gensyms'.
;;;--------------------------------------------------------------------------
;;; Update-in-place macros built using with-places.
+(export 'update-place)
(defmacro update-place (op place &rest args)
"Update PLACE with (OP PLACE . ARGS), returning the new value."
(with-places/gensyms (place)
`(setf ,place (,op ,place ,@args))))
+(export 'update-place-after)
(defmacro update-place-after (op place &rest args)
"Update PLACE with (OP PLACE . ARGS), returning the old value."
(with-places/gensyms (place)
(setf ,place (,op ,x ,@args))
,x))))
+(export 'incf-after)
(defmacro incf-after (place &optional (by 1))
"Increment PLACE by BY, returning the old value."
`(update-place-after + ,place ,by))
+(export 'decf-after)
(defmacro decf-after (place &optional (by 1))
"Decrement PLACE by BY, returning the old value."
`(update-place-after - ,place ,by))
;;;--------------------------------------------------------------------------
;;; Locatives.
+(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))
+(export 'locf)
(defmacro locf (place &environment env)
"Slightly cheesy locatives. (locf PLACE) returns an object which, using
the `ref' function, can be used to read or set the value of PLACE. It's
(make-loc (lambda () ,getform)
(lambda (,@newtmps) ,setform)))))
+(export 'ref)
(declaim (inline ref (setf ref)))
-
(defun ref (loc)
"Fetch the value referred to by a locative."
(funcall (loc-reader loc)))
-
(defun (setf ref) (new loc)
"Store a new value in the place referred to by a locative."
(funcall (loc-writer loc) new))
+(export 'with-locatives)
(defmacro with-locatives (locs &body body)
"LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
symbol and LOC-EXPR evaluates to a locative. If LOC-EXPR is omitted, it
~mdw / lisp / commitdiff