From 6102b240d6bd41b73236d26cbe88104365a6d03f Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Mon, 6 Jul 2015 21:37:28 -0400 Subject: [PATCH] Define quantifiers as source-transforms. This avoids style-warnings during self-build due to the compiler-macro being defined too late. --- build-order.lisp-expr | 1 + src/code/early-extensions.lisp | 12 ++--- src/code/quantifiers.lisp | 99 ++++++++++++++++++++++++++++++++++++++++++ src/code/seq.lisp | 94 --------------------------------------- 4 files changed, 106 insertions(+), 100 deletions(-) create mode 100644 src/code/quantifiers.lisp diff --git a/build-order.lisp-expr b/build-order.lisp-expr index ecd320756..690c5d257 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -522,6 +522,7 @@ ("src/compiler/float-tran") ("src/compiler/saptran") ("src/compiler/srctran") + ("src/code/quantifiers") ("src/compiler/bitops-derive-type") ("src/compiler/generic/vm-tran") ("src/compiler/locall") diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index a9f5170c9..4c3b2dd15 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -1541,17 +1541,17 @@ to :INTERPRET, an interpreter will be used.") ;;; Helper for making the DX closure allocation in macros expanding ;;; to CALL-WITH-FOO less ugly. -(defmacro dx-flet (functions &body forms) +(def!macro dx-flet (functions &body forms) `(flet ,functions - (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent - ,@(mapcar (lambda (func) `(function ,(car func))) functions))) + (declare (truly-dynamic-extent ,@(mapcar (lambda (func) `#',(car func)) + functions))) ,@forms)) ;;; Another similar one. -(defmacro dx-let (bindings &body forms) +(def!macro dx-let (bindings &body forms) `(let ,bindings - (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent - ,@(mapcar (lambda (bind) (if (consp bind) (car bind) bind)) + (declare (truly-dynamic-extent + ,@(mapcar (lambda (bind) (if (listp bind) (car bind) bind)) bindings))) ,@forms)) diff --git a/src/code/quantifiers.lisp b/src/code/quantifiers.lisp new file mode 100644 index 000000000..dbf7e5b3b --- /dev/null +++ b/src/code/quantifiers.lisp @@ -0,0 +1,99 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!IMPL") + +;;;; quantifiers + +;;; We borrow the logic from (MAP NIL ..) to handle iteration over +;;; arbitrary sequence arguments, both in the full call case and in +;;; the open code case. +(flet ((expand (pred sequences test found-result unfound-result) + (unless (proper-list-of-length-p sequences 1 call-arguments-limit) + (return-from expand (values nil t))) ; give up + (binding* ((elements (make-gensym-list (length sequences))) + ((bind-fun call-it) (funarg-bind/call-forms pred elements)) + (blockname (sb!xc:gensym "BLOCK")) + (wrapper (sb!xc:gensym "WRAPPER")) + (value (sb!xc:gensym "VAL"))) + (let ((form + `(block ,blockname + (dx-flet ((,wrapper (,@elements) + (declare (optimize + (sb!c::check-tag-existence 0))) + (let ((,value ,call-it)) + (,test ,value + (return-from ,blockname + ,(if (eq found-result :value) + value + found-result)))))) + (declare (inline ,wrapper)) + (map nil #',wrapper ,@sequences) + ,unfound-result)))) + (values (if bind-fun `(let ,bind-fun ,form) form) nil))))) + (macrolet ((defquantifier (name found-test found-result + &key doc (unfound-result (not found-result))) + (declare (ignorable doc)) + `(progn + ;; KLUDGE: It would be really nice if we could simply + ;; do something like this + ;; (declaim (inline ,name)) + ;; (defun ,name (pred first-seq &rest more-seqs) + ;; ,doc + ;; (flet ((map-me (&rest rest) + ;; (let ((pred-value (apply pred rest))) + ;; (,found-test pred-value + ;; (return-from ,name + ;; ,found-result))))) + ;; (declare (inline map-me)) + ;; (apply #'map nil #'map-me first-seq more-seqs) + ;; ,unfound-result)) + ;; but Python doesn't seem to be smart enough about + ;; inlining and APPLY to recognize that it can use + ;; the DEFTRANSFORM for MAP in the resulting inline + ;; expansion. I don't have any appetite for deep + ;; compiler hacking right now, so I'll just work + ;; around the apparent problem by using a compiler + ;; macro instead. -- WHN 20000410 + (sb!c:define-source-transform ,name (pred &rest sequences) + (expand pred sequences + ',found-test ',found-result ',unfound-result)) + #-sb-xc-host ; don't redefine CL builtins! + (defun ,name (pred first-seq &rest more-seqs) + #!+sb-doc ,doc + (flet ((map-me (&rest rest) + (let ((value (apply pred rest))) + (,found-test value + (return-from ,name + ,(if (eq found-result :value) + 'value + found-result)))))) + (declare (inline map-me)) + (apply #'map nil #'map-me first-seq more-seqs) + ,unfound-result))))) + + (defquantifier some when :value :unfound-result nil + :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return the first + non-NIL value encountered, or NIL if the end of any sequence is reached.") + (defquantifier every unless nil + :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon + as any invocation of PREDICATE returns NIL, or T if every invocation + is non-NIL.") + (defquantifier notany when nil + :doc "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon + as any invocation of PREDICATE returns a non-NIL value, or T if the end + of any sequence is reached.") + (defquantifier notevery unless t + :doc "Apply PREDICATE to 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return T as soon + as any invocation of PREDICATE returns NIL, or NIL if every invocation + is non-NIL."))) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 2cab206dc..0727ad928 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1185,100 +1185,6 @@ many elements are copied." iter from-end))))))) result-sequence) -;;;; quantifiers - -;;; We borrow the logic from (MAP NIL ..) to handle iteration over -;;; arbitrary sequence arguments, both in the full call case and in -;;; the open code case. -(macrolet ((defquantifier (name found-test found-result - &key doc (unfound-result (not found-result))) - `(progn - ;; KLUDGE: It would be really nice if we could simply - ;; do something like this - ;; (declaim (inline ,name)) - ;; (defun ,name (pred first-seq &rest more-seqs) - ;; ,doc - ;; (flet ((map-me (&rest rest) - ;; (let ((pred-value (apply pred rest))) - ;; (,found-test pred-value - ;; (return-from ,name - ;; ,found-result))))) - ;; (declare (inline map-me)) - ;; (apply #'map nil #'map-me first-seq more-seqs) - ;; ,unfound-result)) - ;; but Python doesn't seem to be smart enough about - ;; inlining and APPLY to recognize that it can use - ;; the DEFTRANSFORM for MAP in the resulting inline - ;; expansion. I don't have any appetite for deep - ;; compiler hacking right now, so I'll just work - ;; around the apparent problem by using a compiler - ;; macro instead. -- WHN 20000410 - (defun ,name (pred first-seq &rest more-seqs) - #!+sb-doc ,doc - (flet ((map-me (&rest rest) - (let ((pred-value (apply pred rest))) - (,found-test pred-value - (return-from ,name - ,found-result))))) - (declare (inline map-me)) - (apply #'map nil #'map-me first-seq more-seqs) - ,unfound-result)) - ;; KLUDGE: It would be more obviously correct -- but - ;; also significantly messier -- for PRED-VALUE to be - ;; a gensym. However, a private symbol really does - ;; seem to be good enough; and anyway the really - ;; obviously correct solution is to make Python smart - ;; enough that we can use an inline function instead - ;; of a compiler macro (as above). -- WHN 20000410 - ;; - ;; FIXME: The DEFINE-COMPILER-MACRO here can be - ;; important for performance, and it'd be good to have - ;; it be visible throughout the compilation of all the - ;; target SBCL code. That could be done by defining - ;; SB-XC:DEFINE-COMPILER-MACRO and using it here, - ;; moving this DEFQUANTIFIER stuff (and perhaps other - ;; inline definitions in seq.lisp as well) into a new - ;; seq.lisp, and moving remaining target-only stuff - ;; from the old seq.lisp into target-seq.lisp. - (define-compiler-macro ,name (pred first-seq &rest more-seqs) - (binding* ((elements - (make-gensym-list (1+ (length more-seqs)))) - (blockname (sb!xc:gensym "BLOCK")) - (wrapper (sb!xc:gensym "WRAPPER")) - ((bind call) - (funarg-bind/call-forms pred elements))) - `(let ,bind - (block ,blockname - (flet ((,wrapper (,@elements) - (declare (optimize (sb!c::check-tag-existence 0))) - (let ((pred-value ,call)) - (,',found-test pred-value - (return-from ,blockname ,',found-result))))) - (declare (inline ,wrapper) - (dynamic-extent #',wrapper)) - (map nil #',wrapper ,first-seq - ,@more-seqs)) - ,',unfound-result))))))) - (defquantifier some when pred-value :unfound-result nil :doc - "Apply PREDICATE to the 0-indexed elements of the sequences, then - possibly to those with index 1, and so on. Return the first - non-NIL value encountered, or NIL if the end of any sequence is reached.") - (defquantifier every unless nil :doc - "Apply PREDICATE to the 0-indexed elements of the sequences, then - possibly to those with index 1, and so on. Return NIL as soon - as any invocation of PREDICATE returns NIL, or T if every invocation - is non-NIL.") - (defquantifier notany when nil :doc - "Apply PREDICATE to the 0-indexed elements of the sequences, then - possibly to those with index 1, and so on. Return NIL as soon - as any invocation of PREDICATE returns a non-NIL value, or T if the end - of any sequence is reached.") - (defquantifier notevery unless t :doc - "Apply PREDICATE to 0-indexed elements of the sequences, then - possibly to those with index 1, and so on. Return T as soon - as any invocation of PREDICATE returns NIL, or NIL if every invocation - is non-NIL.")) - ;;;; REDUCE (eval-when (:compile-toplevel :execute) -- 2.11.4.GIT