Commit 62d1bb12 authored by Marius Gerbershagen's avatar Marius Gerbershagen
Browse files

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.
parent dd5c372f
......@@ -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)))))))
(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))
(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-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)))))
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment