# HG changeset patch # User Steve Losh # Date 1575683619 18000 # Node ID 0b09e1b70887809c1c6fc6d0a50d84dca1035ba1 # Parent a85855efde4af5cbd6d00682f8073679d54738ad Add iterate `returning`, `finding-first`, `matching` and remove unused iterate stuff diff -r a85855efde4a -r 0b09e1b70887 losh.asd --- a/losh.asd Thu Dec 05 19:35:58 2019 -0500 +++ b/losh.asd Fri Dec 06 20:53:39 2019 -0500 @@ -10,6 +10,7 @@ :in-order-to ((asdf:test-op (asdf:test-op :losh/test))) :depends-on (:iterate + :cl-ppcre :external-program #+sbcl :sb-sprof) diff -r a85855efde4a -r 0b09e1b70887 package.lisp --- a/package.lisp Thu Dec 05 19:35:58 2019 -0500 +++ b/package.lisp Fri Dec 06 20:53:39 2019 -0500 @@ -245,8 +245,7 @@ (defpackage :losh.iterate (:use :cl :iterate :losh.quickutils - :losh.hash-sets - :losh.control-flow) ;; always needed because we need a single RECURSIVELY symbol + :losh.hash-sets) (:documentation "Custom `iterate` drivers and clauses.") (:export @@ -259,6 +258,7 @@ :cycling :every-nth :finding-all + :finding-first :for-nested :in-array :in-hashset @@ -274,7 +274,6 @@ :pairs-of-list :per-iteration-into :real-time - :recursively :run-time :seed :since-start-into @@ -283,6 +282,12 @@ :then :timing :within-radius + :returning + :matching + :against + :overlap + :start + :end )) diff -r a85855efde4a -r 0b09e1b70887 src/iterate.lisp --- a/src/iterate.lisp Thu Dec 05 19:35:58 2019 -0500 +++ b/src/iterate.lisp Fri Dec 06 20:53:39 2019 -0500 @@ -727,12 +727,6 @@ (let ((kwd (if generate 'generate 'for))) `(,kwd (,var) :in-hashtable (losh.hash-sets::hash-set-storage ,hset)))) -(defmacro-driver (FOR var RECURSIVELY expr INITIALLY init) - (let ((kwd (if generate 'generate 'for))) - `(progn - (initially (setf ,var ,init)) - (,kwd ,var = ,expr)))) - (defmacro-driver (FOR var SEED seed THEN then) "Bind `var` to `seed` initially, then to `then` on every iteration. @@ -760,6 +754,10 @@ (initially (setf ,var ,seed))))) +(deftype sharp-quoted-function () + '(cons (eql function) + (cons t null))) + (defmacro-clause (FINDING-ALL expr MINIMIZING m-expr &optional INTO var) "Collect all `expr`s minimizing `m-expr` into a list at `var`. @@ -777,7 +775,7 @@ (with ,tail = nil) (with ,min = nil) ,(typecase m-expr - ((cons (eql function) (cons t null)) + (sharp-quoted-function `(progn (for ,value = ,expr) (for ,m-value = (funcall ,m-expr ,value)) @@ -815,7 +813,7 @@ (with ,tail = nil) (with ,max = nil) ,(typecase m-expr - ((cons (eql function) (cons t null)) + (sharp-quoted-function `(progn (for ,value = ,expr) (for ,m-value = (funcall ,m-expr ,value)) @@ -845,13 +843,133 @@ " (let ((result (or var iterate::*result-var*))) (typecase test - ((cons (eql function) (cons t null)) - (with-gensyms (value) - `(progn - (for ,value = ,expr) - (when (funcall ,test ,value) - (collect ,value :into ,result - ,@(when result-type `(:result-type ,result-type))))))) + (sharp-quoted-function + (with-gensyms (value) + `(progn + (for ,value = ,expr) + (when (funcall ,test ,value) + (collect ,value :into ,result + ,@(when result-type `(:result-type ,result-type))))))) (t `(when ,test (collect ,expr :into ,result ,@(when result-type `(:result-type ,result-type)))))))) + +(defmacro-clause (FINDING-FIRST expr SUCH-THAT test &optional INTO var) + "Collect the first `expr`s for which `test` is true. + + Unlike vanilla `finding`, does not block further iteration. + + If `test` is a sharp-quoted function, then it is called on `expr` instead of + being evaluated and compared itself. + + " + (with-gensyms (value found) + (let ((result (or var iterate::*result-var*))) + `(progn + (with ,found) + ,@(when var (list `(with ,var))) + ,(typecase test + (sharp-quoted-function + `(unless ,found + (for ,value = ,expr) + (when (funcall ,test ,value) + (setf ,found t ,result ,value)))) + (t `(unless ,found + (when ,test + (setf ,found t ,result ,expr))))))))) + + +(defmacro returning (&rest values) + "Return `values` from the iterate clause. + + Equivalent to `(finally (return (values ...)))`. + + " + `(finally (return (values ,@values)))) + +(defmacro-driver (FOR var-or-vars MATCHING regex AGAINST string &optional OVERLAP overlap? START start END end) + "Iterate over the matches of `regex` in `string`, binding `vars`. + + `regex` must be a suitable argument for passing to `ppcre:create-scanner`. + Note that `ppcre:create-scanner` accepts already-created scanners and returns + them unchanged, so you can provide an existing scanner if you wish. + + `var-or-vars` will be bound to the successive matches. If it is a symbol, it + will be bound to the entire match. If it is a list of variables, they will be + bound to the register groups as if by `ppcre:register-groups-bind`. + + If `overlap?` is true, after finding a match, the next match will be searched + for from the next character, instead of skipping past the entire previous + match. + + `generate` is supported. + + Examples: + + (iterate (for word :matching \"\\\\w+\" :against \"foo bar baz\") + (collect word)) + ; => + (\"foo\" \"bar\" \"baz\") + + (iterate (for x :matching \"\\\\w\\\\w\" :against \"abcde\") + (collect x)) + ; => + (\"ab\" \"cd\") + + (iterate (for x :matching \"\\\\w\\\\w\" :against \"abcde\" :overlap t) + (collect x)) + ; => + (\"ab\" \"bc\" \"cd\" \"de\") + + (iterate (for ((#'string-upcase name) (#'parse-integer year month day)) + :matching \"(\\\\w+)? (\\\\d+)-(\\\\d+)-(\\\\d+)\" + :against \"foo 2019-12-06 / 2010-11-14\") + (collect (list name year month day))) + ; => + ((\"FOO\" 2019 12 6) (NIL 2010 11 14)) + + (iterate (for x :matching (ppcre:create-scanner \"foo+\" :case-insensitive-mode t) + :against \"FOOOOD\") + (collect x)) + ; => + (\"FOOOO\") + + " + (let* ((kwd (if generate 'generate 'for)) + (single (symbolp var-or-vars)) + (var (if single var-or-vars nil)) + (vars (unless single + (iterate + (for spec :in var-or-vars) + (etypecase spec + (cons (destructuring-bind (function &rest vars) spec + (appending (mapcar (curry #'cons function) vars)))) + (symbol (appending (list `(nil . ,spec))))))))) + (with-gensyms (scanner% pos% start% end% string% reg-start% reg-end% limit%) + `(progn + (with ,pos% = ,(or start 0)) + (with ,string% = ,string) + (with ,limit% = ,(or end `(length ,string%))) + (with ,scanner% = (ppcre:create-scanner ,regex)) + (,kwd ,(if single + var + `(values ,@(mapcar #'cdr vars))) + :next + (multiple-value-bind (,start% ,end% ,@(unless single `(,reg-start% ,reg-end%))) + (ppcre:scan ,scanner% ,string% :start ,pos% :end ,limit%) + (if (null ,start%) + (terminate) + (progn (setf ,pos% ,(if overlap? `(1+ ,start%) end%)) + ,(if single + `(subseq ,string% ,start% ,end%) + `(values + ,@(iterate + (for i :from 0) + (for (function . nil) :in vars) + (collect + `(when (aref ,reg-start% ,i) + (,@(if function `(funcall ,function) `(progn)) + (subseq ,string% + (aref ,reg-start% ,i) + (aref ,reg-end% ,i)))))))))))))))) +