diff options
| -rw-r--r-- | lambda.lisp | 168 | ||||
| -rw-r--r-- | mulkutils.asd | 8 |
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) |