diff --git a/src/cmp/cmpopt-sequence.lsp b/src/cmp/cmpopt-sequence.lsp index ba7fe6c01..259ff8f3e 100644 --- a/src/cmp/cmpopt-sequence.lsp +++ b/src/cmp/cmpopt-sequence.lsp @@ -19,91 +19,25 @@ (and (consp form) (member (first form) '(quote function lambda)))) -(defun seq-opt-test-function (test-flag test) +(defun seq-opt-test-function (test-flag test %test) (cond ((null test-flag) - (values (seq-opt-test-function :test '#'eql) nil)) + #'(lambda (v1 v2) `(eql ,v1 ,v2))) ((eq test-flag :test-not) - (multiple-value-bind (function init) - (seq-opt-test-function :test test) - (values #'(lambda (v1 v2) `(not ,(funcall function v1 v2))) - init))) - ((constant-function-expression test) - (values #'(lambda (v1 v2) `(funcall ,test ,v1 ,v2)) - nil)) + (if (constant-function-expression test) + #'(lambda (v1 v2) `(not (funcall ,test ,v1 ,v2))) + #'(lambda (v1 v2) `(not (funcall ,%test ,v1 ,v2))))) (t - (ext:with-unique-names (test-function) - (values #'(lambda (v1 v2) `(funcall ,test-function ,v1 ,v2)) - (list (list test-function test))))))) + (if (constant-function-expression test) + #'(lambda (v1 v2) `(funcall ,test ,v1 ,v2)) + #'(lambda (v1 v2) `(funcall ,%test ,v1 ,v2)))))) -(defun seq-opt-key-function (key) +(defun seq-opt-key-function (key %key) (cond ((null key) - (values #'identity nil)) + #'identity) ((constant-function-expression key) - (values #'(lambda (elt) `(funcall ,key ,elt)) - nil)) + #'(lambda (elt) `(funcall ,key ,elt))) (t - (ext:with-unique-names (key-function) - (values #'(lambda (elt) `(funcall ,key-function ,elt)) - (list (list key-function - `(or ,key #'identity)))))))) - -(defun seq-opt-parse-args (function args &key (start-end t)) - (loop with key-flag = nil - with key = nil - with init = nil - with test = ''eql - with test-flag = nil - with start = 0 - with end = nil - with keyword - while args - do (cond ((or (atom args) - (null (rest args)) - (eq keyword :allow-other-keys) - (not (keywordp (setf keyword (pop args))))) - (return nil)) - ((eq keyword :key) - (unless key-flag - (setf key (pop args) - key-flag t))) - ((or (eq keyword :test) - (eq keyword :test-not)) - (cond ((null test-flag) - (setf test (pop args) - test-flag keyword)) - ((not (eq test-flag keyword)) - (cmpwarn "Cannot specify :TEST and :TEST-NOT arguments to ~A" - function) - (return nil)))) - ((eq keyword :start) - (unless start-end - (cmpwarn "Unexpected keyword argument ~A in a call to function ~A" - keyword function) - (return nil)) - (setf start (pop args))) - ((eq keyword :end) - (unless start-end - (cmpwarn "Unexpected keyword argument ~A in a call to function ~A" - keyword function) - (return nil)) - (setf end (pop args))) - ((eq keyword :from-end) - (unless (null (pop args)) - (return nil))) - (t (return nil))) - finally - (multiple-value-bind (key-function key-init) - (seq-opt-key-function key) - (multiple-value-bind (test-function test-init) - (seq-opt-test-function test-flag test) - (return (values key-function - test-function - (nconc key-init test-init) - key-flag - test-flag - test - start - end)))))) + #'(lambda (elt) `(funcall (or ,%key #'identity) ,elt))))) #+(or) (define-compiler-macro si::make-seq-iterator (seq &optional (start 0)) @@ -142,17 +76,15 @@ %iterator)) (cons-cdr %iterator))))) -(defmacro do-in-seq ((%elt sequence &key (start 0) end output) &body body) - (ext:with-unique-names (%start %iterator %counter %sequence) +(defmacro do-in-seq ((%elt %sequence &key %start %end end output) &body body) + (ext:with-unique-names (%iterator %counter) (let* ((counter (if end - `(- (or ,end most-positive-fixnum) ,%start) + `(- (or ,%end most-positive-fixnum) ,%start) 0)) (test (if end `(and ,%iterator (plusp ,%counter)) %iterator))) - `(let* ((,%sequence ,sequence) - (,%start ,start) - (,%iterator (si::make-seq-iterator ,%sequence ,%start)) + `(let* ((,%iterator (si::make-seq-iterator ,%sequence ,%start)) (,%counter ,counter)) (declare (:read-only ,%sequence ,%start ,%counter) (ignorable ,%counter) @@ -169,128 +101,103 @@ ;;; MEMBER ;;; -(defmacro do-in-list ((%elt %sublist list &rest output) &body body) - `(do* ((,%sublist ,list (cons-cdr ,%sublist))) +(defmacro do-in-list ((%elt %sublist %list &rest output) &body body) + `(do* ((,%sublist ,%list (cons-cdr ,%sublist))) ((null ,%sublist) ,@output) (let* ((,%sublist (optional-type-check ,%sublist cons)) (,%elt (cons-car ,%sublist))) ,@body))) -(defun expand-member (value list &rest sequence-args) - (multiple-value-bind (key-function test-function init - key-flag test-flag test) - (seq-opt-parse-args 'member sequence-args :start-end nil) - ;; When having complex arguments (:allow-other-keys, etc) - ;; we just give up. - (when (null key-function) - (return-from expand-member nil)) - (unless key-flag - (when (and (or (null test) (constant-function-expression test)) - (constant-expression-p list)) - (when (<= (length (setf list (cmp-eval list))) 4) - (return-from expand-member - (ext:with-unique-names (%value) - `(let ((,%value ,value)) - (or ,@(loop for l on list - for elt = (first l) - collect `(and ,(funcall test-function %value `',elt) - ',l))))))) - (when (or (consp list) (symbolp list)) - (setf list `',list))) - (when (or (null test-flag) (eq test-flag :test)) - (when (member test '('EQ #'EQ) :test #'equal) - (return-from expand-member - `(ffi:c-inline (,value ,list) (:object :object) :object - "si_memq(#0,#1)" :one-liner t :side-effects nil))) - (when (member test '('EQL #'EQL) :test #'equal) - (return-from expand-member - `(ffi:c-inline (,value ,list) (:object :object) :object - "ecl_memql(#0,#1)" :one-liner t :side-effects nil))) - (when (member test '('EQUAL #'EQUAL) :test #'equal) - (return-from expand-member - `(ffi:c-inline (,value ,list) (:object :object) :object - "ecl_member(#0,#1)" :one-liner t :side-effects nil))))) - (ext:with-unique-names (%value %list %sublist %elt) - `(let ((,%value ,value) - (,%list ,list) - ,@init) - (do-in-list (,%elt ,%sublist ,%list) - (when ,(funcall test-function %value - (funcall key-function %elt)) - (return ,%sublist))))))) +(defmacro define-seq-compiler-macro (name lambda-list &body body) + (let ((whole (second lambda-list))) + `(define-compiler-macro* ,name ,lambda-list + (unless (policy-inline-sequence-functions) + (return-from ,name ,whole)) + (when (and test test-not) + (cmpwarn "Cannot specify both :TEST and :TEST-NOT arguments to ~A" ',name) + (return-from ,name ,whole)) + (let* ((test-flag (cond (test :test) + (test-not :test-not) + (t nil))) + (key-function (seq-opt-key-function key %key)) + (test-function (seq-opt-test-function test-flag + (if test test test-not) + (if test %test %test-not)))) + (declare (ignorable test-flag key-function test-function)) + ,@body)))) -(define-compiler-macro member (&whole whole value list &rest sequence-args) - (declare (ignore value list sequence-args)) - (if (policy-inline-sequence-functions) - (or (apply #'expand-member (rest whole)) - whole) - whole)) +(define-seq-compiler-macro member (&whole whole value list &key key test test-not) + (unless key + (when (and (or (null test) (constant-function-expression test)) + (constant-expression-p list)) + (let ((evaluated-list (cmp-eval list))) + (when (and (si:proper-list-p evaluated-list) (<= (length evaluated-list) 4)) + (return-from member + `(or ,@(loop for l on evaluated-list + for elt = (first l) + collect `(and ,(funcall test-function %value `(quote ,elt)) + ',l))))) + (when (or (consp evaluated-list) (symbolp evaluated-list)) + (setf list `',evaluated-list)))) + (when (or (null test-flag) (eq test-flag :test)) + (when (member test '('EQ #'EQ) :test #'equal) + (return-from member + `(ffi:c-inline (,%value ,%list) (:object :object) :object + "si_memq(#0,#1)" :one-liner t :side-effects nil))) + (when (or (member test '('EQL #'EQL) :test #'equal) (null test)) + (return-from member + `(ffi:c-inline (,%value ,%list) (:object :object) :object + "ecl_memql(#0,#1)" :one-liner t :side-effects nil))) + (when (member test '('EQUAL #'EQUAL) :test #'equal) + (return-from member + `(ffi:c-inline (,%value ,%list) (:object :object) :object + "ecl_member(#0,#1)" :one-liner t :side-effects nil))))) + (ext:with-unique-names (%sublist %elt) + `(do-in-list (,%elt ,%sublist ,%list) + (when ,(funcall test-function %value + (funcall key-function %elt)) + (return ,%sublist))))) ;;; ;;; ASSOC ;;; -(defun expand-assoc (value list &rest sequence-args) - (multiple-value-bind (key-function test-function init - key-flag test-flag test) - (seq-opt-parse-args 'assoc sequence-args :start-end nil) - (unless key-flag - (when (or (null test-flag) (eq test-flag :test)) - (when (member test '('EQ #'EQ) :test #'equal) - (return-from expand-assoc - `(ffi:c-inline (,value ,list) (:object :object) :object - "ecl_assq(#0,#1)" :one-liner t :side-effects nil))) - (when (member test '('EQL #'EQL) :test #'equal) - (return-from expand-assoc - `(ffi:c-inline (,value ,list) (:object :object) :object - "ecl_assql(#0,#1)" :one-liner t :side-effects nil))) - (when (member test '('EQUAL #'EQUAL) :test #'equal) - (return-from expand-assoc - `(ffi:c-inline (,value ,list) (:object :object) :object - "ecl_assoc(#0,#1)" :one-liner t :side-effects nil))) - (when (member test '('EQUALP #'EQUALP) :test #'equal) - (return-from expand-assoc - `(ffi:c-inline (,value ,list) (:object :object) :object - "ecl_assqlp(#0,#1)" :one-liner t :side-effects nil))))) - (when test-function - (ext:with-unique-names (%value %list %sublist %elt %car) - `(let ((,%value ,value) - (,%list ,list) - ,@init) - (do-in-list (,%elt ,%sublist ,%list) - (when ,%elt - (let ((,%car (cons-car (optional-type-check ,%elt cons)))) - (when ,(funcall test-function %value - (funcall key-function %car)) - (return ,%elt)))))))))) - -(define-compiler-macro assoc (&whole whole value list &rest sequence-args) - (declare (ignore value list sequence-args)) - (if (policy-inline-sequence-functions) - (or (apply #'expand-assoc (rest whole)) - whole) - whole)) +(define-seq-compiler-macro assoc (&whole whole value list &key key test test-not) + (unless key + (when (or (null test-flag) (eq test-flag :test)) + (when (member test '('EQ #'EQ) :test #'equal) + (return-from assoc + `(ffi:c-inline (,%value ,%list) (:object :object) :object + "ecl_assq(#0,#1)" :one-liner t :side-effects nil))) + (when (or (member test '('EQL #'EQL) :test #'equal) (null test)) + (return-from assoc + `(ffi:c-inline (,%value ,%list) (:object :object) :object + "ecl_assql(#0,#1)" :one-liner t :side-effects nil))) + (when (member test '('EQUAL #'EQUAL) :test #'equal) + (return-from assoc + `(ffi:c-inline (,%value ,%list) (:object :object) :object + "ecl_assoc(#0,#1)" :one-liner t :side-effects nil))) + (when (member test '('EQUALP #'EQUALP) :test #'equal) + (return-from assoc + `(ffi:c-inline (,%value ,%list) (:object :object) :object + "ecl_assqlp(#0,#1)" :one-liner t :side-effects nil))))) + (ext:with-unique-names (%sublist %elt %car) + `(do-in-list (,%elt ,%sublist ,%list) + (when ,%elt + (let ((,%car (cons-car (optional-type-check ,%elt cons)))) + (when ,(funcall test-function %value + (funcall key-function %car)) + (return ,%elt))))))) ;;; ;;; FIND ;;; -(defun expand-find (value sequence &rest sequence-args) - (multiple-value-bind (key-function test-function init - key-flag test-flag test start end) - (seq-opt-parse-args 'find sequence-args) - (when test-function - (ext:with-unique-names (%value %elt) - `(let ((,%value ,value) - ,@init) - (do-in-seq (,%elt ,sequence :start ,start :end ,end) - (when ,(funcall test-function %value - (funcall key-function %elt)) - (return ,%elt)))))))) - -(define-compiler-macro find (&whole whole value sequence &rest sequence-args) - (declare (ignore value sequence sequence-args)) - (if (policy-inline-sequence-functions) - (or (apply #'expand-find (rest whole)) - whole) - whole)) +(define-seq-compiler-macro find (&whole whole value sequence &key key test test-not (start 0) end from-end) + (when from-end + (return-from find whole)) + (ext:with-unique-names (%elt) + `(do-in-seq (,%elt ,%sequence :%start ,%start :%end ,%end :end ,end) + (when ,(funcall test-function %value + (funcall key-function %elt)) + (return ,%elt))))) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index d170e2f4b..d69ed411f 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -529,7 +529,8 @@ keyword argument, the compiler-macro declines to provide an expansion. (loop for ,given-keyword in ,rest by #'cddr for ,given-arg in (rest ,rest) by #'cddr for ,some-keyword-found = nil - do (when (not (keywordp ,given-keyword)) + do (when (or (not (keywordp ,given-keyword)) + (eq ,given-keyword :allow-other-keys)) (return-from ,name ,whole)) ,@parse-forms-pass1 (when (not ,some-keyword-found) @@ -620,7 +621,7 @@ keyword argument, the compiler-macro declines to provide an expansion. ,(pass1-parse) ,@aux-setf-forms ;; evaluate the body of the compiler-macro - (let ((,output (locally ,@body))) + (let ((,output (block ,name (locally ,@body)))) (if (eq ,output ,whole) ,whole (progn