;;;
;;; libalpha.scm - Procedures needed by other lib*.scm
;;;
;;;   Copyright (c) 2000-2020  Shiro Kawai  <shiro@acm.org>
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

;; This file is initialized first among lib-*.scm.  Define procedures
;; here that are required to run initialization of other lib-*.scm files.

(select-module gauche.internal)

(inline-stub
 (declcode (.include <gauche/vminsn.h>
                     <gauche/priv/macroP.h>)))

;;;
;;;  errors
;;;

(select-module gauche.internal)
(define (%error-scan-keys args)
  (let loop ([args args] [keys '()])
    (if (and (not (null? args))
             (keyword? (car args))
             (not (null? (cdr args))))
      (loop (cddr args) (list* (cadr args) (car args) keys))
      (values (reverse! keys) args))))

(define (%make-error-message msg args) ; srfi-23 style message
  (let1 p (open-output-string)
    (display msg p)
    (dolist [obj args] (display " " p) (write/ss obj p))
    (get-output-string p)))

;; Handy when you want to create <error> object without immediately raising it.
(define-in-module gauche (make-error msg . args)
  (make <error> :message (%make-error-message msg args)
        :message-prefix msg :message-args args))

;; error and errorf.  A bit messy to allow optional condition class argument
;; as the first arg.
(define-in-module gauche (error msg . args)
  (raise
   (cond
    [(is-a? msg <condition-meta>)
     (receive (keys msgs) (%error-scan-keys args)
       (if (null? msgs)
         (apply make msg keys)
         (apply make msg
                :message (%make-error-message (car msgs) (cdr msgs)) keys)))]
    [else (apply make-error msg args)])))

(define-in-module gauche (errorf fmt . args)
  (raise
   (cond
    [(is-a? fmt <condition-meta>)
     (receive (keys msgs) (%error-scan-keys args)
       (if (null? msgs)
         (apply make fmt keys)
         (apply make fmt :message (apply format/ss #f msgs) keys)))]
    [else (make <error> :message (apply format/ss #f fmt args))])))

;;;
;;;  make-vector
;;;

;; make-vector needs to be defined here, for it is called
;; in other initalization routines.
(select-module scheme)
(define-cproc make-vector (k::<fixnum> :optional fill) Scm_MakeVector)

;;;
;;;  srfi-17 support
;;;

;; some libraries needs to set the setter procedures during initialization,
;; so we should have it before them.

(select-module gauche)
(define-cproc getter-with-setter (proc::<procedure> set::<procedure>) ;SRFI-17
  (case (SCM_PROCEDURE_TYPE proc)
    [(SCM_PROC_SUBR SCM_PROC_CLOSURE)]  ;ok
    [(SCM_PROC_GENERIC SCM_PROC_METHOD)
     (Scm_Error "You can't attach a setter to a generic function or a method \
                 using getter-with-setter.  Instead, you can define a setter \
                 method using the name (setter %S)."
                (SCM_PROCEDURE_INFO proc))]
    [else (Scm_Error "You can't attach a setter to %S." (SCM_OBJ proc))])
  (let* ([p (Scm_CopyProcedure proc)])
    ;; NB: We override p->locked, for p is a copy.
    (set! (SCM_PROCEDURE_SETTER_LOCKED p) FALSE)
    (return (Scm_SetterSet (SCM_PROCEDURE p) set TRUE))))

(define-cproc setter (proc) ;SRFI-17
  (inliner SETTER)
  (setter (proc::<procedure> setter::<procedure>) ::<void>
          (Scm_SetterSet proc setter FALSE))
  Scm_Setter)

;;;
;;;  srfi-111 & srfi-195 box
;;;

;; We use them in equal? implementation as well, so here we go...
(define-cproc box (:optarray (argv argc 1) :rest rest)
  (cond
   [(== argc 0) (return (SCM_OBJ (Scm_MakeMVBox 0 SCM_FALSE)))]
   [(SCM_NULLP rest) (return (SCM_OBJ (Scm_MakeBox (aref argv 0))))]
   [else (return (SCM_OBJ (Scm_ListToMVBox (Scm_Cons (aref argv 0) rest))))]))

(define-cproc box? (v) ::<boolean> (return (or (SCM_BOXP v) (SCM_MVBOXP v))))

(define-cproc unbox (b)
  (cond
   [(SCM_BOXP b) (return (SCM_BOX_VALUE b))]
   [(SCM_MVBOXP b) (return (Scm_ValuesFromArray (SCM_MVBOX_VALUES b)
                                                (SCM_MVBOX_SIZE b)))]
   [else (SCM_TYPE_ERROR b "<box> or <mv-box>") (return SCM_UNDEFINED)]))

(define-cproc set-box! (b :rest vs) ::<void>
  (cond
   [(SCM_BOXP b) 
    (unless (and (SCM_PAIRP vs) (SCM_NULLP (SCM_CDR vs)))
      (Scm_Error "Wrong number of values to set to a single-value box %S: %S"
                 b vs))
    (SCM_BOX_SET b (SCM_CAR vs))]
   [(SCM_MVBOXP b)
    (let* ([argc::ScmSmallInt (Scm_Length vs)]
           [i::ScmSmallInt 0])
      (unless (== argc (SCM_MVBOX_SIZE b))
        (Scm_Error "Wrong number of values to set to a multi-value box %S: %S"
                   b vs))
      (for (() (< i argc) (begin (post++ i) (set! vs (SCM_CDR vs))))
        (set! (aref (SCM_MVBOX_VALUES b) i) (SCM_CAR vs))))]
   [else (SCM_TYPE_ERROR b "<box> or <mv-box>")]))

(define-cproc box-arity (b) ::<int>
  (cond
   [(SCM_BOXP b) (return 1)]
   [(SCM_MVBOXP b) (return (SCM_MVBOX_SIZE b))]
   [else (SCM_TYPE_ERROR b "<box> or <mv-box>")]))

(define-cproc unbox-value (b i::<fixnum>)
  (cond
   [(SCM_BOXP b) 
    (unless (== i 0) (Scm_Error "index out of range for %S: %d" b i))
    (return (SCM_BOX_VALUE b))]
   [(SCM_MVBOXP b)
    (unless (and (<= 0 i)
                 (< i (SCM_MVBOX_SIZE b)))
      (Scm_Error "index out of range for %S: %d" b i))
    (return (aref (SCM_MVBOX_VALUES b) i))]
   [else (SCM_TYPE_ERROR b "<box> or <mv-box>")]))

(define-cproc set-box-value! (b i::<fixnum> val) ::<void>
  (cond
   [(SCM_BOXP b) 
    (unless (== i 0) (Scm_Error "index out of range for %S: %d" b i))
    (SCM_BOX_SET b val)]
   [(SCM_MVBOXP b)
    (unless (and (<= 0 i)
                 (< i (SCM_MVBOX_SIZE b)))
      (Scm_Error "index out of range for %S: %d" b i))
    (set! (aref (SCM_MVBOX_VALUES b) i) val)]
   [else (SCM_TYPE_ERROR b "<box> or <mv-box>")]))

;;;
;;;  case-lambda support
;;;

(select-module gauche.internal)
(inline-stub
 ;; Support procedure for case-lambda
 ;; Dispatch-vector maps # of required arguments to the procedure body.
 ;; The last entry of dispatch vector is to cover more arguments; it should
 ;; be #f if no cases take arbitrary number of arguments.
 ;; Examples:
 ;;  (case-lambda [() a] [(x) (b)] [(x y) c] [(x y . z) d])
 ;;  =>
 ;;  #( (lambda () a)              min-reqargs == 0
 ;;     (lambda (x) b)
 ;;     (lambda (x y) c)
 ;;     (lambda (x y . z) d) )
 ;;
 ;;  (case-lambda [() a] [(x) (b)] [(x y) c])
 ;;  =>
 ;;  #( (lambda () a)              min-reqargs == 0
 ;;     (lambda (x) b)
 ;;     (lambda (x y) c)
 ;;     #f )
 ;;
 ;;  (case-lambda [(x y) a] [(x y z) b] [(x y z . w) c]
 ;;  =>
 ;;  #( (lambda (x y) a)           min-reqargs == 2
 ;;     (lambda (x y z) b)
 ;;     (lambda (x y z . w) c))
 ;;
 ;;  (case-lambda [(x y) a] [(x . y) b]
 ;;  =>
 ;;  #( (lambda (x . y) c)         min-reqargs == 1
 ;;     (lambda (x y) a)
 ;;     (lambda (x . y) c))
 ;;
 ;; In the last example, 2 argument case matches the first procedure,
 ;; for it has precedence.

 "typedef struct case_lambda_packet_rec {
    ScmVector *dispatch_vector;
    int max_optargs;
    int min_reqargs;
 } case_lambda_packet;"

 (define-cfn case-lambda-dispatch (args::ScmObj* nargs::int data::void*):static
   (let* ([d::case_lambda_packet* (cast case_lambda_packet* data)]
          [rarg (aref args (- nargs 1))])
     (SCM_ASSERT (> nargs (-> d min_reqargs)))
     (SCM_ASSERT (<= nargs (+ (-> d min_reqargs) (-> d max_optargs) 1)))
     ;; NB: Since this is variable-arg subr, rarg is always a list.
     ;; If nargs <= d->max_optargs + d->min_reqargs, rargs should always
     ;; be '().  See vmcall.c for how the arguments are folded.
     (let* ([p (SCM_VECTOR_ELEMENT (-> d dispatch_vector)
                                   (- nargs (-> d min_reqargs) 1))])
       (when (SCM_FALSEP p)
         (Scm_Error "wrong number of arguments to case lambda: %S"
                    (Scm_ArrayToListWithTail args (- nargs 1)
                                             (aref args (- nargs 1)))))
       (if (SCM_NULLP rarg)
         (case (- nargs 1)
           [(0) (return (Scm_VMApply0 p))]
           [(1) (return (Scm_VMApply1 p (aref args 0)))]
           [(2) (return (Scm_VMApply2 p (aref args 0) (aref args 1)))]
           [(3) (return (Scm_VMApply3 p (aref args 0) (aref args 1)
                                      (aref args 2)))]
           [(4) (return (Scm_VMApply4 p (aref args 0) (aref args 1)
                                      (aref args 2) (aref args 3)))]
           [else (return (Scm_VMApply p (Scm_ArrayToList args (- nargs 1))))])
         (return
          (Scm_VMApply p (Scm_ArrayToListWithTail args (- nargs 1) rarg))))
       )))

 ;; NB: We keep dispatch-vector in the procedure info, so that disasm
 ;; and other inspection routines can find it.  The structure of
 ;; the procedure info here is tentative; it may be changed later.
 ;; Routines that depends on this info must be aware of that.
 (define-cproc make-case-lambda-dispatcher (dispatch-vector::<vector>
                                            min-reqargs::<int>
                                            name)
   (let* ([max-optargs::int (SCM_VECTOR_SIZE dispatch-vector)]
          [packet::case_lambda_packet* (SCM_NEW case_lambda_packet)])
     (set! (-> packet min_reqargs) min-reqargs
           (-> packet max_optargs) max-optargs
           (-> packet dispatch_vector) dispatch-vector)
     (return (Scm_MakeSubr case_lambda_dispatch packet
                           min_reqargs max_optargs
                           (SCM_LIST3 (?: (SCM_FALSEP name)
                                         'case-lambda-dispatcher
                                         name)
                                      (SCM_MAKE_INT min-reqargs)
                                      (SCM_OBJ dispatch-vector))))))
 )

;; The compiler expands case-lambda to a call of make-case-lambda.
;; It may be called during initialization, so we need it here.
(define-in-module gauche.internal (make-case-lambda minarg maxarg
                                                    formals closures
                                                    :optional (name #f))
  (define (fill-dispatch-vector! v formals closure)
    (define (%set n)
      (let1 i (- n minarg)
        (unless (vector-ref v i) (vector-set! v i closure))))
    (let loop ([formals formals] [n 0])
      (cond [(> n (+ maxarg 1))]
            [(null? formals) (%set n)]
            [(pair? formals) (loop (cdr formals) (+ n 1))]
            [else (%set n) (loop formals (+ n 1))])))

  (let1 v (make-vector (+ (- maxarg minarg) 2) #f)
    ;; Avoid using for-each, since the definition of for-each itself
    ;; nees to call make-case-lambda.
    (let loop ([fs formals] [cs closures])
      (unless (null? fs)
        (fill-dispatch-vector! v (car fs) (car cs))
        (loop (cdr fs) (cdr cs))))
    ((with-module gauche.internal make-case-lambda-dispatcher) v minarg name)))

;; Returns ((<required args> <optional arg> <procedure>) ...)
;; This also depends on the structure of dispatch vector info.
;; Programs that needs to deal with case-lambda should use this procedure
;; instead of directly interpret dispatch vector info.
(define-in-module gauche (case-lambda-info proc)
  (and (subr? proc)
       (let1 info (procedure-info proc)
         (and (pair? info)
              (pair? (cdr info))
              (integer? (cadr info))
              (pair? (cddr info))
              (vector? (caddr info))
              (let* ([min-args (cadr info)]
                     [dispatch-vec (caddr info)]
                     [len (vector-length dispatch-vec)])
                (let loop ([r '()] [i 0])
                  (if (= i (- len 1))
                    (if-let1 optproc (vector-ref dispatch-vec i)
                      (reverse r `((,(+ min-args i -1) #t ,optproc)))
                      (reverse r))
                    (if-let1 proc (vector-ref dispatch-vec i)
                      (loop (cons `(,(+ min-args i) #f ,proc) r) (+ i 1))
                      (loop r (+ i 1))))))))))

;;;
;;; This is needed before we use define-macro.
;;;

(with-module gauche.internal)
;; proc :: Sexpr, Cenv -> Sexpr
(define-cproc %make-macro-transformer (name transformer
                                       :optional (src #f) (describer #f))
  Scm_MakeMacro)
