diff options
| -rw-r--r-- | kif.lisp | 64 |
1 files changed, 45 insertions, 19 deletions
@@ -54,25 +54,51 @@ ;;; one is "it". ;;; -(defmacro kif (test then &optional else) - (flet ((candidate-p (expr) - (not (or (constantp expr) (symbolp expr))))) - (cond - ((or (atom test) (null (cdr test))) `(let ((it ,test)) - (if it ,then ,else))) - ((member (first test) '(not null)) `(kif ,(second test) ,else ,then)) - (t (let* ((sym (first test)) - (args (rest test)) - (n-candidate-args (count-if #'candidate-p args)) - (pos-candidate (or (position-if #'candidate-p args) 0))) - (unless (fboundp sym) - (error "kif: only works with global functions.")) - (when (> n-candidate-args 1) - (error "kif: ambiguous situation: not clear what can be \"it\".")) - (let* ((temps (loop for x in args collecting (gensym))) - (it-temp (nth pos-candidate temps))) - `(let* (,@(mapcar #'list temps args) (it ,it-temp)) - (if (,sym ,@temps) ,then ,else)))))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; + ;; Macro helper: performs steps 3 through 6 of the above + ;; description, returning several values: + ;; - a list of temporary symbols (gensyms) + ;; - a list of forms which can be used to initialize these + ;; symbols in a let-like construct + ;; - an expression equivalent to expr, but which requires + ;; the above bindings to be established. + ;; - a symbol, which one of the gensyms in the first returned value. + ;; If this symbol is bound to its init form, that symbols's + ;; value then is the anaphoric value which can be bound to the "it" + ;; variable. + ;; + (defun anaphorize (construct expr env) + (flet ((candidate-p (expr) + (not (or (constantp expr env) (symbolp expr))))) + (let* ((sym (first expr)) + (args (rest expr)) + (n-candidate-args (count-if #'candidate-p args)) + (pos-candidate (or (position-if #'candidate-p args) 0))) + (unless (fboundp sym) + (error "~a: only works with global functions." construct)) + (when (> n-candidate-args 1) + (error "~a ambiguous situation: not clear what can be \"it\"." + construct)) + (let* ((temps (loop for x in args collecting (gensym))) + (it-temp (nth pos-candidate temps))) + (values temps args `(,sym ,@temps) it-temp)))))) + +(defmacro kif (test then &optional else &environment env) + (cond + ((or (atom test) (null (cdr test))) `(let ((it ,test)) + (if it ,then ,else))) + ((member (first test) '(not null)) `(kif ,(second test) ,else ,then)) + (t (multiple-value-bind (temps args form it-temp) + (anaphorize 'kif test env) + `(let* (,@(mapcar #'list temps args) (it ,it-temp)) + (if ,form ,then ,else)))))) + +(defmacro kwhile (test &rest forms) + (let ((label (gensym "again-"))) + `(block nil + (tagbody ,label + (kif ,test (progn ,@forms (go ,label) (return nil))))))) ;;; ;;; Test cases |