mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-25 22:12:40 -08:00
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.
This commit is contained in:
Marius Gerbershagen
parent
dd5c372ff8
commit
62d1bb1203
2 changed files with 103 additions and 195 deletions
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue