From 62d1bb1203a3ea83c36cd51ee24d28eed2a27cdd Mon Sep 17 00:00:00 2001 From: Marius Gerbershagen Date: Tue, 30 Mar 2021 23:07:52 +0200 Subject: [PATCH] cmp: fix evaluation order of sequence compiler macros Minor improvements to define-compiler-macro* (bail out if we detect :allow-other-keys arguments, define a named block such that return-from works as expected). Major refactor of sequence compiler-macros: use define-compiler-macro* which handles correct evaluation order, define new macro to handle common stuff for all sequences compiler-macros (e.g. inline policy checking, check that test and test-not are not both given). The main expansion logic in the compiler macros is unchanged although the code had to be slightly rewritten to accomodate the new macros. Remove the now superfluous seq-opt-parse-args function. --- src/cmp/cmpopt-sequence.lsp | 293 ++++++++++++------------------------ src/cmp/cmputil.lsp | 5 +- 2 files changed, 103 insertions(+), 195 deletions(-) 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