;;;;
;;;; 51.stk                -- Implementation of SRFI-51
;;;;
;;;; Copyright © 2020 Jeronimo Pellegrini - <j_p@aleph0.info>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; This file is a derivative work from the  implementation of
;;;; this SRFI by Joo ChurlSoo, it is copyrighted as:
;;;;
;;;;;; Copyright © Joo ChurlSoo (2004).
;;;;;;
;;;;;; 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 (including the
;;;;;; next paragraph) 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.
;;;;
;;;;           Author: Jeronimo Pellegrini [j_p@aleph0.info]
;;;;    Creation date: 22-Jun-2020 08:21 (jpellegrini)

(define-module srfi/51
  (import (srfi 1))
  (export rest-values
          arg-and
          arg-ands
          arg-or
          arg-ors
          err-and
          err-ands
          err-or
          err-ors)

(define (rest-values rest . default)
  (let* ((caller (if (or (null? default)
                         (boolean? (car default))
                         (integer? (car default))
                         (memq (car default) (list + -)))
                     '()
                     (if (string? rest) rest (list rest))))
         (rest-list (if (null? caller) rest (car default)))
         (rest-length (if (list? rest-list)
                          (length rest-list)
                          (if (string? caller)
                              (error caller rest-list 'rest-list
                                     '(list? rest-list))
                              (apply error "bad rest list" rest-list 'rest-list
                                     '(list? rest-list) caller))))
         (default (if (null? caller) default (cdr default)))
         (default-list (if (null? default) default (cdr default)))
         (default-length (length default-list))
         (number
          (and (not (null? default))
               (let ((option (car default)))
                 (or (and (integer? option)
                          (or (and (> rest-length (abs option))
                                   (if (string? caller)
                                       (error caller rest-list 'rest-list
                                              `(<= (length rest-list)
                                                   ,(abs option)))
                                       (apply error "too many arguments"
                                              rest-list 'rest-list
                                              `(<= (length rest-list)
                                                   ,(abs option))
                                              caller)))
                              (and (> default-length (abs option))
                                   (if (string? caller)
                                       (error caller default-list
                                              'default-list
                                              `(<= (length default-list)
                                                   ,(abs option)))
                                       (apply error "too many defaults"
                                              default-list 'default-list
                                              `(<= (length default-list)
                                                   ,(abs option))
                                              caller)))
                              option))
                     (eq? option #t)
                     (and (not option) 'false)
                     (and (eq? option +) +)
                     (and (eq? option -) -)
                     (if (string? caller)
                         (error caller option 'option
                                '(or (boolean? option)
                                     (integer? option)
                                     (memq option (list + -))))
                         (apply error "bad optional argument" option 'option
                                '(or (boolean? option)
                                     (integer? option)
                                     (memq option (list + -)))
                                caller)))))))
    (cond
     ((or (eq? #t number) (eq? 'false number))
      (and (not (every pair? default-list))
           (if (string? caller)
               (error caller default-list 'default-list
                      '(every pair? default-list))
               (apply error "bad default list" default-list 'default-list
                      '(every pair? default-list) caller)))
      (let loop ((rest-list rest-list)
                 (default-list default-list)
                 (result '()))
        (if (null? default-list)
            (if (null? rest-list)
                (apply values (reverse result))
                (if (eq? #t number)
                    (if (string? caller)
                        (error caller rest-list 'rest-list '(null? rest-list))
                        (apply error "bad argument" rest-list 'rest-list
                               '(null? rest-list) caller))
                    (apply values (append-reverse result rest-list))))
            (if (null? rest-list)
                (apply values (append-reverse result (map car default-list)))
                (let ((default (car default-list)))
                  (let lp ((rest rest-list)
                           (head '()))
                    (if (null? rest)
                        (loop (reverse head)
                              (cdr default-list)
                              (cons (car default) result))
                        (if (list? default)
                            (if (member (car rest) default)
                                (loop (append-reverse head (cdr rest))
                                      (cdr default-list)
                                      (cons (car rest) result))
                                (lp (cdr rest) (cons (car rest) head)))
                            (if ((cdr default) (car rest))
                                (loop (append-reverse head (cdr rest))
                                      (cdr default-list)
                                      (cons (car rest) result))
                                (lp (cdr rest) (cons (car rest) head)))))))))))
     ((or (and (integer? number) (> number 0))
          (eq? number +))
      (and (not (every pair? default-list))
           (if (string? caller)
               (error caller default-list 'default-list
                      '(every pair? default-list))
               (apply error "bad default list" default-list 'default-list
                      '(every pair? default-list) caller)))
      (let loop ((rest rest-list)
                 (default default-list))
        (if (or (null? rest) (null? default))
            (apply values
                   (if (> default-length rest-length)
                       (append rest-list
                               (map car (list-tail default-list rest-length)))
                       rest-list))
            (let ((arg (car rest))
                  (par (car default)))
              (if (list? par)
                  (if (member arg par)
                      (loop (cdr rest) (cdr default))
                      (if (string? caller)
                          (error caller arg 'arg `(member arg ,par))
                          (apply error "unmatched argument"
                                 arg 'arg `(member arg ,par) caller)))
                  (if ((cdr par) arg)
                      (loop (cdr rest) (cdr default))
                      (if (string? caller)
                          (error caller arg 'arg `(,(cdr par) arg))
                          (apply error "incorrect argument"
                                 arg 'arg `(,(cdr par) arg) caller))))))))
     (else
      (apply values (if (> default-length rest-length)
                        (append rest-list (list-tail default-list rest-length))
                        rest-list))))))

(define-syntax arg-and
  (syntax-rules()
    ((arg-and arg (a1 a2 ...) ...)
     (and (or (symbol? 'arg)
              (error "bad syntax" 'arg '(symbol? 'arg)
                     '(arg-and arg (a1 a2 ...) ...)))
          (or (a1 a2 ...)
              (error "incorrect argument" arg 'arg '(a1 a2 ...)))
          ...))
    ((arg-and caller arg (a1 a2 ...) ...)
     (and (or (symbol? 'arg)
              (error "bad syntax" 'arg '(symbol? 'arg)
                     '(arg-and caller arg (a1 a2 ...) ...)))
          (or (a1 a2 ...)
              (if (string? caller)
                  (error caller arg 'arg '(a1 a2 ...))
                  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
          ...))))

;; accessory macro for arg-ands
(define-syntax caller-arg-and
  (syntax-rules()
    ((caller-arg-and caller arg (a1 a2 ...) ...)
     (and (or (symbol? 'arg)
              (error "bad syntax" 'arg '(symbol? 'arg)
                     '(caller-arg-and caller arg (a1 a2 ...) ...)))
          (or (a1 a2 ...)
              (if (string? caller)
                  (error caller arg 'arg '(a1 a2 ...))
                  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
          ...))
    ((caller-arg-and null caller arg (a1 a2 ...) ...)
     (and (or (symbol? 'arg)
              (error "bad syntax" 'arg '(symbol? 'arg)
                     '(caller-arg-and caller arg (a1 a2 ...) ...)))
          (or (a1 a2 ...)
              (if (string? caller)
                  (error caller arg 'arg '(a1 a2 ...))
                  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
          ...))))

(define-syntax arg-ands
  (syntax-rules (common)
    ((arg-ands (a1 a2 ...) ...)
     (and (arg-and a1 a2 ...) ...))
    ((arg-ands common caller (a1 a2 ...) ...)
     (and (caller-arg-and caller a1 a2 ...) ...))))

(define-syntax arg-or
  (syntax-rules()
    ((arg-or arg (a1 a2 ...) ...)
     (or (and (not (symbol? 'arg))
              (error "bad syntax" 'arg '(symbol? 'arg)
                     '(arg-or arg (a1 a2 ...) ...)))
         (and (a1 a2 ...)
              (error "incorrect argument" arg 'arg '(a1 a2 ...)))
         ...))
    ((arg-or caller arg (a1 a2 ...) ...)
     (or (and (not (symbol? 'arg))
              (error "bad syntax" 'arg '(symbol? 'arg)
                     '(arg-or caller arg (a1 a2 ...) ...)))
         (and (a1 a2 ...)
              (if (string? caller)
                  (error caller arg 'arg '(a1 a2 ...))
                  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
         ...))))

;; accessory macro for arg-ors
(define-syntax caller-arg-or
  (syntax-rules()
    ((caller-arg-or caller arg (a1 a2 ...) ...)
     (or (and (not (symbol? 'arg))
              (error "bad syntax" 'arg '(symbol? 'arg)
                     '(caller-arg-or caller arg (a1 a2 ...) ...)))
         (and (a1 a2 ...)
              (if (string? caller)
                  (error caller arg 'arg '(a1 a2 ...))
                  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
         ...))
    ((caller-arg-or null caller arg (a1 a2 ...) ...)
     (or (and (not (symbol? 'arg))
              (error "bad syntax" 'arg '(symbol? 'arg)
                     '(caller-arg-or caller arg (a1 a2 ...) ...)))
         (and (a1 a2 ...)
              (if (string? caller)
                  (error caller arg 'arg '(a1 a2 ...))
                  (error "incorrect argument" arg 'arg '(a1 a2 ...) caller)))
         ...))))

(define-syntax arg-ors
  (syntax-rules (common)
    ((arg-ors (a1 a2 ...) ...)
     (or (arg-or a1 a2 ...) ...))
    ((arg-ors common caller (a1 a2 ...) ...)
     (or (caller-arg-or caller a1 a2 ...) ...))))

(define-syntax err-and
  (syntax-rules ()
    ((err-and err expression ...)
     (and (or expression
              (if (string? err)
                  (error err 'expression)
                  (error "false expression" 'expression err)))
          ...))))

(define-syntax err-ands
  (syntax-rules ()
    ((err-ands (err expression ...)  ...)
     (and (err-and err expression ...)
          ...))))

(define-syntax err-or
  (syntax-rules ()
    ((err-or err expression ...)
     (or (and expression
              (if (string? err)
                  (error err 'expression)
                  (error "true expression" 'expression err)))
         ...))))

(define-syntax err-ors
  (syntax-rules ()
    ((err-ors (err expression ...) ...)
     (or (err-or err expression ...)
         ...))))

) ;; END OF DEFINE-MODULE

(provide "srfi/51")
