Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
1 contributor

Users who have contributed to this file

938 lines (873 sloc) 39.8 KB
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GMap -*-
;;; This file is in the public domain. It is provided with ABSOLUTELY
;;; NO WARRANTY.
(in-package gmap)
;
; GMAP, version 3.3, 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. UPDATE: as of 3.3, this function may return
; multiple values. If this item is of the form `(:values <n> <argfn>)', <n>
; specifies how many of its values to use. See predefined arg-type `:alist'
; below for an example. The values are passed to the function being mapped as
; multiple arguments, somewhat analogously to `multiple-value-call' except that
; how many arguments are supplied by each arg-spec is declared statically
; rather than being the number of values actually returned at runtime (ugh).
; <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. UPDATE: as of 3.3, this function can now take
; more than two arguments. If this item is of the form `(:consume <n> <resfn>)',
; <n> specifies how many of the values of the function being mapped are to be
; passed to <resfn> (which then takes <n> + 1 arguments). See result-type
; `:alist' below for an example.
; <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.
; No guarantees are offered as to the order in which the forms generated by
; the arg-specs and result-specs are evaluated, except that the `exitp'
; and `argfn' functions are called at the beginning of each iteration, before
; the function being mapped; and the `nextfn' and `filterp' functions are called
; after the function being mapped. Do not depend on the order of side-effects
; across clauses! (The whole purpose of GMap is to better support a highly
; functional style.)
; 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.
;;; CHANGES:
;;;
;;; Version 3.3, 2007-07-04:
;;;
;;; () Revamped arg types `:index' and `:index-inc' (incompatibly).
;;; () Added doc strings, including on the predefined arg- and result-types,
;;; and arranged for them to be placed on the symbol-plist, where there's
;;; an outside chance someone might find them.
;;; () Revamped result types `:vector' and `:string' (incompatibly).
;;; () Removed deprecated arg- and result-types `:array'.
;;; () Changed most optional arguments to arg- and result-types to keyword
;;; arguments.
;;; () Substantially expanded the multiple-value capability. Now it is possible
;;; for an arg-spec to generate any number of arguments to the function being
;;; mapped, and for a single result-spec to consume more than one value
;;; returned by that function.
;;; () Using the new multiple-value capabilities, added `:alist' and `:plist'
;;; as both arg- and result-types.
;;;
;;; Thanks to Joerg Hoehle for some useful suggestions.
;;; The top-level macro.
(defmacro gmap (res-spec fn &rest arg-specs)
"A generalized mapping macro. Applies `fn' to the successive values generated
by the `arg-specs', analagously to `mapcar'; that is, on each iteration, each
arg-spec yields one value, and `fn' is called with these values as arguments.
The values returned by `fn' are accumulated into a result according to
`res-spec'. The `res-spec' is either a list whose car is a predefined result
type, or a list whose car is `nil' and whose cdr has the same form as the value
of a result type expander (see `def-gmap-res-type'); or, the `res-spec' can be
a symbol, which is shorthand for a list of that symbol; or, it can be a list
whose car is `:values' and whose cdr is a list of result-specs. Similarly,
each of the `arg-specs' is either a list whose car is a predefined arg type,
or a list whose car is `nil' and whose cdr has the same form as the value of
an arg type expander (see `def-gmap-arg-type')."
(unless arg-specs
(error "At least one argument spec is required."))
(gmap>expand fn
(gmap>res-spec-lookup res-spec)
(mapcar #'gmap>arg-spec-lookup arg-specs)))
;;; This does the real work.
(defun gmap>expand (fn res-specs arg-specs)
(let ((param-list
(mapcar #'gmap>param arg-specs))
(result-list (gmap>res>init-clauses res-specs))
(let-specs (gmap>let-specs arg-specs res-specs)))
(let ((one-value-p (null (cdr result-list)))
(multi-vars (mapcar #'gmap>param>multi-vars arg-specs))
(fnval-vars (mapcan #'(lambda (res-spec)
(and res-spec
(let ((resfn (second res-spec)))
(if (and (consp resfn)
(eq (first resfn) ':consume))
(let ((vars nil))
(dotimes (i (second resfn))
(push (gensym "VAR-") vars))
(nreverse vars))
(list (gensym "VAR-"))))))
res-specs)))
`(let ,let-specs
(do (,@param-list
,@result-list)
((or ,@(apply #'append (mapcar #'gmap>param>exit-test ; exit test
param-list arg-specs)))
,(gmap>res>cleanup res-specs result-list one-value-p))
(let ,(reduce #'append
(mapcar #'gmap>param>multi-let-specs
param-list arg-specs multi-vars))
,(if (null fnval-vars)
;; Null result spec -- just call the function for effect.
(apply #'gmap>funcall fn
(reduce #'append
(mapcar #'gmap>param>arg
param-list arg-specs multi-vars)))
`(let ((,@fnval-vars
,(apply #'gmap>funcall fn
(reduce #'append
(mapcar #'gmap>param>arg
param-list arg-specs multi-vars)))))
. ,(let ((setqs nil))
(do ((res-specs res-specs (cdr res-specs))
(result-list result-list (cdr result-list)))
((null res-specs))
(let ((next-exp fnvs
(gmap>res>next (car res-specs) (caar result-list)
fnval-vars)))
(setq fnval-vars fnvs)
(push `(setq ,(caar result-list) ,next-exp) setqs)))
(nreverse setqs))))))))))
;;; 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 "VAR-"))
(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 multi-vars)
(let ((param-name (first param))
(argfn (third arg-spec)))
(or multi-vars
`(,(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)))
(defun gmap>param>multi-vars (arg-spec)
(let ((argfn (third arg-spec)))
(and (consp argfn) (eq (first argfn) ':values)
;; (gmap :list (lambda (i) (gensym))
;; (:index 0 (cadr argfn)))
(let ((vars nil))
(dotimes (i (second argfn))
(push (gensym "VAR-") vars))
(nreverse vars)))))
(defun gmap>param>multi-let-specs (param arg-spec multi-vars)
(let ((argfn (third arg-spec)))
(and multi-vars
`((,@multi-vars ,(gmap>funcall (third argfn) (first param)))))))
;;; get the initial value of the result.
(defun gmap>res>init-clauses (res-specs)
(mapcan #'(lambda (res-spec)
(and res-spec (cons (list (gensym "VAR-") (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 fnvals)
(let ((resfn (second res-spec))
(filterp (fourth res-spec))
((n-fnvals resfn
(if (and (consp resfn) (eq (first resfn) ':consume))
(values (second resfn) (third resfn))
(values 1 resfn)))
((my-fnvals (subseq fnvals 0 n-fnvals)))))
(values (if filterp
`(if ,(apply #'gmap>funcall filterp my-fnvals)
,(apply #'gmap>funcall resfn result my-fnvals)
,result)
(apply #'gmap>funcall resfn result my-fnvals))
(subseq fnvals n-fnvals))))
;;; 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, some compilers don'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. Also
;;; cleans up the expansion a bit.
(defun gmap>funcall (function &rest args)
(let ((args (copy-list args)))
(cond ((or (null function) (eq function ':id))
`(values . ,args))
((and (listp function)
(eq (car function) 'function))
`(,(cadr function) . ,args))
((and (listp function)
(eq (car function) 'lambda))
`(,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."))
(defmacro def-gmap-arg-type (name args &body body)
"Defines a GMap arg-type. Syntax is identical to `defun'. The body should
return a list of 1 to 5 elements: (0, \"init\") the initial value of the
state variable; (1, \"exitp\"), if non-nil, a function of one argument which
is called on the state variable, a true result causing the iteration to
exit; (2, \"argfn\"), if non-nil, a function of one argument which is called
on the state variable to get the value to be used on this iteration; (3,
\"nextfn\"), if non-nil, a function of one argument which is called on the
state variable to get the new value of same; and (4, \"let-specs\") a list of
clauses for an `nlet' that will wrapped around the entire expansion.
It is also possible for an arg-type to generate multiple arguments. If
element 2, \"argfn\", is of the form `(:values N FN)', FN should be a function
returning N values, which will be passed as separate arguments to the function
being mapped."
(let ((fn-name (gensym "GMAP-ARG-SPEC-EXPANDER-")))
;; CLISP doesn't seem to preserve EQ-ness on fasl-dumped uninterned symbols.
#+clisp (setq fn-name (intern (symbol-name fn-name) :gmap))
(let ((doc-string body
(if (stringp (car body)) (values (car body) (cdr body))
(values nil body))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ,fn-name ,args . ,body)
(setf (get ',name ':gmap-arg-spec-expander) ',fn-name)
,@(and doc-string
`((setf (get ',name ':gmap-arg-spec-expander-doc-string) ,doc-string)))
(pushnew ',name *gmap-arg-type-list*)))))
(defmacro def-gmap-res-type (name args &body body)
"Defines a GMap result-type. Syntax is identical to `defun'. The body should
return a list of 2 to 5 elements: (0, \"init\") the initial value of the state
variable; (1, \"resfn\") a function of two arguments which is called on the
state variable and the current value of the function being mapped, returning
the new value of the state variable; (2, \"cleanup\"), if non-nil, a function
of one argument which is called on the final value of the state variable to
get the value of the `gmap' form; (3, \"filterp\"), if non-nil, a predicate
of one argument which is called on the current value of the function being
mapped, a false value causing \"resfn\" not to be called on this iteration (and
the state variable to be unchanged); and (4, \"let-specs\") a list of
clauses for an `nlet' that will wrapped around the entire expansion.
It is also possible for a result-type to consume more than one value of the
function being mapped. If element 1, \"resfn\", is of the form `(:consume N
FN)', FN should be a function of N + 1 arguments, and will receive N values
from the function being mapped."
(let ((fn-name (gensym "GMAP-RES-SPEC-EXPANDER-")))
;; CLISP doesn't seem to preserve EQ-ness on fasl-dumped uninterned symbols.
#+clisp (setq fn-name (intern (symbol-name fn-name) :gmap))
(let ((doc-string body
(if (stringp (car body)) (values (car body) (cdr body))
(values nil body))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ,fn-name ,args . ,body)
(setf (get ',name ':gmap-res-spec-expander) ',fn-name)
,@(and doc-string
`((setf (get ',name ':gmap-res-spec-expander-doc-string) ,doc-string)))
(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)
"Yields an unbounded sequence of `value'."
`(,value))
(def-gmap-arg-type :list (list)
"Yields the successive elements of `list'."
`(,list
#'endp #'car #'cdr))
(def-gmap-arg-type :alist (alist)
"Yields, as two values, the successive pairs of `alist'."
`(,alist
#'endp
(:values 2 #'(lambda (alist) (values (caar alist) (cdar alist))))
#'cdr))
(def-gmap-arg-type :plist (plist)
"Yields, as two values, the successive pairs of elements of `plist'; that is,
there is one iteration for each two elements."
`(,plist
#'endp
(:values 2 #'(lambda (plist) (values (car plist) (cadr plist))))
#'cddr))
(def-gmap-arg-type :tails (list)
"Yields the successive tails (cdrs) of `list', starting with `list' itself."
`(,list
#'endp nil #'cdr))
;;; If `incr' is +1 or -1, then swapping `start' and `stop' and negating `incr'
;;; generates the same sequence in reverse order. This isn't true, though, in
;;; general. Should it be?
(def-gmap-arg-type :index (&optional (start 0) stop &key (incr 1) (fixnums? t))
"Yields integers in the interval [`start', `stop') if `incr' (which defaults
to 1) is positive; or in the interval [`stop', `start') if `incr' is negative.
Specifically, in the upward case, the values begin with `start' and increase by
`incr' until >= `stop'; in the downward case, the values begin with
`start' - `incr' and decrease by `incr' until < `stop'. All values are
assumed to be fixnums unless `fixnums?' is a literal `nil'. `stop' can be
omitted or a literal `nil' to indicate an unbounded sequence. `start' can be
omitted to start at 0."
(let ((incr-temp (gensym "INCR-"))
(stop-temp (gensym "STOP-")))
;; Aargh, have to handle the constant vs. variable cases of `incr' separately
;; to avoid unreachable-code warnings from Python. (Suggested heuristic:
;; if code becomes unreachable because a variable is bound to a compile-time
;; constant, and the name of the variable is an uninterned symbol, suppress
;; the warning on the grounds that a macro generated the code in question.)
`(,(if (numberp incr) ; init
(if (minusp incr)
(if fixnums? `(+ (the fixnum ,start) ,incr)
`(+ ,start ,incr))
start)
`(if (minusp ,incr-temp)
,(if fixnums? `(+ (the fixnum ,start) (the fixnum ,incr-temp))
`(+ ,start ,incr-temp))
,start))
,(and stop ; exitp
(if (numberp incr)
(if fixnums?
`#'(lambda (val)
(,(if (minusp incr) '< '>=)
(the fixnum val) (the fixnum ,stop-temp)))
`#'(lambda (val)
(,(if (minusp incr) '< '>=) val ,stop-temp)))
`#'(lambda (val)
,@(and fixnums? `((declare (type fixnum val ,incr-temp ,stop-temp))))
(if (minusp ,incr-temp)
(< val ,stop-temp)
(>= val ,stop-temp)))))
nil ; no argfn
#'(lambda (val) ; nextfn
,(if fixnums?
`(the fixnum (+ (the fixnum val)
(the fixnum ,(if (numberp incr) incr incr-temp))))
`(+ val ,(if (numberp incr) incr incr-temp))))
(,@(and (not (numberp incr)) ; let-specs
`((,incr-temp ,incr)))
,@(and stop
`((,stop-temp ,stop)))))))
(def-gmap-arg-type :index-inc (start stop &key (incr 1) (fixnums? t))
"Yields integers in the interval [`start', `stop']. Specifically, in the
upward case (`incr' > 0), the values begin with `start' and increase by
`incr' until > `stop'; in the downward case, the values begin with `start'
and decrease by `incr' until < `stop'. All values are assumed to be fixnums
unless `fixnums?' is a literal `nil'. `stop' can be a literal `nil' to
indicate an unbounded sequence."
(let ((incr-temp (gensym "INCR-"))
(stop-temp (gensym "STOP-")))
;; Aargh, have to handle the constant vs. variable cases of `incr' separately
;; to avoid unreachable-code warnings from Python. (Suggested heuristic:
;; if code becomes unreachable because a variable is bound to a compile-time
;; constant, and the name of the variable is an uninterned symbol, suppress
;; the warning on the grounds that a macro generated the code in question.)
`(,start
,(and stop ; exitp
(if (numberp incr)
(if fixnums?
`#'(lambda (val)
(,(if (minusp incr) '< '>)
(the fixnum val) (the fixnum ,stop-temp)))
`#'(lambda (val)
(,(if (minusp incr) '< '>) val ,stop-temp)))
`#'(lambda (val)
,@(and fixnums? `((declare (type fixnum val ,incr-temp ,stop-temp))))
(if (minusp ,incr-temp)
(< val ,stop-temp)
(> val ,stop-temp)))))
nil ; no argfn
#'(lambda (val) ; nextfn
,(if fixnums?
`(the fixnum (+ (the fixnum val)
(the fixnum ,(if (numberp incr) incr incr-temp))))
`(+ val ,(if (numberp incr) incr incr-temp))))
(,@(and (not (numberp incr)) ; let-specs
`((,incr-temp ,incr)))
,@(and stop
`((,stop-temp ,stop)))))))
(def-gmap-arg-type :exp (initial-value base)
"Yields an unbounded exponential sequence starting with `initial-value'
and multiplying by `base' after each iteration."
(let ((base-temp (gensym "BASE-")))
`(,initial-value
nil
nil
#'(lambda (x) (* x ,base-temp))
((,base-temp ,base)))))
(def-gmap-arg-type :vector (vec &key start stop incr)
"Yields elements of vector `vec'. `start' and `stop' may be supplied to select
a subsequence of `vec'; `incr' may be supplied (it must be positive) to select
every second element etc. For performance, you may prefer `:simple-vector'."
(let ((vec-temp (gensym "VEC-"))
(incr-temp (and incr (gensym "INCR-")))
(stop-temp (gensym "STOP-")))
`(,(or start 0)
#'(lambda (i) (>= i ,stop-temp))
#'(lambda (i) (aref ,vec-temp i))
#'(lambda (x) (+ x ,(or incr-temp 1)))
((,vec-temp ,vec)
,@(and incr `((,incr-temp ,incr)))
((,stop-temp ,(or stop `(length ,vec-temp))))))))
(def-gmap-arg-type :simple-vector (vec &key start stop incr)
"Yields elements of vector `vec', which is assumed to be simple, and whose size
is assumed to be a fixnum. `start' and `stop' may be supplied to select a
subsequence of `vec'; `incr' may be supplied (it must be positive) to select
every second element etc."
(let ((vec-temp (gensym "VEC-"))
(incr-temp (and incr (gensym "INCR-")))
(stop-temp (gensym "STOP-")))
`(,(or start 0)
#'(lambda (i) (>= (the fixnum i) ,stop-temp))
#'(lambda (i) (svref ,vec-temp (the fixnum i)))
#'(lambda (i) (the fixnum (+ (the fixnum i) ,(or incr-temp 1))))
((,vec-temp ,vec)
,@(and incr `((,incr-temp (the fixnum ,incr))))
((,stop-temp (the fixnum ,(or stop `(length ,vec-temp)))))))))
(def-gmap-arg-type :string (str &key start stop incr)
"Yields elements of string `str'. `start' and `stop' may be supplied to select
a subsequence of `vec'; `incr' may be supplied (it must be positive) to select
every second element etc. For performance, you may prefer `:simple-string'."
(let ((str-temp (gensym "STR-"))
(incr-temp (and incr (gensym "INCR-")))
(stop-temp (gensym "STOP-")))
`(,(or start 0)
#'(lambda (i) (>= i ,stop-temp))
#'(lambda (i) (char ,str-temp i))
#'(lambda (i) (+ i ,(or incr-temp 1)))
((,str-temp (string ,str))
,@(and incr `((,incr-temp ,incr)))
((,stop-temp ,(or stop `(length ,str-temp))))))))
(def-gmap-arg-type :simple-string (str &key start stop incr)
"Yields elements of string `str', which is assumed to be simple, and whose size
is assumed to be a fixnum. `start' and `stop' may be supplied to select a
subsequence of `str'; `incr' may be supplied (it must be positive) to select
every second element etc."
(let ((str-temp (gensym "STR-"))
(incr-temp (and incr (gensym "INCR-")))
(stop-temp (gensym "STOP-")))
`(,(or start 0)
#'(lambda (i) (>= (the fixnum i) ,stop-temp))
#'(lambda (i) (schar ,str-temp (the fixnum i)))
#'(lambda (i) (+ (the fixnum i) ,(or incr-temp 1)))
((,str-temp ,str)
,@(and incr `((,incr-temp (the fixnum ,incr))))
((,stop-temp (the fixnum ,(or stop `(length ,str-temp)))))))))
;;; ******** Predefined result types ********
(def-gmap-res-type :list (&key filterp)
"Returns a list of the values, optionally filtered by `filterp'."
`(nil #'(lambda (x y) (cons y x)) #'nreverse ,filterp))
(def-gmap-res-type :alist (&key filterp)
"Consumes two values from the mapped function; returns an alist of the
pairs. Note that `filterp', if supplied, must take two arguments."
`(nil (:consume 2 #'(lambda (res x y) (cons (cons x y) res))) #'nreverse ,filterp))
(def-gmap-res-type :plist (&key filterp)
"Consumes two values from the mapped function; returns a plist of the
pairs. Note that `filterp', if supplied, must take two arguments."
`(nil (:consume 2 #'(lambda (res x y) (cons y (cons x res)))) #'nreverse ,filterp))
(def-gmap-res-type :append (&key filterp)
"Returns the result of `append'ing the values, optionally filtered by
`filterp'."
`(nil
#'(lambda (old new) (revappend new old))
#'nreverse
,filterp))
(def-gmap-res-type :nconc (&key filterp)
"Returns the result of `nconc'ing the values, optionally filtered by
`filterp'."
(let ((result-var (gensym "RESULT-"))) ; 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 ()
"If one of the values is false, terminates the iteration and returns false.
Does not work as an operand of `:values'."
'(t #'(lambda (ignore new)
(declare (ignore ignore))
(if new new (return nil)))))
(def-gmap-res-type :or ()
"If one of the values is true, terminates the iteration and returns it.
Does not work as an operand of `:values'."
'(nil #'(lambda (ignore new)
(declare (ignore ignore))
(if new (return new) nil))))
(def-gmap-res-type :sum (&key filterp)
"Returns the sum of the values, optionally filtered by `filterp'."
`(0 #'+ nil ,filterp))
(def-gmap-res-type :count-if ()
"Returns the number of true values."
'(0 #'(lambda (n new)
(if new (1+ n) n))))
(def-gmap-res-type :max (&key filterp)
"Returns the maximum of the values, optionally filtered by `filterp'; or `nil'
if there are none."
`(nil
#'(lambda (old new) (if (null old) new (max old new)))
nil
,filterp))
(def-gmap-res-type :min (&key filterp)
"Returns the minimum of the values, optionally filtered by `filterp'; or `nil'
if there are none."
`(nil
#'(lambda (old new) (if (null old) new (min old new)))
nil
,filterp))
(def-gmap-res-type :vector (&key use-vector length fill-pointer adjustable filterp)
"Constructs a vector containing the results. If `use-vector' is supplied,
the argument will be filled with the results and returned; if `fill-pointer'
is true and `adjustable' is true, it must have a fill pointer and be adjustable,
and values will be appended to it with `vector-push-extend'; if `fill-pointer'
is true and `adjustable' is false, it must have a fill pointer, and values will
be appended to it with `vector-push'; otherwise, the vector is assumed to be
simple and must be large enough to hold the results. (Recall that `vector-push'
has no effect if the vector is full.)
If `use-vector' is not supplied, a vector will be constructed and returned;
if `length' is supplied, returns a simple vector of the specified length (which
must be sufficient to hold the results); otherwise, returns a simple vector of
the correct length (but to do this, it must cons a temporary list).
In any case, if `filterp' is supplied, it is a predicate of one argument,
the value of the function being mapped, that says whether to include it in
the result."
(cond ((and use-vector fill-pointer)
`(,use-vector
#'(lambda (vec next-elt)
(,(if adjustable
'vector-push-extend
'vector-push)
next-elt vec)
vec)
nil
,filterp))
((and use-vector length)
(error "Makes no sense to supply both `:use-vector' and `:length'"))
(use-vector
(let ((index-temp (gensym "INDEX-")))
`(,use-vector
#'(lambda (vec next-elt)
(setf (svref vec (the fixnum ,index-temp)) next-elt)
(incf (the fixnum ,index-temp))
vec)
nil
,filterp
((,index-temp 0)))))
(length
(let ((index-temp (gensym "INDEX-")))
`((make-array ,length)
#'(lambda (vec next-elt)
(setf (svref vec (the fixnum ,index-temp)) next-elt)
(incf (the fixnum ,index-temp))
vec)
nil
,filterp
((,index-temp 0)))))
(t
(let ((len-temp (gensym "LEN-")))
`(nil
#'(lambda (list next-elt)
(incf (the fixnum ,len-temp))
(cons next-elt list))
#'(lambda (list)
(let ((vec (make-array (the fixnum ,len-temp))))
(dolist (x list)
(setf (svref vec (decf (the fixnum ,len-temp))) x))
vec))
,filterp
((,len-temp 0)))))))
(def-gmap-res-type :string (&key use-string length fill-pointer adjustable filterp)
"Constructs a string containing the results. If `use-string' is supplied,
the argument will be filled with the results and returned; if `fill-pointer'
is true and `adjustable' is true, it must have a fill pointer and be adjustable,
and values will be appended to it with `vector-push-extend'; if `fill-pointer'
is true and `adjustable' is false, it must have a fill pointer, and values will
be appended to it with `vector-push'; otherwise, the vector is assumed to be
simple and must be large enough to hold the results. (Recall that `vector-push'
has no effect if the vector is full.)
If `use-string' is not supplied, a string will be constructed and returned;
if `length' is supplied, returns a simple string of the specified length (which
must be sufficient to hold the results); otherwise, returns a simple string of
the correct length (but to do this, it must cons a temporary list).
In any case, if `filterp' is supplied, it is a predicate of one argument,
the value of the function being mapped, that says whether to include it in
the result."
(cond ((and use-string fill-pointer)
`(,use-string
#'(lambda (str next-elt)
(,(if adjustable
'vector-push-extend
'vector-push)
next-elt str)
str)
nil
,filterp))
(use-string
(let ((index-temp (gensym "INDEX-")))
`(,use-string
#'(lambda (vec next-elt)
(setf (schar vec (the fixnum ,index-temp)) next-elt)
(incf (the fixnum ,index-temp))
vec)
nil
,filterp
((,index-temp 0)))))
(length
(let ((index-temp (gensym "INDEX-")))
`((make-string ,length)
#'(lambda (vec next-elt)
(setf (schar vec (the fixnum ,index-temp)) next-elt)
(incf (the fixnum ,index-temp))
vec)
nil
,filterp
((,index-temp 0)))))
(t
(let ((len-temp (gensym "LEN-")))
`(nil ; init
#'(lambda (list next-elt) ; nextfn
(incf (the fixnum ,len-temp))
(cons next-elt list))
#'(lambda (list) ; cleanup
(let ((str (make-string (the fixnum ,len-temp))))
(dolist (x list)
(setf (schar str (decf (the fixnum ,len-temp))) x))
str))
,filterp
((,len-temp 0)))))))
; End of gmap.lisp
You can’t perform that action at this time.