misc-extensions-cvs

Download

misc-extensions-cvs@common-lisp.net

January 2007

1 participants
2 discussions

[misc-extensions-cvs] r2 -
by sburson＠common-lisp.net 06 Jan '07

06 Jan '07

Author: sburson Date: Sat Jan 6 18:32:32 2007 New Revision: 2 Added: misc-extensions.asd Log: Initial commit. Added: misc-extensions.asd ============================================================================== --- (empty file) +++ misc-extensions.asd Sat Jan 6 18:32:32 2007 @@ -0,0 +1,8 @@ +;;; -*- Lisp -*- + +(defsystem misc-extensions + :serial t + :components ((:module "src" + :components ((:file "defs") + (:file "new-let") + (:file "gmap")))))

1 0

[misc-extensions-cvs] r1 - src
by sburson＠common-lisp.net 06 Jan '07

06 Jan '07

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 (,@param-list + ,@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))) + + +

1 0