mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-26 22:43:13 -08:00
62d1bb1203
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.
203 lines
8.2 KiB
Common Lisp
203 lines
8.2 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
|
|
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
|
|
|
;;;;
|
|
;;;; CMPOPT-SEQUENCE Optimization of SEQUENCE functions
|
|
;;;;
|
|
;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll
|
|
;;;;
|
|
;;;; This program is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Library General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 2 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; See file '../Copyright' for full details.
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun constant-function-expression (form)
|
|
(and (consp form)
|
|
(member (first form) '(quote function lambda))))
|
|
|
|
(defun seq-opt-test-function (test-flag test %test)
|
|
(cond ((null test-flag)
|
|
#'(lambda (v1 v2) `(eql ,v1 ,v2)))
|
|
((eq test-flag :test-not)
|
|
(if (constant-function-expression test)
|
|
#'(lambda (v1 v2) `(not (funcall ,test ,v1 ,v2)))
|
|
#'(lambda (v1 v2) `(not (funcall ,%test ,v1 ,v2)))))
|
|
(t
|
|
(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 %key)
|
|
(cond ((null key)
|
|
#'identity)
|
|
((constant-function-expression key)
|
|
#'(lambda (elt) `(funcall ,key ,elt)))
|
|
(t
|
|
#'(lambda (elt) `(funcall (or ,%key #'identity) ,elt)))))
|
|
|
|
#+(or)
|
|
(define-compiler-macro si::make-seq-iterator (seq &optional (start 0))
|
|
(with-clean-symbols (%seq %start)
|
|
`(let ((%seq (optional-type-check ,seq sequence))
|
|
(%start ,start))
|
|
(cond ((consp %seq)
|
|
(nthcdr %start %seq))
|
|
((< %start (length %seq))
|
|
%start)
|
|
(t
|
|
nil)))))
|
|
|
|
#+(or)
|
|
(define-compiler-macro si::seq-iterator-ref (seq iterator)
|
|
(with-clean-symbols (%seq %iterator)
|
|
`(let* ((%seq ,seq)
|
|
(%iterator ,iterator))
|
|
(declare (optimize (safety 0)))
|
|
(if (si::fixnump %iterator)
|
|
;; Fixnum iterators are always fine
|
|
(aref %seq %iterator)
|
|
;; Error check in case we may have been passed an improper list
|
|
(cons-car (checked-value cons %iterator))))))
|
|
|
|
#+(or)
|
|
(define-compiler-macro si::seq-iterator-next (seq iterator)
|
|
(with-clean-symbols (%seq %iterator)
|
|
`(let* ((%seq ,seq)
|
|
(%iterator ,iterator))
|
|
(declare (optimize (safety 0)))
|
|
(if (si::fixnump %iterator)
|
|
(let ((%iterator (1+ (truly-the fixnum %iterator))))
|
|
(declare (fixnum %iterator))
|
|
(and (< %iterator (length (truly-the vector %seq)))
|
|
%iterator))
|
|
(cons-cdr %iterator)))))
|
|
|
|
(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)
|
|
0))
|
|
(test (if end
|
|
`(and ,%iterator (plusp ,%counter))
|
|
%iterator)))
|
|
`(let* ((,%iterator (si::make-seq-iterator ,%sequence ,%start))
|
|
(,%counter ,counter))
|
|
(declare (:read-only ,%sequence ,%start ,%counter)
|
|
(ignorable ,%counter)
|
|
(fixnum ,%counter))
|
|
(loop
|
|
(unless ,test (return ,output))
|
|
(let ((,%elt (si::seq-iterator-ref ,%sequence ,%iterator)))
|
|
,@body)
|
|
(setf ,%iterator (si::seq-iterator-next ,%sequence ,%iterator))
|
|
,(when end
|
|
`(decf ,%counter)))))))
|
|
|
|
;;;
|
|
;;; MEMBER
|
|
;;;
|
|
|
|
(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)))
|
|
|
|
(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
|
|
;;;
|
|
|
|
(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
|
|
;;;
|
|
|
|
(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)))))
|