summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Benkard <code@mail.matthias.benkard.de>2007-06-28 15:13:37 +0200
committerMatthias Benkard <code@mail.matthias.benkard.de>2007-06-28 15:13:37 +0200
commit84aa8b5a3c9aabf50bb1a39a632f113e794cf139 (patch)
treed9f1c10a39526e9d70e1e9c1705212804ae0719b
A nicer way of writing LAMBDA forms.
darcs-hash:783a4d0b55541e4e1e122a81f92407280a0420b0
-rw-r--r--lambda.lisp168
-rw-r--r--mulkutils.asd8
2 files changed, 176 insertions, 0 deletions
diff --git a/lambda.lisp b/lambda.lisp
new file mode 100644
index 0000000..29dfb66
--- /dev/null
+++ b/lambda.lisp
@@ -0,0 +1,168 @@
+;;; -*- mode: lisp -*-
+;;; Copyright 2007, Matthias Andreas Benkard.
+
+#| Basic usage
+ | ===========
+ |
+ | (fn + _ 10)
+ | (fn (+ _ 10))
+ | (fn + _0 _1)
+ | (fn + _ _1)
+ | (mapcar (fn (cons _ _)) '(1 2 3)) ;=> ((1 . 1) (2 . 2) (3 . 3))
+ | (funcall (fn + _ 10 _3) 20 30 40 50) ;=> 80
+ |
+ |
+ | Simple variant FN1
+ | ==================
+ |
+ | (funcall (fn () _) 42) ;=> 42
+ | (funcall (fn _) 42) ;=> error (usually)
+ | (funcall (fn1 _) 42) ;=> 42
+ | (funcall (fn +)) ;=> 0
+ | (funcall (fn1 +)) ;=> value of +
+ |
+ |
+ | Argument-number-safe variant EFN
+ | ================================
+ |
+ | (funcall (fn (fn () _))) ;=> #<LAMBDA ...>
+ | (funcall (efn (efn () _))) ;=> error
+ | (funcall (fn1 (fn1 _))) ;=> #<LAMBDA ...>
+ | (funcall (efn1 (efn1 _))) ;=> error
+ |#
+
+
+(defpackage #:mulk.lambda
+ (:use #:cl)
+ (:export #:efn #:fn #:efn1 #:fn1))
+(in-package #:mulk.lambda)
+
+
+(defun collect-lambda-args (clause)
+ (typecase clause
+ (list (mapcan #'collect-lambda-args clause))
+ (symbol (let ((name (symbol-name clause)))
+ (if (or (string= "_" name)
+ (and (char= #\_ (char name 0))
+ (ignore-errors
+ (parse-integer (subseq name 1)))))
+ (list clause)
+ nil)))))
+
+
+(defun find-lambda-args (clause)
+ (let* ((lambda-args (collect-lambda-args clause))
+ (max-arg-no (loop for lambda-arg in lambda-args
+ maximizing
+ (let ((name (symbol-name lambda-arg)))
+ (if (string= "_" name)
+ 0
+ (parse-integer (subseq name 1))))))
+ (arglist (loop for i from 0 to (if (not (null lambda-args))
+ max-arg-no
+ -1)
+ collecting
+ (let ((symbol (find (format nil "_~D" i)
+ lambda-args
+ :key #'symbol-name
+ :test #'string=)))
+ ;; If the user does not use a particular
+ ;; positional argument, we shall not
+ ;; introduce its name, either. Use a
+ ;; GENSYM instead.
+ (or symbol (gensym (format nil "_~D_" i)))))))
+ (cond ((null lambda-args) nil)
+ ((position "_" lambda-args
+ :key #'symbol-name
+ :test #'string=) (cons (intern "_" *package*) arglist))
+ (t arglist))))
+
+
+(defmacro efn (&body args)
+ "A convenience wrapper for LAMBDA.
+
+Positional arguments are numbered from 0 and follow the pattern given by the
+format string \"_~D\". _ can be used as an abbreviation for _0.
+
+FN can be used recursively, but this has to be done with care, for the
+macro will inevitably get confused about the number of arguments it
+should use if a subform uses more lambda arguments than its enclosing FN
+form. For instance, the following will work:
+
+ (funcall (efn (efn () 10) _) 'foo)
+
+But the following will not, because the inner _ is detected by the outer
+FN as an argument, making the latter expect an argument where none is
+given:
+
+ (funcall (efn (efn () _)))"
+ (cond ((null args) `#'(lambda ()))
+ ((not (listp (first args))) `(efn ,args))
+ (t
+ (let* ((lambda-args (find-lambda-args `(progn ,@args)))
+ (real-lambda-args (remove "_" lambda-args
+ :key #'symbol-name
+ :test #'string=))
+ (_ (find "_" lambda-args
+ :key #'symbol-name
+ :test #'string=)))
+ `(symbol-macrolet ,(if _
+ `((,_ ,(first real-lambda-args)))
+ nil)
+ (function (lambda ,real-lambda-args
+ (declare (ignorable ,@real-lambda-args))
+ ,@args)))))))
+
+
+(defmacro fn (&body args)
+ "A less safe but recursively callable variant of EFN.
+
+This macro is like EFN save the fact that the anonymous functions it
+produces do not check the number of their arguments, thereby
+circumventing lambda argument misidentification errors in
+COLLECT-LAMBDA-ARGS."
+ (cond ((null args) `#'(lambda ()))
+ ((not (listp (first args))) `(fn ,args))
+ (t
+ (let* ((lambda-args (find-lambda-args `(progn ,@args)))
+ (real-lambda-args (remove "_" lambda-args
+ :key #'symbol-name
+ :test #'string=))
+ (_ (find "_" lambda-args
+ :key #'symbol-name
+ :test #'string=))
+ (args-sym (gensym "FN-ARGS")))
+ `(symbol-macrolet (,@(if _
+ `((,_ ,(first real-lambda-args)))
+ nil)
+ ,@(loop for i from 0
+ for lambda-arg in real-lambda-args
+ collect `(,lambda-arg
+ (nth ,i ,args-sym))))
+ (function (lambda (&rest ,args-sym)
+ (declare (ignorable ,args-sym))
+ ,@args)))))))
+
+
+(defmacro efn1 (&body args)
+ "A variant of EFN that does not try to interpret its first argument as
+ a function name.
+
+ Useful for stuff like (EFN1 _3).
+
+ (EFN1 a b c ...) is semantically equivalent to (EFN () a b c ...)."
+ (cond ((null args) `(efn))
+ ((not (listp (first args))) `(efn () ,@args))
+ (t `(efn ,@args))))
+
+
+(defmacro fn1 (&body args)
+ "A variant of FN that does not try to interpret its first argument as
+ a function name.
+
+ Useful for stuff like (FN1 _3).
+
+ (FN1 a b c ...) is semantically equivalent to (FN () a b c ...)."
+ (cond ((null args) `(fn))
+ ((not (listp (first args))) `(fn () ,@args))
+ (t `(fn ,@args))))
diff --git a/mulkutils.asd b/mulkutils.asd
new file mode 100644
index 0000000..84a767f
--- /dev/null
+++ b/mulkutils.asd
@@ -0,0 +1,8 @@
+(defsystem "mulkutils"
+ :description "Random utilities by Matthias Benkard."
+ :version "0.0.1"
+ :author "Matthias Benkard <matthias@benkard.de>"
+ :licence "GNU General Public License, version 2 or higher"
+ :depends-on ()
+ :components ((:file "lambda"))
+ :serial t)