;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: Allow for &REST after &KEY in lambda lists
;;   Created: 2025-03-29
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;  (c) copyright 2025 by Gilbert Baumann

;;  Permission is hereby granted, free of charge, to any person obtaining
;;  a copy of this software and associated documentation files (the
;;  "Software"), to deal in the Software without restriction, including
;;  without limitation the rights to use, copy, modify, merge, publish,
;;  distribute, sublicense, and/or sell copies of the Software, and to
;;  permit persons to whom the Software is furnished to do so, subject to
;;  the following conditions:
;; 
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(in-package :cl-user)

;; A common task is to have a function which takes keywords to pass on
;; what would be the &rest argument without the keys specified in the
;; lambda list. This is a bit of tedious business in ANSI-CL.

;; The idea is to allow for &REST after any &KEY parameters have been
;; given. That &REST parameter would then only receive those arguments
;; that aren't already consumed by preceding &KEY parameters. Best
;; served with &ALLOW-OTHER-KEYS.

;; Example:

;; (translate-lambda-list '(&key x y &allow-other-keys &rest r))
;; => (&REST #:REST/728 &KEY X Y &ALLOW-OTHER-KEYS &AUX (R (REMOVE-PROPERTIES '(:X :Y) #:REST/728)))

(eval-when (:compile-toplevel :execute :load-toplevel)
  (defun translate-lambda-list (lambda-list &optional (kind :function))
    "Translate the lambda list /lambda-list/ which allows for &REST
after &KEY to an ANSI-CL lambda list."
    (declare (ignore kind))
    (let ((yet-keys nil) auxes cur-rest syn-rest ignores)
      (labels ((cons* (cell ca cd)
                 (if (and (eq ca (car cell))
                          (eq cd (cdr cell)))
                     cell
                     (list* ca cd)))
               (aux (q)
                 (cond ((null q) nil)
                       ((eq '&key (car q))
                        (let ((res (aux-keys (cdr q))))
                          (if syn-rest
                              `(&rest ,syn-rest ,@(cons* q '&key res))
                              (cons* q '&key res))))
                       ((eq '&rest (car q))
                        (setq cur-rest (cadr q))
                        (cons* q '&rest (cons* (cdr q) (cadr q) (aux (cddr q)))))
                       (t
                        (cons* q (car q) (aux (cdr q))))))
               (aux-keys (q)
                 (cond ((null q)
                        (if auxes
                            `(&aux ,@(reverse auxes))
                            nil))
                       ((eq '&rest (car q))
                        (unless cur-rest
                          (setq cur-rest (setq syn-rest (gensym "REST/")))
                          (push syn-rest ignores))
                        (push `(,(cadr q)
                                 (remove-properties ',(mapcar #'key-param-key (reverse yet-keys))
                                                    ,cur-rest))
                              auxes)
                        (setq cur-rest (cadr q) yet-keys nil)
                        (aux-keys (cddr q)))
                       ((eq '&key (car q))
                        (aux-keys (cdr q)))
                       ((eq '&allow-other-keys (car q))
                        (cons* q (car q) (aux-keys (cdr q))))
                       ((member (car q) lambda-list-keywords)
                        (aux-other q))
                       (t
                        (push (car q) yet-keys)
                        (unless (eq cur-rest syn-rest) (push (key-param-var (car q)) ignores))
                        (cons* q (car q) (aux-keys (cdr q))))))
               (aux-other (q)
                 (cond ((null q)
                        (if auxes
                            `(&aux ,@(reverse auxes))
                            nil))
                       ((eq '&aux (car q))
                        (if auxes
                            `(&aux ,@(reverse auxes) ,@(cdr q))
                            q))
                       (t
                        (cons* q (car q) (aux-other (cdr q)))))))
        ;;
        (values (aux lambda-list) ignores))))

  (defun key-param-key (p)
    (etypecase p
      (symbol                     (intern (string p) :keyword))
      ((cons symbol t)            (intern (string (car p)) :keyword))
      ((cons (cons symbol t) t)   (caar p))))

  (defun key-param-var (p)
    (etypecase p
      (symbol                     p)
      ((cons symbol t)            (car p))
      ((cons (cons symbol t) t)   (cadar p)))) )

(defun remove-properties (properties plist)
  (loop for (k v) on plist by #'cddr nconc (unless (member k properties) (list k v))))