[misc-extensions-cvs] r1 - src
sburson at common-lisp.net
sburson at common-lisp.net
Sat Jan 6 23:32:19 UTC 2007
Author: sburson
Date: Sat Jan 6 18:32:18 2007
New Revision: 1
Added:
src/
src/defs.lisp
src/gmap.lisp
src/new-let.lisp
Log:
Initial commit.
Added: src/defs.lisp
==============================================================================
--- (empty file)
+++ src/defs.lisp Sat Jan 6 18:32:18 2007
@@ -0,0 +1,17 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-User -*-
+
+;;; This file is in the public domain. It is provided with ABSOLUTELY
+;;; NO WARRANTY.
+
+(in-package :cl-user)
+
+(defpackage :new-let
+ (:use :cl)
+ (:shadow cl:let cl:cond)
+ (:export #:let #:cond #:nlet #:bcond))
+
+(defpackage :gmap
+ (:use :cl)
+ (:export #:gmap)
+ (:import-from :new-let #:nlet #:bcond))
+
Added: src/gmap.lisp
==============================================================================
--- (empty file)
+++ src/gmap.lisp Sat Jan 6 18:32:18 2007
@@ -0,0 +1,617 @@
+; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: (GMAP Common-Lisp) -*-
+(in-package gmap)
+
+;
+; GMAP, version 3.2, by Scott L. Burson
+;
+; This file is in the public domain.
+;
+; The GMAP macro provides a new kind of iteration facility in LISP.
+; Basically, it is intended for when you would like to use MAPCAR, but
+; can't because the things you want to map over aren't in lists, or you
+; need to collect the results of the mapping into something other than a
+; list. That is, GMAP is probably the right thing to use when you are
+; using iteration to perform the same computation on each element of
+; some collection, as opposed to changing your state in some complicated
+; way on every iteration of a loop.
+; In fact, it's conceptually reasonable to imagine all the iterations of a
+; GMAP as happening in parallel, just as you might with MAPCAR. The
+; difference is that with GMAP you explicitly say, via keywords, what kinds
+; of collections the elements come in and what kind of collection to make
+; from the result. For example, the following two expressions are equivalent:
+; (mapcar #'foo this-list that-list) and
+; (gmap :list #'foo (:list this-list) (:list that-list))
+; The first :list keyword indicates that GMAP is to build a list; the other
+; two tell it that this-list and that-list are in fact lists of elements over
+; which foo is to be mapped. Other keywords exist besides :list; for
+; example, :string, if used as an argument keyword, causes its argument
+; to be viewed as a string; the values it "generates" for the function being
+; mapped are the successive characters of the string.
+; Perhaps the best feature of GMAP is its facility for defining one's own
+; keywords. Thus you can adapt it to other kinds of data structures over
+; which you would like to iterate.
+;
+; The overall syntax of GMAP is:
+; (gmap <result-spec> <fn>
+; <arg-spec-0>
+; <arg-spec-1>
+; ... )
+; where <fn> is the function being mapped, just like the first argument
+; to MAPCAR. The <result-spec> and the <arg-spec-i> are lists, whose first
+; element is a keyword indicating the type of result constructor or argument
+; generator, and the interpretation of whose subsequent elements depends on
+; that type. For example, in:
+; (gmap :list #'+
+; (:list '(14 32 51))
+; (:index 3))
+; #'+ is the function to be mapped;
+; the result-type of :list specifies that a list is to be constructed containing
+; the results;
+; the first arg-spec specifies that the first argument to the function
+; being mapped will be successive elements of the list '(14 32 51);
+; and the second arg-spec says that the second argument will be successive
+; integers starting with 3.
+; The result, of course, is (17 36 56).
+;
+; **** Argument generators ****
+; Each generator is given one variable in which to maintain its state. We have
+; to tell GMAP explicitly how to get from the current value of the state variable
+; to a)the value to be generated and b)the next value of the state variable.
+;
+; The keyword, the first element, of each argument spec tells what kind of
+; generator to use. NIL as a keyword specifies that one is defining a generator
+; for this instance of GMAP only instead of using one of the predefined ones.
+; A NIL-type arg-spec has the following syntax:
+; (nil <init> &optional <exitp> <argfn> <nextfn> <let-specs>)
+; where <init> is the initial value of the generator's state variable;
+; <exitp>, if non-nil, is a function of one argument; when it becomes true of
+; [i.e., returns a non-nil value when applied to] the state variable, the
+; iteration terminates. If it is absent or nil, this generator has no exit-test.
+; If more than one arg-spec supplies an exitp, then the
+; first one to finish terminates the entire iteration [just like mapcar, which
+; stops when any list runs out].
+; <argfn>, if non-nil, is a function of one argument which is applied to the
+; current value of the state variable to get the value the generator actually
+; returns on this iteration.
+; <nextfn>, if non-nil, is a function of one argument which takes the current
+; value of the state variable and returns the next.
+; <let-specs> facilitates arbitrary hair and is explained below.
+; For example, an arg-spec of (:list foo) is equivalent to
+; (nil foo #'null #'car #'cdr)
+; where foo is the initial value of the list; #'null is the predicate that says
+; when the list has run out; #'car, the argfn, is what is done to the list to
+; get the current element; and #'cdr, the nextfn, is what is done to the list
+; to get the next list.
+;
+; An argument generator described this way is conceptually equivalent to
+; (let `(state-var ,@<let-specs>)
+; #'(lambda ()
+; (if (<exitp> state-var)
+; (*throw 'exit-iteration nil)
+; (prog1 (<argfn> state-var)
+; (setq state-var (<nextfn> state-var))))))
+;
+; Note that if only (nil <init>) is specified, the argument is a constant <init>;
+; no more circular-list'ing!
+;
+; Other predefined argument types include:
+; (:constant <value>)
+; A more readable version of `(nil <value>)'.
+; (:list <list>)
+; As shown in examples above: supplies successive elements of <list>.
+; (:index <start> &optional <stop> <incr>)
+; Provides numbers beginning at <start> and going to (but not including) <stop>
+; incrementing by <incr> each time. If <stop> is missing or nil, this generates
+; numbers indefinitely. <incr> may be positive or negative and defaults to 1.
+; (:index-inc <start> <stop> &optional <incr>)
+; "Index, INClusive": like :index, but the numbers generated include <stop>.
+; (:vector <vector>)
+; Generates successive elements of <vector>.
+; (:simple-vector <vector>)
+; Generates successive elements of <vector> (which must be simple).
+; (:string <string>)
+; Generates successive characters of <string>.
+; (:simple-string <string>)
+; Generates successive characters of <string> (which must be simple).
+; (:exp <initial-value> <base>)
+; Generates an exponential sequence whose first value is <initial-value>, and
+; whose value is multiplied by <base> on each iteration.
+;
+; **** Result Constructors ****
+; Like arg-specs, result-specs begin with a keyword saying what kind of
+; constructor to use, i.e., how to put together the results of the function
+; being mapped. And again, a keyword of NIL means that no predefined
+; constructor is being used. A NIL-type result-spec looks like:
+; (nil <init> <resfn> &optional <cleanup> <filterp> <let-specs>)
+; where
+; <init> is the initial value of the constructor's state variable;
+; <resfn> is a function of two arguments, the current value of the state variable
+; and the current value returned by the function being mapped; it gives the next
+; value of the state variable.
+; <cleanup>, if present and non-nil, is a function of one argument that
+; translates the final value of the state variable into the value that the GMAP
+; actually returns.
+; <filterp>, if present and non-nil, is a predicate of one argument; when it is false
+; of the current value of the function being mapped, <resfn> is not called on that
+; iteration, and the value of the state variable is unchanged.
+; <let-specs>, as before, is hairy; I'll get back to it below.
+; For example, a res-spec of (:list) is equivalent to
+; (nil nil #'(lambda (a b) (cons b a)) #'nreverse)
+; -- the state variable starts at nil, gets successive values consed onto it, and
+; gets nreversed before being returned.
+;
+; A result-spec that supplies no arguments may be written without the parens; so
+; (:list) and :list are equivalent.
+;
+; Other predefined result types include:
+; :list
+; Generates a list, like mapcar, of the values.
+; :and
+; Returns the first NIL, or the last value if none are NIL.
+; :or
+; Returns the first non-NIL, or NIL if all values are NIL.
+; :sum
+; Returns the sum of the values. E.g., to get sum of products, use
+; (gmap :sum #'* ...)
+; (:array <initial-array>)
+; Generates an array of the values. You supply the initial array; the values
+; are stored starting with element 0. If the array has a fill pointer, it is
+; set upon exit to the number of elements stored. The array itself is returned.
+; (:string &optional <length-guess>)
+; Generates a string from the values. <length-guess> is the initially allocated
+; string size; it defaults to 20. #'array-push-extend is used to append each
+; character.
+; (:values &rest <result-specs>)
+; The function being mapped is expected to return as many values as there are
+; result-specs; each value is accumulated separately according to its respective
+; result-spec, and finally, all the result values are returned.
+;
+; **** User-defined argument and result types ****
+; A useful feature of GMAP is the provision for the user to define his/her own
+; argument generators and result constructors. For example, if in some program you
+; commonly iterate over words in a sentence, or lines in an editor buffer, or users
+; currently logged on, then define an argument type SENTENCE, or LINES, or USERS.
+; And similarly with result-types. The way this is done [which I'm not yet sure is
+; entirely satisfactory] is with the two special forms DEF-GMAP-ARG-TYPE and
+; DEF-GMAP-RES-TYPE. These have syntax like DEFUN:
+; (def-gmap-foo-type <name> (<args>)
+; <body>)
+; When <name> is seen as the keyword of an arg- or result-spec, and has
+; been defined with the appropriate special form, then the function
+; #'(lambda (<args>) <body>) is applied to the cdr of the spec; that is,
+; the keyword itself has been stripped off. Whatever this returns is interpreted
+; as a nil-type spec, except, again, without the keyword "nil". For example, the
+; arg-type :list is actually defined by
+; (def-gmap-arg-type :list (initial-list)
+; `(,initial-list ; init
+; #'null #'car #'cdr)) ; exitp, argfn, and resfn
+;
+; Lists of what arg- and result-types are defined can be found in the variables
+; *GMAP-ARG-TYPE-LIST* and *GMAP-RES-TYPE-LIST*.
+;
+; Now for the promised explanation about let-specs. Sometimes [indeed, fairly
+; often] a user-defined type will want to compute values and bind variables
+; other than those automatically provided by the iteration. For example, the
+; index type goes to some trouble to evaluate its parameters only once. It does
+; this by providing a list of specs, i.e., (<var> <value>) pairs, which go into
+; a LET that surrounds the entire iteration. Except, that is, for the following
+; hack: if you want several dependent initializations, e.g., you want foo to be
+; something hairy and bar to be the cdr of foo, you can indicate the dependence
+; by the nesting in list structure of the specs:
+; ((foo (something-hairy))
+; ((bar (cdr foo))))
+; This will cause a gmap that uses this type to expand into
+; (let ((foo (something-hairy)))
+; (let ((bar (cdr foo)))
+; ... [iteration] ...))
+; For details, see the NLET macro at the end of this file. For examples,
+; see some of the types defined herein.
+
+; Remaining tidbits:
+; Many arg- and result-specs take optional parameters, which are defined to do
+; something only if both present and non-nil. By "non-nil" here I mean non-nil
+; *at expansion time*.
+; The function being mapped can itself be nil, subject of course to the above
+; considerations; in which case the identity function of the first argument is
+; used, and other arguments are ignored.
+
+; Bugs:
+;
+; Purists will object to the use of symbols in the keyword package rather than
+; the `lisp' package for the arg- and result-types. It would make sense for
+; these symbols to come from the package providing the types they refer to;
+; among other advantages, this would prevent name collisions (which is, after
+; all, the whole point of the package system). Against this very reasonable
+; argument is my desire to have it immediately apparent to someone seeing a
+; `gmap' form, perhaps for the first time, that it is a macro with somewhat
+; unusual syntax; the use of ordinary Lisp symbols (`list', `vector', etc.)
+; would tend to disguise this fact. Anyway, there's nothing requiring the arg-
+; and result-type names to be in the keyword package; anyone who strongly
+; dislikes this is welcome to define names in some other package.
+
+; The top-level macro.
+(defmacro gmap (res-spec fn &rest arg-spec-list)
+ (gmap>expand fn
+ (gmap>res-spec-lookup res-spec)
+ (mapcar #'gmap>arg-spec-lookup arg-spec-list)))
+
+; This does the real work.
+(defun gmap>expand (fn res-specs arg-spec-list)
+ (let ((param-list
+ (mapcar #'gmap>param arg-spec-list))
+ (result-list (gmap>res>init-clauses res-specs))
+ (let-specs (gmap>let-specs arg-spec-list res-specs)))
+ (let ((one-value-p (null (cdr result-list)))
+ (fnval-vars (mapcar #'(lambda (ignore)
+ (declare (ignore ignore))
+ (gensym))
+ result-list)))
+ `(nlet ,let-specs
+ (do (, at param-list
+ , at result-list)
+ ((or ,@(apply #'append (mapcar #'gmap>param>exit-test ; exit test
+ param-list arg-spec-list)))
+ ,(gmap>res>cleanup res-specs result-list one-value-p))
+ ,(if one-value-p
+ (if (car fnval-vars)
+ `(let ((,(car fnval-vars)
+ ,(apply #'gmap>funcall fn
+ (mapcar #'gmap>param>arg param-list arg-spec-list))))
+ (setq ,(caar result-list)
+ ,(gmap>res>next (car res-specs) (caar result-list)
+ (car fnval-vars))))
+ #| Null result spec -- just call the function for effect. |#
+ (apply #'gmap>funcall fn
+ (mapcar #'gmap>param>arg param-list arg-spec-list)))
+ `(multiple-value-bind ,fnval-vars
+ ,(apply #'gmap>funcall fn
+ (mapcar #'gmap>param>arg param-list arg-spec-list))
+ . ,(mapcar #'(lambda (fnval result-pair res-spec)
+ `(setq ,(car result-pair)
+ ,(gmap>res>next res-spec (car result-pair) fnval)))
+ fnval-vars result-list res-specs))))))))
+
+
+; extract the let-specs.
+(defun gmap>let-specs (arg-specs res-specs)
+ (nconc (mapcan #'fifth arg-specs) (mapcan #'fifth res-specs)))
+
+; generate the do-variable spec for each argument.
+(defun gmap>param (arg-spec)
+ (let ((param-name (gensym))
+ (init (first arg-spec))
+ (nextfn (fourth arg-spec)))
+ `(,param-name
+ ,init
+ ,@(if nextfn
+ `(,(gmap>funcall nextfn param-name))
+ nil))))
+
+; get the argument to the function being mapped from the do-variable.
+(defun gmap>param>arg (param arg-spec)
+ (let ((param-name (first param))
+ (argfn (third arg-spec)))
+ (gmap>funcall argfn param-name)))
+
+; get the exit test for the variable.
+(defun gmap>param>exit-test (param arg-spec)
+ (let ((param-name (first param))
+ (exitp (second arg-spec)))
+ (if exitp
+ `(,(gmap>funcall exitp param-name))
+ nil)))
+
+; get the initial value of the result.
+(defun gmap>res>init-clauses (res-specs)
+ (mapcan #'(lambda (res-spec) (and res-spec (cons (list (gensym) (first res-spec)) nil)))
+ res-specs))
+
+; compute the next value of the result from the current one and the
+; current value of the function.
+(defun gmap>res>next (res-spec result fnval)
+ (let ((resfn (second res-spec))
+ (filterp (fourth res-spec)))
+ (if filterp
+ `(if ,(gmap>funcall filterp fnval)
+ ,(gmap>funcall resfn result fnval)
+ ,result)
+ (gmap>funcall resfn result fnval))))
+
+; call the cleanup function on exit.
+(defun gmap>res>cleanup (res-specs result-list one-value-p)
+ (if one-value-p
+ (gmap>funcall (third (car res-specs)) (caar result-list))
+ `(values . ,(mapcar #'(lambda (res-spec result-pair)
+ (gmap>funcall (third res-spec) (car result-pair)))
+ res-specs result-list))))
+
+; For some reason, the compiler doesn't convert, e.g., (funcall #'car foo)
+; to (car foo); thus we lose some efficiency for functions that would normally
+; open-code, like car. Hence this function to perform the optimization for it.
+(defun gmap>funcall (function &rest args)
+ (let ((args (copy-list args)))
+ (cond ((or (null function) (eq function ':id))
+ (car args))
+ ((and (listp function)
+ (eq (car function) 'function))
+ `(,(cadr function) . ,args))
+ (t `(funcall ,function . ,args)))))
+
+
+
+(eval-when (:execute :compile-toplevel :load-toplevel)
+ (defvar *gmap-arg-type-list* nil
+ "A list of all GMAP arg types that have been defined.")
+ (defvar *gmap-res-type-list* nil
+ "A list of all GMAP result types that have been defined."))
+
+; define an arg-type.
+(defmacro def-gmap-arg-type (name args &body body)
+ (let ((fn-name (gensym "GMAP-ARG-SPEC-EXPANDER-")))
+ `(progn
+ 'compile
+ (defun ,fn-name ,args . ,body)
+ (eval-when (:execute :compile-toplevel :load-toplevel)
+ (setf (get ',name ':gmap-arg-spec-expander) ',fn-name)
+ (pushnew ',name *gmap-arg-type-list*)))))
+
+; define a result-type.
+(defmacro def-gmap-res-type (name args &body body)
+ (let ((fn-name (gensym "GMAP-RES-SPEC-EXPANDER-")))
+ `(progn
+ 'compile
+ (defun ,fn-name ,args . ,body)
+ (eval-when (:execute :compile-toplevel :load-toplevel)
+ (setf (get ',name ':gmap-res-spec-expander) ',fn-name)
+ (pushnew ',name *gmap-res-type-list*)))))
+
+; look up an arg type.
+(defun gmap>arg-spec-lookup (raw-arg-spec)
+ (let ((type (car raw-arg-spec)))
+ (if (null type)
+ (cdr raw-arg-spec)
+ (let ((generator (get type ':gmap-arg-spec-expander)))
+ (if generator
+ (apply generator (cdr raw-arg-spec))
+ (error "Argument spec, ~S, to gmap is of unknown type
+ (Do you have the package right?)"
+ raw-arg-spec))))))
+
+; look up a result type.
+(defun gmap>res-spec-lookup (raw-res-spec)
+ (if (and (listp raw-res-spec)
+ (eq (car raw-res-spec) ':values))
+ (mapcar #'gmap>res-spec-lookup-1 (cdr raw-res-spec))
+ (cons (gmap>res-spec-lookup-1 raw-res-spec) nil)))
+(defun gmap>res-spec-lookup-1 (raw-res-spec)
+ (let ((type (if (listp raw-res-spec) (car raw-res-spec)
+ raw-res-spec)))
+ (if (null type)
+ (cdr raw-res-spec)
+ (let ((generator (get type ':gmap-res-spec-expander)))
+ (if generator
+ (apply generator (and (listp raw-res-spec) (cdr raw-res-spec)))
+ (error "Result spec, ~S, to gmap is of unknown type
+ (Do you have the package right?)"
+ raw-res-spec))))))
+
+
+
+; ******** Predefined argument types ********
+; See above for documentation.
+
+(def-gmap-arg-type :constant (value)
+ `(,value))
+
+(def-gmap-arg-type :list (initial-list)
+ `(,initial-list
+ #'null #'car #'cdr))
+
+(def-gmap-arg-type :index (start &optional stop incr)
+ (let ((incr-temp (gensym))
+ (stop-temp (gensym))
+ (bounds-fn-temp (gensym)))
+ `(,start ; init
+ ,(if stop ; exitp
+ (if incr
+ `#'(lambda (val)
+ (funcall ,bounds-fn-temp val ,stop-temp))
+ `#'(lambda (val) (declare (type fixnum val))
+ (>= val ,stop-temp)))
+ 'nil)
+ nil ; no argfn
+ ,(if incr ; nextfn
+ `#'(lambda (val) (declare (type fixnum val))
+ (+ val ,incr-temp))
+ '#'1+)
+ (,@(if incr ; and let-specs
+ `((,incr-temp ,incr)
+ ((,bounds-fn-temp (if (minusp ,incr-temp) #'<= #'>=)))))
+ ,@(if stop
+ `((,stop-temp ,stop)))))))
+
+(def-gmap-arg-type :index-inc (start &optional stop incr)
+ (let ((incr-temp (gensym))
+ (stop-temp (gensym))
+ (bounds-fn-temp (gensym)))
+ `(,start ; init
+ ,(if stop ; generate (possibly hairy) exitp
+ (if incr
+ `#'(lambda (val)
+ (funcall ,bounds-fn-temp val ,stop-temp))
+ `#'(lambda (val) (declare (type fixnum val))
+ (> val ,stop-temp)))
+ 'nil)
+ nil ; no argfn
+ ,(if incr ; nextfn
+ `#'(lambda (val) (declare (type fixnum val))
+ (+ val ,incr-temp))
+ '#'1+)
+ (,@(if incr ; and let-specs
+ `((,incr-temp ,incr)
+ ((,bounds-fn-temp (if (minusp ,incr-temp) #'< #'>)))))
+ ,@(if stop
+ `((,stop-temp ,stop)))))))
+
+;;; Deprecated; use `:vector'.
+(def-gmap-arg-type :array (array &optional start stop incr)
+ (let ((array-temp (gensym))
+ (incr-temp (and incr (gensym)))
+ (stop-temp (gensym)))
+ `(,(or start 0)
+ #'(lambda (i) (>= i ,stop-temp))
+ #'(lambda (i) (aref ,array-temp i))
+ #'(lambda (x) (+ x ,(or incr-temp 1)))
+ ((,array-temp ,array)
+ ,@(and incr `((,incr-temp ,incr)))
+ ((,stop-temp ,(or stop `(length ,array-temp))))))))
+
+(def-gmap-arg-type :vector (array &optional start stop incr)
+ (let ((array-temp (gensym))
+ (incr-temp (and incr (gensym)))
+ (stop-temp (gensym)))
+ `(,(or start 0)
+ #'(lambda (i) (>= i ,stop-temp))
+ #'(lambda (i) (aref ,array-temp i))
+ #'(lambda (x) (+ x ,(or incr-temp 1)))
+ ((,array-temp ,array)
+ ,@(and incr `((,incr-temp ,incr)))
+ ((,stop-temp ,(or stop `(length ,array-temp))))))))
+
+(def-gmap-arg-type :simple-vector (array &optional start stop incr)
+ (let ((array-temp (gensym))
+ (incr-temp (and incr (gensym)))
+ (stop-temp (gensym)))
+ `(,(or start 0)
+ #'(lambda (i) (declare (type fixnum i)) (>= i ,stop-temp))
+ #'(lambda (i) (declare (type fixnum i)) (svref ,array-temp i))
+ #'(lambda (i) (declare (type fixnum i)) (+ i ,(or incr-temp 1)))
+ ((,array-temp ,array)
+ ,@(and incr `((,incr-temp (the fixnum ,incr))))
+ ((,stop-temp (the fixnum ,(or stop `(length ,array-temp)))))))))
+
+; This is like :array but coerces the object to a string first.
+(def-gmap-arg-type :string (string &optional start stop incr)
+ (let ((string-temp (gensym))
+ (incr-temp (and incr (gensym)))
+ (stop-temp (gensym)))
+ `(,(or start 0)
+ #'(lambda (i) (>= i ,stop-temp))
+ #'(lambda (i) (char ,string-temp i))
+ #'(lambda (x) (+ x ,(or incr-temp 1)))
+ ((,string-temp (string ,string))
+ ,@(and incr `((,incr-temp ,incr)))
+ ((,stop-temp ,(or stop `(length ,string-temp))))))))
+
+(def-gmap-arg-type :simple-string (string &optional start stop incr)
+ (let ((string-temp (gensym))
+ (incr-temp (and incr (gensym)))
+ (stop-temp (gensym)))
+ `(,(or start 0)
+ #'(lambda (i) (>= i ,stop-temp))
+ #'(lambda (i) (schar ,string-temp i))
+ #'(lambda (x) (+ x ,(or incr-temp 1)))
+ ((,string-temp (string ,string))
+ ,@(and incr `((,incr-temp ,incr)))
+ ((,stop-temp ,(or stop `(length ,string-temp))))))))
+
+
+; ******** Predefined result types ********
+
+(def-gmap-res-type :list (&optional filterp)
+ `(nil #'xcons #'nreverse ,filterp))
+
+(defun xcons (a b)
+ (cons b a))
+
+(def-gmap-res-type :nconc (&optional filterp)
+ (let ((result-var (gensym))) ; have to use our own, sigh.
+ `(nil ; init
+ #'(lambda (tail-loc new) ; nextfn
+ (if tail-loc (rplacd tail-loc new)
+ (setq ,result-var new))
+ (if new (last new) tail-loc))
+ #'(lambda (ignore)
+ (declare (ignore ignore))
+ ,result-var)
+ ,filterp
+ ((,result-var nil)))))
+
+(def-gmap-res-type :and ()
+ '(t #'(lambda (ignore new)
+ (declare (ignore ignore))
+ (if new new (return nil)))))
+
+(def-gmap-res-type :or ()
+ '(nil #'(lambda (ignore new)
+ (declare (ignore ignore))
+ (if new (return new) nil))))
+
+(def-gmap-res-type :sum ()
+ '(0 #'+))
+
+(def-gmap-res-type :count-if ()
+ '(0 #'(lambda (n new)
+ (if new (1+ n) n))))
+
+(def-gmap-res-type :max ()
+ '(nil #'max-with-nil-id))
+
+(defun max-with-nil-id (x y)
+ (if (null x) y
+ (if (null y) x
+ (max x y))))
+
+(def-gmap-res-type :min ()
+ '(nil #'min-with-nil-id))
+
+(defun min-with-nil-id (x y)
+ (if (null x) y
+ (if (null y) x
+ (min x y))))
+
+;;; Deprecated; use `:vector'.
+(def-gmap-res-type :array (initial-empty-array)
+ (let ((array-temp (gensym)))
+ `(0 ; init
+ #'(lambda (curr-index next-elt) ; nextfn
+ (setf (aref ,array-temp curr-index) next-elt)
+ (1+ curr-index))
+ #'(lambda (last-index) ; cleanup
+ (if (array-has-fill-pointer-p ,array-temp)
+ (setf (fill-pointer ,array-temp) last-index))
+ ,array-temp)
+ nil ; filterp
+ ((,array-temp ,initial-empty-array))))) ; let-specs
+
+(def-gmap-res-type :vector (initial-empty-vector)
+ (let ((vector-temp (gensym)))
+ `(0 ; init
+ #'(lambda (curr-index next-elt) ; nextfn
+ (setf (aref ,vector-temp curr-index) next-elt)
+ (1+ curr-index))
+ #'(lambda (last-index) ; cleanup
+ (if (vector-has-fill-pointer-p ,vector-temp)
+ (setf (fill-pointer ,vector-temp) last-index))
+ ,vector-temp)
+ nil ; filterp
+ ((,vector-temp ,initial-empty-vector))))) ; let-specs
+
+(def-gmap-res-type :string (&optional (length-guess 20.))
+ `((make-array ,length-guess ; init
+ :element-type :character
+ :adjustable t :fill-pointer 0)
+ #'(lambda (string char) ; nextfn
+ (vector-push-extend char string)
+ string)))
+
+(def-gmap-arg-type :exp (initial-value base)
+ (let ((base-temp (gensym)))
+ `(,initial-value
+ nil
+ nil
+ #'(lambda (x) (* x ,base-temp))
+ ((,base-temp ,base)))))
+
+
+; End of gmap.lisp
Added: src/new-let.lisp
==============================================================================
--- (empty file)
+++ src/new-let.lisp Sat Jan 6 18:32:18 2007
@@ -0,0 +1,327 @@
+(in-package :new-let)
+
+;;; This file is in the public domain.
+
+;;; This code implements a new LET macro with expanded syntax and semantics,
+;;; a generalization of LET, LET*, and MULTIPLE-VALUE-BIND. Some examples:
+;;;
+;;; (let ((a (foo))
+;;; ((b (bar a))))
+;;; ...)
+;;;
+;;; This example illustrates that clause nesting depth is used to indicate
+;;; ordering of evaluation and binding. B is bound after A, and its initial
+;;; value expression refers to A.
+;;;
+;;; (let ((a b c (zot))
+;;; ((d (quux a c))
+;;; ((e f (mumble b d))
+;;; (g (mung a))))
+;;; ((h (frobozz c))
+;;; ((i (xyzzy h))))
+;;; (*print-level* 3))
+;;; ...)
+;;;
+;;; A, B, and C are bound to the first three values of (ZOT), and in parallel,
+;;; *PRINT-LEVEL* is bound to 3; then D and H are bound; then E, F, G, and I
+;;; are bound.
+;;;
+;;; As this example illustrates, all bindings at a given nesting level are
+;;; done in parallel, with all bindings at a deeper level following.
+;;;
+;;; Since I like to use multiple values, I find this syntax for binding them
+;;; very handy, and I think many will agree. (Those familiar with Dylan
+;;; will think that I have borrowed the idea from it, but I wrote the first
+;;; version of this macro in 1980.) The value of using nesting to indicate
+;;; sequencing will perhaps be less clear. The additional flexibility
+;;; provided, compared to LET*, is admittedly rarely of importance in terms
+;;; of expressing an idea in fewer keystrokes. Personally, though, I like
+;;; being able to indicate clearly the data flow dependences among the
+;;; various variables I may be binding in one LET; and I have written LET
+;;; expressions of complexity comparable to the second example above. (I
+;;; should emphasize that the breaking up of the clauses into groups, as in
+;;; that second example, to emphasize their data dependence relationships
+;;; is strictly for clarity; in fact, the initial value expression for G,
+;;; for instance, is within the scope of H.)
+;;;
+;;; This code also implements an extension to COND. It is simply this: that
+;;; if the predicate expression of a COND clause is a LET form, the scope of
+;;; all variables bound by the LET is extended to include the consequent
+;;; expressions of the clause. (However, it does not include subsequent
+;;; clauses.) This simplifies the writing of somewhat Prolog-like code that
+;;; simultaneously tests that an object has a certain structure and binds
+;;; variables to parts of that structure in order to do something else.
+;;; (In order to be recognized as such, the predicate expression must be
+;;; written as a LET form, not a macro invocation that expands to a LET form.
+;;; I think this is a feature, but am open to being persuaded otherwise.)
+;;;
+;;; To use these macros, you must shadow the standard definitions in your
+;;; package. This can be done by including the following option clause in
+;;; your DEFPACKAGE form:
+;;;
+;;; (:shadowing-import-from "NEW-LET" "LET" "COND")
+;;;
+;;; If for some reason you don't want to shadow these, you can access this
+;;; version of LET as NLET, and this version of COND as BCOND (the "B" is
+;;; for "binding"), by using the following DEFPACKAGE option instead:
+;;;
+;;; (:import-from "NEW-LET" "NLET" "BCOND")
+;;;
+;;; Enjoy!
+;;; Scott L. Burson 2/18/2005
+
+
+(defmacro let (clauses &body body)
+ "A generalization of CL:LET that better supports nested bindings and multiple
+values. Syntax: (let (<clause>*) <body>). The <clause> syntax is more general
+than for CL:LET:
+ <clause> ::= <symbol> ; binds to NIL
+ | ( <symbol> ) ; likewise
+ | <clause1>
+ <clause1> ::= ( <symbol>+ <form> ) ; binding
+ | ( <clause1>+ ) ; nesting
+When a clause begins with more than one variable name, they are to be bound to
+successive values of the form. The nesting of clauses indicates sequencing of
+bindings; more deeply nested clauses may reference bindings of shallower clauses.
+All bindings at a given depth are done in parallel. This allows arbitrary
+combinations of parallel and sequential binding. Standard declarations at the
+head of BODY are handled correctly, though nonstandard ones may not be. If two
+variables of the same name are bound at different levels, any declaration
+applies to the inner one."
+ (multiple-value-bind (decls body)
+ (analyze-decls clauses body)
+ (car (expand-new-let clauses body decls))))
+
+;;; Alternative name for the above. I could have this one expand into that
+;;; one, or conversely, but I'd want to duplicate the doc string anyway, and
+;;; that's most of the code.
+(defmacro nlet (clauses &body body)
+ "A generalization of CL:LET that better supports nested bindings and multiple
+values. Syntax: (let (<clause>*) <body>). The <clause> syntax is more general
+than for CL:LET:
+ <clause> ::= <symbol> ; binds to NIL
+ | ( <symbol> ) ; likewise
+ | <clause1>
+ <clause1> ::= ( <symbol>+ <form> ) ; binding
+ | ( <clause1>+ ) ; nesting
+When a clause begins with more than one variable name, they are to be bound to
+successive values of the form. The nesting of clauses indicates sequencing of
+bindings; more deeply nested clauses may reference bindings of shallower clauses.
+All bindings at a given depth are done in parallel. This allows arbitrary
+combinations of parallel and sequential binding. Standard declarations at the
+head of BODY are handled correctly, though nonstandard ones may not be. If two
+variables of the same name are bound at different levels, any declaration
+applies to the inner one."
+ (multiple-value-bind (decls body)
+ (analyze-decls clauses body)
+ (car (expand-new-let clauses body decls))))
+
+(defun expand-new-let (clauses body decls)
+ (labels ((expand-1 (this-level-single this-level-multiple next-level body decls)
+ (cl:cond ((and this-level-multiple
+ (null (cdr this-level-multiple))
+ (null this-level-single))
+ (cl:let ((vars (butlast (car this-level-multiple))))
+ (multiple-value-bind (body decls)
+ (expand-1 nil nil next-level body decls)
+ (values `((multiple-value-bind ,vars
+ ,(car (last (car this-level-multiple)))
+ ,@(bound-decls decls vars)
+ ,@(and (null next-level)
+ (mapcar #'(lambda (d) `(declare ,d))
+ (cdr decls)))
+ . ,body))
+ (prune-decls decls vars)))))
+ (this-level-multiple
+ (let* ((vars (butlast (car this-level-multiple)))
+ (gensyms (mapcar #'(lambda (x)
+ (declare (ignore x))
+ (gensym))
+ vars)))
+ (multiple-value-bind (body decls)
+ (expand-1 (append (mapcar #'list vars gensyms)
+ this-level-single)
+ (cdr this-level-multiple) next-level body decls)
+ (values `((multiple-value-bind ,gensyms
+ ,(car (last (car this-level-multiple)))
+ ,@(bound-decls decls vars)
+ ,@(and (null next-level)
+ (mapcar #'(lambda (d) `(declare ,d))
+ (cdr decls)))
+ . ,body))
+ (prune-decls decls vars)))))
+ (this-level-single
+ (cl:let ((vars (mapcar #'(lambda (x) (if (consp x) (car x) x))
+ this-level-single)))
+ (multiple-value-bind (body decls)
+ (expand-1 nil nil next-level body decls)
+ (values `((cl:let ,this-level-single
+ ,@(bound-decls decls vars)
+ ,@(and (null next-level)
+ (mapcar #'(lambda (d) `(declare ,d))
+ (cdr decls)))
+ . ,body))
+ (prune-decls decls vars)))))
+ (next-level
+ (expand-new-let next-level body decls))
+ (t (values body decls)))))
+ (multiple-value-bind (this-level-single this-level-multiple next-level)
+ (split-level clauses nil nil nil)
+ (expand-1 this-level-single this-level-multiple next-level body decls))))
+
+(defun split-level (clauses this-level-single this-level-multiple next-level)
+ (if (null clauses)
+ (values (reverse this-level-single) (reverse this-level-multiple)
+ next-level)
+ (cl:let ((clause (car clauses)))
+ (cl:cond ((and (listp clause) (listp (car clause)))
+ (split-level (cdr clauses) this-level-single this-level-multiple
+ (append next-level clause)))
+ ((and (listp clause) (cddr clause))
+ (split-level (cdr clauses) this-level-single
+ (cons clause this-level-multiple) next-level))
+ (t
+ (split-level (cdr clauses) (cons clause this-level-single)
+ this-level-multiple next-level))))))
+
+(defun bound-decls (decls vars)
+ (let* ((bd-alist (car decls))
+ (prs (remove-if-not #'(lambda (pr) (member (car pr) vars))
+ bd-alist)))
+ (and prs `((declare . ,(mapcar #'(lambda (pr)
+ (if (listp (cdr pr))
+ `(,@(cdr pr) ,(car pr))
+ `(,(cdr pr) ,(car pr))))
+ prs))))))
+
+(defun prune-decls (decls vars)
+ (cl:let ((bd-alist (car decls)))
+ (cons (remove-if #'(lambda (pr) (member (car pr) vars))
+ bd-alist)
+ (cdr decls))))
+
+(defun analyze-decls (clauses body)
+ "Returns two values. The first value is a cons of: (a) for the bound declarations
+at the head of `body', an alist from variable name to a list of declarations
+affecting that variable; (b) a list of the remaining (free) declarations. The
+second value is `body' with the declarations stripped off."
+ (labels ((process-declares (body bd-alist free vars)
+ (if (or (null body) (not (consp (car body)))
+ (not (eq (caar body) 'declare)))
+ (values bd-alist free body)
+ (multiple-value-bind (bd-alist free)
+ (process-decls (cdar body) bd-alist free vars)
+ (process-declares (cdr body) bd-alist free vars))))
+ (process-decls (decls bd-alist free vars)
+ (if (null decls)
+ (values bd-alist free)
+ (multiple-value-bind (bd-alist free)
+ (process-decl (car decls) bd-alist free vars)
+ (process-decls (cdr decls) bd-alist free vars))))
+ (process-decl (decl bd-alist free vars)
+ (cl:cond
+ ((not (consp decl)) ; defensive programming
+ (values bd-alist (cons decl free)))
+ ((member (car decl) '(ignore ignoreable))
+ ;; These are always bound.
+ (values (append (mapcar #'(lambda (x) (cons x (car decl)))
+ (cdr decl))
+ bd-alist)
+ free))
+ ((type-specifier-name? (car decl))
+ (process-vars (cdr decl) (list 'type (car decl)) bd-alist free vars))
+ ((eq (car decl) 'type)
+ (process-vars (cddr decl) (list 'type (cadr decl)) bd-alist free vars))
+ ((eq (car decl) 'special)
+ (process-vars (cdr decl) (car decl) bd-alist free vars))
+ (t (values bd-alist (cons decl free)))))
+ (process-vars (decl-vars decl-name bd-alist free vars)
+ (if (null decl-vars)
+ (values bd-alist free)
+ (multiple-value-bind (bd-alist free)
+ (process-vars (cdr decl-vars) decl-name bd-alist free vars)
+ (if (member (car decl-vars) vars)
+ (values (cons (cons (car decl-vars) decl-name)
+ bd-alist)
+ free)
+ (values bd-alist
+ (cons (list decl-name (car decl-vars))
+ free)))))))
+ (multiple-value-bind (bd-alist free body)
+ (process-declares body nil nil (new-let-bound-vars clauses))
+ (values (cons bd-alist free) body))))
+
+(defun new-let-bound-vars (clauses)
+ (and clauses
+ (append (cl:let ((clause (car clauses)))
+ (cl:cond ((symbolp clause) (cons clause nil))
+ ((symbolp (car clause)) (butlast clause))
+ (t (new-let-bound-vars clause))))
+ (new-let-bound-vars (cdr clauses)))))
+
+(defun type-specifier-name? (x)
+ (or (member x '(array atom bignum bit bit-vector character compiled-function
+ complex cons double-float extended-char fixnum float function
+ hash-table integer keyword list long-float nil null number
+ package pathname random-state ratio rational real readtable
+ sequence short-float simple-array simple-bit-vector
+ simple-string simple-vector single-float standard-char stream
+ string base-char symbol t vector))
+ (find-class x nil)))
+
+
+(defmacro cond (&rest clauses)
+ "A generalization of CL:COND that makes it convenient to compute a value in
+the predicate expression of a clause and then use that value in the consequent.
+If the predicate expression is a LET form, then the scope of the variables bound
+by the LET is extended to include the consequent expressions. For example:
+
+ (cond ((let ((x (foo)))
+ (bar x))
+ (baz x)))
+
+Here the X in (BAZ X) is the one bound to the result of (FOO)."
+ (cl:let ((block-nm (gensym)))
+ `(block ,block-nm
+ . ,(mapcar #'(lambda (c) (bcond-clause c block-nm)) clauses))))
+
+(defmacro bcond (&rest clauses)
+ "A generalization of CL:COND that makes it convenient to compute a value in
+the predicate expression of a clause and then use that value in the consequent.
+If the predicate expression is a LET form, then the scope of the variables bound
+by the LET is extended to include the consequent expressions. For example:
+
+ (cond ((let ((x (foo)))
+ (bar x))
+ (baz x)))
+
+Here the X in (BAZ X) is the one bound to the result of (FOO)."
+ (cl:let ((block-nm (gensym)))
+ `(block ,block-nm
+ . ,(mapcar #'(lambda (c) (bcond-clause c block-nm)) clauses))))
+
+(defun bcond-clause (clause block-nm)
+ (cl:cond ((not (listp clause))
+ (error "COND clause is not a list: ~S" clause))
+ ((and (listp (car clause))
+ ;; Allow NLET and CL:LET in case the user hasn't chosen
+ ;; to shadow LET.
+ (member (caar clause) '(let nlet cl:let)))
+ (bcond-build-clause (caar clause) (cadar clause)
+ `(progn . ,(cddar clause))
+ (cdr clause) block-nm))
+ (t
+ (bcond-build-clause nil nil (car clause) (cdr clause) block-nm))))
+
+(defun bcond-build-clause (let-sym let-clauses pred consequents block-nm)
+ (cl:let ((body (if consequents
+ `(if ,pred (return-from ,block-nm (progn . ,consequents)))
+ (cl:let ((temp-var (gensym)))
+ `(cl:let ((,temp-var ,pred))
+ (if ,temp-var (return-from ,block-nm ,temp-var)))))))
+ (if let-clauses
+ `(,let-sym ,let-clauses ,body)
+ body)))
+
+
+
More information about the Misc-extensions-cvs
mailing list