;;;
;;; genstub - simple stub generator for Gauche
;;;  
;;;   Copyright (c) 2000-2003 Shiro Kawai, All rights reserved.
;;;   
;;;   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.
;;;  
;;;  $Id: genstub,v 1.96 2003/12/05 03:01:16 shirok Exp $
;;;

(use srfi-1)
(use srfi-2)
(use srfi-13)
(use gauche.let-opt)
(use gauche.parseopt)
(use gauche.parameter)
(use gauche.mop.instance-pool)
(use text.tr)

(define *file-prefix* "")
(define *insert-sharp-line* #t)         ;if #t, output #line directive
(define *unbound* (cons #f #f))         ;placeholder for unbound value

(define cpp-condition (make-parameter #f))

(define (f fmt . args) (apply format #t fmt args) (newline))

;; Summary of forms
;;
;;   define-type name c-type [desc c-predicate unboxer boxer]
;;
;;      Register a new type to be recognized.  This is rather a declaration
;;      than definition; no C code will be generated directly by this form.
;;
;;   define-cproc name (args ...) body ...
;;
;;      Create a subr function.  Body can be:
;;        a string : becomes the body of C code.
;;        (return [<rettype>] <C-function>) :
;;             calls C-function.  If <rettype> is omitted, C-function
;;             is assumed to return ScmObj.  Otherwise, a boxer of
;;             <rettype> is used.  As a special case, if <rettype> is
;;             <void>, the return value of C-function is ignored and
;;             the function returns #<undef>.
;;        (setter <setter-name>) : specfy setter.  <setter-name> should
;;             be a cproc name defined in the same stub file
;;        (setter (args ...) body ...) : specify setter anonymously.
;;
;;   define-cgeneric name c-name property-clause ...)
;;
;;      Defines generic function.   C-name specifies a C variable name
;;      that keeps the generic function structure.  One or more of
;;      the following clauses can appear in property-clause ...:
;;        (extern) : makes c-name visible from other file (i.e. do
;;             not define the structure as 'static').
;;        (fallback "fallback") : specifies the fallback function.
;;        (setter . setter-spec) : specifies the setter.
;;
;;   define-cmethod name (arg ...) body ...
;;
;;   define-cclass scheme-name [qualifier] c-typename c-class-name cpa
;;      (slot-spec ...)
;;      property-clause ...
;;
;;   define-symbol scheme-name [c-name]
;;      Defines a Scheme symbol.  No Scheme binding is created.
;;      When c-name is given, the named C variable points to the
;;      created ScmSymbol.
;;
;;   define-variable scheme-name initializer
;;      Defines a Scheme variable.
;;
;;   define-constant scheme-name initializer
;;      Defines a Scheme constant.
;;
;;   define-enum name
;;      A define-constant Specialized for enum values.
;;
;;   initcode <c-code>
;;      Insert <c-code> literally in the initialization function
;;

;;===================================================================
;; Form parsers
;;

;; just a device to register handlers of syntax elements.
(define-class <form-parser> (<instance-pool-mixin>)
  ((name    :init-keyword :name    :getter name-of)
   (args    :init-keyword :args    :getter args-of)
   (handler :init-keyword :handler :getter handler-of)))

(define-macro (define-form-parser name args . body)
  `(make <form-parser>
     :name ',name
     :args ',args
     :handler (lambda ,args ,@body)))

(define-method invoke ((self <form-parser>) form)
  (define (badform)
    (errorf "malformed ~a: ~s" (name-of self) form))
  (let1 args
      ;; need to check if given form matches args
      (let loop ((llist (args-of self))
                 (form  (cdr form)))
        (cond ((null? llist)
               (if (null? form) '() (badform)))
              ((pair? llist)
               (if (null? form)
                   (badform)
                   (cons (car form) (loop (cdr llist) (cdr form)))))
              (else form)))
    (apply (handler-of self) args)))

(define (parse-form form)
  (cond ((string? form) (print form))
        ((not (pair? form))
         (error "bad form:" form))
        ((find (lambda (p) (eq? (car form) (name-of p)))
               (instance-pool->list <form-parser>))
         => (cut invoke <> form))
        (else (error "bad form:" form))))

;;===================================================================
;; Type handling
;;

;; Stub's type system doesn't exactly match Scheme's, since stub has
;; to handle internal guts of Scheme implementations as well as
;; C type systems.  We call the types used in the stub generator
;; "stub type", apart from "C type" and "Scheme type".
;;
;; For each existing conversion between C type and Scheme type, a stub
;; type is defined.  For types that has one-to-one mapping between
;; C and Scheme (such as most aggregate types, for example, Scheme's
;; <u32vector> and C's ScmU32Vector*), there is only one stub type,
;; which uses the same name as the Scheme's.  There are some stub types
;; that reflects C type variations: <int>, <int8>, <int16>, <int32>,
;; <uint>, <uint8>, <uint16>, <uint32> --- these are mapped to Scheme's
;; integer, but the range limit is taken into account.   <fixnum>
;; refers to the integers that can be represented in an immediate integer.
;; Note that a stub type <integer> corresponds to Scheme's exact integers,
;; but it is mapped to C's ScmObj, since C's integer isn't enough to
;; represent all of Scheme integers.   A stub type <void> is
;; used to denote a procedure return type.
;;
;; Each stub type has a "boxer" and an "unboxer".  A boxer is a C name
;; of a function or a macro that takes an object of C type of the stub
;; type and returns a Scheme object.  An unboxer is a C name of a function
;; or a macro that takes Scheme object and checks its vailidy, then
;; returns a C object of the C type or throws an error.
;;
;; Here's a summary of primitive stub types and the mapping each one
;; represents.
;;
;;   stub type    Scheme       C           Notes
;;  -----------------------------------------------------------------
;;   <fixnum>     <integer>    int         Integers within fixnum range
;;   <integer>    <integer>    ScmObj      Any exact integers
;;   <real>       <real>       double
;;   <number>     <number>     ScmObj      Any numbers
;;
;;   <int>        <integer>    int         Integers representable in C
;;   <int8>       <integer>    int
;;   <int16>      <integer>    int
;;   <int32>      <integer>    int
;;   <short>      <integer>    short
;;   <long>       <integer>    long
;;   <uint>       <integer>    uint        Integers representable in C
;;   <uint8>      <integer>    uint
;;   <uint16>     <integer>    uint
;;   <uint32>     <integer>    uint
;;   <ushort>     <integer>    ushort
;;   <ulong>      <integer>    ulong
;;   <float>      <real>       float       Unboxed value casted to float
;;   <double>     <real>       double      Alias of <real>
;;
;;   <boolean>    <boolean>    int         Boolean value
;;   <char>       <char>       ScmChar     NB: not a C char
;;
;;   <void>       -            void        (Used only as a return type.
;;                                          Scheme function returns #<undef>)
;;
;;   <pair>       <pair>       ScmPair*
;;   <list>       <list>       ScmObj
;;   <string>     <string>     ScmString*
;;   <symbol>     <symbol>     ScmSymbol*
;;   <vector>     <vector>     ScmVector*
;;    :
;;

;; Stub type definition
(define-class <type> (<instance-pool-mixin>)
  ((name        :init-keyword :name        :accessor name-of)
   ;; ::<symbol> - name of this stub type.
   (c-type      :init-keyword :c-type      :accessor c-type-of)
   ;; ::<string> - C type name this stub type represents
   (description :init-keyword :description :accessor description-of)
   ;; ::<string> - used in the type error message
   (c-predicate :init-keyword :c-predicate :accessor c-predicate-of)
   ;; ::<string> - name of a C function (macro) to find out the given
   ;;              ScmObj has a valid type for this stub type.
   (unboxer     :init-keyword :unboxer     :accessor unboxer-of)
   ;; ::<string> - name of a C function (macro) that takes Scheme object
   ;;              and returns a C object.
   (boxer       :init-keyword :boxer       :accessor boxer-of
                :init-value "SCM_OBJ_SAFE")
   ;; ::<string> - name of a C function (macro) that takes C object
   ;;              and returns a Scheme Object.
   ))

(define (find-type-by-name name)
  ;; trick for transition - will be removed later
  (define (canon-type-name type-name)
    (let1 n (x->string type-name)
      (if (string-prefix? "<" n)
          (string->symbol (string-trim-both n #[<>]))
          (begin (warn "old-style type name used: ~s" type-name)
                 type-name))))
  (let1 cname (canon-type-name name)
    (find (lambda (type) (eq? (canon-type-name (name-of type)) cname))
          (instance-pool->list <type>))))

(define (name->type name)
  (or (find-type-by-name name) (error "unknown type" name)))

;; define-type name c-type [desc c-predicate unboxer boxer]
;;
;;   Creates a new stub type for existing scheme type.

(define-form-parser define-type args
  (define (strip<> name) (string-trim-both name #[<>]))
  (define (default-cpred name)
    (if (string-index name #\-)
        (string-append "SCM_"
                       (string-tr (strip<> name) "a-z-" "A-Z_")
                       "_P")
        #`"SCM_,(string-upcase (strip<> name))P"))
  (define (default-unbox name)
    #`"SCM_,(string-tr (strip<> name) \"a-z-\" \"A-Z_\")")
  (define (default-box name)
    #`"SCM_MAKE_,(string-tr (strip<> name) \"a-z-\" \"A-Z_\")")

  (if (string? (car args))
      ;; comatibility
      (receive (desc assert c-type c-pred unboxer . maybe-boxer)
          (apply values args)
        (warn "using obsolete define-type form (~s)" desc)
        (parse-form
         `(define-type
            ,(string->symbol #`"<,(string-drop-right (symbol->string assert) 1)>")
            ,c-type
            ,desc
            ,c-pred
            ,unboxer
            ,@maybe-boxer)))
      (begin
        (unless (<= 2 (length args) 6)
          (error "malformed define-type:" args))
        (let ((name   (list-ref args 0))
              (c-type (list-ref args 1))
              (desc   (list-ref args 2 #f))
              (c-pred (list-ref args 3 #f))
              (unbox  (list-ref args 4 #f))
              (box    (list-ref args 5 #f)))
          (make <type>
            :name name :c-type c-type
            :description (or desc (x->string name))
            :c-predicate (or c-pred (default-cpred (x->string name)))
            :unboxer     (or unbox (default-unbox (x->string name)))
            :boxer       (or box "SCM_OBJ_SAFE"))))
      ))

;; Builtin types
(for-each
 parse-form
 '(;; Numeric types
   (define-type <fixnum>  "int" "small integer"
     "SCM_INTP" "SCM_INT_VALUE" "SCM_MAKE_INT")
   (define-type <integer> "ScmObj" "exact integer"
     "SCM_EXACTP" "")
   (define-type <real>    "double" "real number"
     "SCM_REALP" "Scm_GetDouble" "Scm_MakeFlonum")
   (define-type <number>  "ScmObj" "number"
     "SCM_NUMBERP" "")
   (define-type <int>     "int" "C integer"
     "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
   (define-type <long>    "long" "C long integer"
     "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
   (define-type <short>   "short" "C short integer"
     "SCM_INTP" "(short)SCM_INT_VALUE" "SCM_MAKE_INT")
   (define-type <int8>    "int" "C integer"
     "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
   (define-type <int16>   "int" "C integer"
     "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
   (define-type <int32>   "int" "C integer"
     "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
   (define-type <uint>    "u_int" "C integer"
     "SCM_UINTP" "Scm_GetUInteger" "Scm_MakeIntegerFromUI")
   (define-type <ulong>   "u_long" "C integer"
     "SCM_EXACTP" "Scm_GetUInteger" "Scm_MakeIntegerFromUI")
   (define-type <ushort>  "u_short" "C short integer"
     "SCM_EXACTP" "(unsigned short)Scm_GetUInteger" "Scm_MakeIntegerFromUI")
   (define-type <uint8>   "u_int" "C integer"
     "SCM_UINTP" "Scm_GetUInteger" "Scm_MakeIntegerFromUI")
   (define-type <uint16>  "u_int" "C integer"
     "SCM_UINTP" "Scm_GetUInteger" "Scm_MakeIntegerFromUI")
   (define-type <uint32>  "u_int" "C integer"
     "SCM_EXACTP" "Scm_GetUInteger" "Scm_MakeIntegerFromUI")
   (define-type <float>   "float" "real number"
     "SCM_REALP" "(float)Scm_GetDouble" "Scm_MakeFlonum")
   (define-type <double>  "double" "real number"
     "SCM_REALP" "Scm_GetDouble" "Scm_MakeFlonum")
   
   ;; Basic immediate types
   (define-type <boolean> "int" "boolean"
     "SCM_BOOLP"   "SCM_BOOL_VALUE" "SCM_MAKE_BOOL")
   (define-type <char>    "ScmChar" "character"
     "SCM_CHARP" "SCM_CHAR_VALUE" "SCM_MAKE_CHAR")
   (define-type <void>    "void" "void"
     ""      ""  "SCM_VOID_RETURN_VALUE")
   (define-type <top>     "ScmObj" "scheme object" "" "")

   ;; Aggregate types
   (define-type <pair> "ScmPair*" "pair"
     "SCM_PAIRP" "SCM_PAIR" "SCM_OBJ")
   (define-type <list> "ScmObj" "list"
     "SCM_LISTP" "")
   (define-type <vector> "ScmVector*" "vector"
     "SCM_VECTORP" "SCM_VECTOR")
   (define-type <string> "ScmString*" "string"
     "SCM_STRINGP" "SCM_STRING")
   (define-type <symbol> "ScmSymbol*" "symbol"
     "SCM_SYMBOLP" "SCM_SYMBOL")
   (define-type <keyword> "ScmKeyword*" "keyword"
     "SCM_KEYWORDP" "SCM_KEYWORD")
   (define-type <identifier> "ScmIdentifier*" "identifier"
     "SCM_IDENTIFIERP" "SCM_IDENTIFIER")
   (define-type <char-set> "ScmCharSet*" "char-set"
     "SCM_CHARSETP" "SCM_CHARSET")
   (define-type <regexp> "ScmRegexp*" "regexp"
     "SCM_REGEXPP" "SCM_REGEXP")
   (define-type <regmatch> "ScmRegMatch*" "regmatch"
     "SCM_REGMATCHP" "SCM_REGMATCH")
   (define-type <port> "ScmPort*" "port"
     "SCM_PORTP" "SCM_PORT")
   (define-type <input-port> "ScmPort*" "input port"
     "SCM_IPORTP" "SCM_PORT")
   (define-type <output-port> "ScmPort*" "output port"
     "SCM_OPORTP" "SCM_PORT")
   (define-type <procedure> "ScmProcedure*" "procedure"
     "SCM_PROCEDUREP" "SCM_PROCEDURE")
   (define-type <closure> "ScmClosure*" "closure"
     "SCM_CLOSUREP" "SCM_CLOSURE")
   (define-type <hash-table> "ScmHashTable*" "hash table"
     "SCM_HASHTABLEP" "SCM_HASHTABLE")
   (define-type <class> "ScmClass*" "class"
     "SCM_CLASSP" "SCM_CLASS")
   (define-type <method> "ScmMethod*" "method"
     "SCM_METHODP" "SCM_METHOD")
   (define-type <module> "ScmModule*" "module"
     "SCM_MODULEP" "SCM_MODULE")
   (define-type <thread> "ScmVM*" "thread"
     "SCM_VMP" "SCM_VM")
   (define-type <mutex> "ScmMutex*" "mutex"
     "SCM_MUTEXP" "SCM_MUTEX")
   (define-type <condition-variable> "ScmConditionVariable*"
     "condition variable" "SCM_CONDITION_VARIABLE_P" "SCM_CONDITION_VARIABLE")
   (define-type <weak-vector> "ScmWeakVector*" "weak vector"
     "SCM_WEAKVECTORP" "SCM_WEAKVECTOR")
   ))

;; default
(define *scm-type* (name->type '<top>))

;; DEPRECATED: for backward compatibility
(define-method predicate-of ((self <type>))
  (string->symbol #`",(string-trim-both (x->string (name-of self)) #[<>])?"))

;; DEPRECATED: for backward compatibility
(define (predicate->type pred)
  (or (find (lambda (type) (eq? (predicate-of type) pred))
            (instance-pool->list <type>))
      (error "unknown predicate to assert" pred)))

;;===================================================================
;; Stub : base class of declarations
;;
;;   - Each declaration makes a stub.
;;   - Stub is used to generate two things: immediate definition,
;;     and initialization code called in Scm_Init_<module>.
;;     Those should be implemented by the following methods:
;;        emit-definition
;;        emit-initializer

(define-class <stub> (<instance-pool-mixin>)
  ((scheme-name     :init-keyword :scheme-name :accessor scheme-name-of)
   (c-name          :init-keyword :c-name      :accessor c-name-of)
   (cpp-condition   :init-keyword :cpp-condition :initform #f
                    :accessor cpp-condition-of)
   ))

(define-method initialize ((self <stub>) initargs)
  (next-method)
  (set! (cpp-condition-of self) (cpp-condition)))

(define (get-stubs class)
  (reverse (filter (lambda (s) (is-a? s class))
                   (instance-pool->list <stub>))))

(define-syntax with-cpp-condition
  (syntax-rules ()
    ((_ stub . body)
     (let ((cpp (cpp-condition-of stub)))
       (when cpp (f "#if ~a" cpp))
       (begin . body)
       (when cpp (f "#endif /*~a*/" cpp))
       ))))

;;===================================================================
;; Literals
;;

;; Literal is used to embed Scheme value in C file.
;; Class <literal> is subclassed to each Scheme object types.
;; Besides the standard stub protocol, a subclass has to define
;; value-getter-of that returns a C expression ot retrieve the
;; Scheme value.

(define-class <literal> (<instance-pool-mixin>)
  ((value        :init-keyword :value :accessor value-of)
   ;; - the Scheme value
   (c-name       :init-keyword :c-name :accessor c-name-of)
   ;; - C variable name used to keep the literal; the actual use
   ;;   of this depends on the subclass.
   (next-serial  :allocation :class :init-value 0)
   ;; - counter of literals; can be used to generate unique C variable name.
   ))

(define-method initialize ((self <literal>) initargs)
  (next-method)
  (unless (slot-bound? self 'c-name)
    (set! (c-name-of self)
          #`"genstub__literal_,(slot-ref self 'next-serial)"))
  (inc! (slot-ref self 'next-serial)))

(define-method make-literal (obj . opts)       ;falback
  (errorf "can't use Scheme object ~s as a literal value" obj))
(define-method emit-definition ((obj <literal>)) #f) ;fallback
(define-method emit-initializer ((obj <literal>)) #f);fallback
(define-method value-getter-of ((obj <literal>))
  ;; this is the most common way
  #`"SCM_OBJ(,(c-name-of obj))")
(define-macro (define-literal-binding class literal-class)
  `(define-method make-literal ((obj ,class) . opts)
     (apply make ,literal-class :value obj opts)))

;; integer literals
(define-literal-binding <integer>
  (if (fixnum? obj) <fixnum-literal> <bignum-literal>))
(define-class <fixnum-literal> (<literal>) ())
(define-method value-getter-of ((self <fixnum-literal>))
  #`"SCM_MAKE_INT(,(value-of self))")
(define-class <bignum-literal> (<literal>) ())
(define-method emit-definition ((self <bignum-literal>))
  (f #`"static ScmObj ,(c-name-of self) = SCM_UNBOUND;"))
(define-method emit-initializer ((self <bignum-literal>))
  (f "  ~a = ~a(~a)"
     (c-name-of a)
     (if (positive? (value-of a)) "Scm_MakeIntegerFromUI" "Scm_MakeInteger")
     (value-of a)))

;; boolean literals
(define-literal-binding <boolean> <boolean-literal>)
(define-class <boolean-literal> (<literal>) ())
(define-method value-getter-of ((self <boolean-literal>))
  (if (value-of self) "SCM_TRUE" "SCM_FALSE"))

;; string literals
(define-literal-binding <string> <string-literal>)
(define-class <string-literal> (<literal>) ())
(define-method emit-definition ((self <string-literal>))
  (emit-static-string (c-name-of self) (value-of self)))
(define-method value-getter-of ((self <string-literal>))
  #`"SCM_OBJ(&,(c-name-of self)__NAME)")

;; symbol literals
(define-literal-binding <symbol> <symbol-literal>)
(define-class <symbol-literal> (<literal>) ())
(define-method emit-definition ((self <symbol-literal>))
  (emit-static-string (c-name-of self) (value-of self))
  (f "static ScmObj ~a = SCM_UNBOUND;" (c-name-of self)))
(define-method emit-initializer ((self <symbol-literal>))
  (f "  ~a = Scm_Intern(&~:*~a__NAME);" (c-name-of self)))

;; keyword literals
(define-literal-binding <keyword> <keyword-literal>)
(define-class <keyword-literal> (<literal>) ())
(define-method emit-definition ((self <keyword-literal>))
  (emit-static-string (c-name-of self)
                      (write-to-string (value-of self) display))
  (f "static ScmObj ~a = SCM_UNBOUND;" (c-name-of self)))
(define-method emit-initializer ((self <keyword-literal>))
  (f "  ~a = Scm_MakeKeyword(&~:*~a__NAME);" (c-name-of self)))

;; some special literals
;;  (c "...")              - embedding C code
;;  (current-...-port)     - current ports (these are not literal, but
;;                           can be used as the default value of optional
;;                           and keyword arguments).
(define-literal-binding <list> <special-literal>)
(define-class <special-literal> (<literal>) ())
(define-method initialize ((self <special-literal>) initargs)
  (define (badval)
    (errorf "bad initializer ~s" (value-of self)))
  (next-method)
  (receive (sig val) (car+cdr (value-of self))
    (case sig
      ((c)
       (set! (c-name-of self) (car val)))
      ((current-input-port)
       (set! (c-name-of self) "SCM_CURIN"))
      ((current-output-port)
       (set! (c-name-of self) "SCM_CUROUT"))
      ((current-error-port)
       (set! (c-name-of self) "SCM_CURERR"))
      (else (badval)))))

;;===================================================================
;; Arg
;;

;; <arg> is used to keep procedure's argument information.
(define-class <arg> ()
  ((name     :init-keyword :name :accessor name-of)
   ;; - <symbol>: the name as appears in the Scheme argument list.
   (c-name   :accessor c-name-of)
   ;; - <string>: C variable name for unboxed value
   (scm-name :accessor scm-name-of)
   ;; - <string>: C variable name to hold boxed ScmObj value
   (count    :init-keyword :count :accessor count-of)
   ;; - <integer>: This arg is count-th in the procedure
   (type     :init-keyword :type :accessor  type-of)
   ;; - <type>: Stub type of this arg
   (default  :init-keyword :default :initform *unbound* :accessor default-of)
   ))

(define-class <required-arg> (<arg>) ())
(define-class <optional-arg> (<arg>) ())
(define-class <keyword-arg>  (<arg>)
  ((c-keyword :initform #f :accessor c-keyword-of)
   ))
(define-class <rest-arg> (<arg>) ())

(define-method write-object ((self <arg>) out)
  (format out "#<~a ~a>" (class-of self) (name-of self)))

(define-method initialize ((self <arg>) initargs)
  (next-method)
  (set! (c-name-of self) (get-c-name "" (name-of self)))
  (set! (scm-name-of self) (string-append (c-name-of self) "_scm")))

;;===================================================================
;; Symbol and keyword definition
;;

;;-------------------------------------------------------------------
;; (define-symbol scheme-name c-name)

(define-class <csymbol> (<stub>)
  ((symbol     :init-keyword :symbol :accessor symbol-of)
   ))
  
(define-method emit-definition ((self <csymbol>))
  (emit-definition (symbol-of self)))

(define-method emit-initializer ((self <csymbol>))
  (emit-initializer (symbol-of self)))

(define-form-parser define-symbol (name c-name . maybe-init)
  (check-arg symbol? name)
  (check-arg string? c-name)
  (unless (null? maybe-init)
    (warn "using initializer value in define-symbol is deprecated.  use define-variable instead.")
    (parse-form `(define-variable ,name ,@maybe-init)))
  (let* ((literal (make-literal name :c-name c-name))
         (symbol  (make <csymbol> :symbol literal)))
    (with-cpp-condition symbol (emit-definition symbol))
    ))

;;-------------------------------------------------------------------
;; (define-variable scheme-name init &keyword c-name)
;; (define-constant scheme-name init &keyword c-name)

(define-class <cvariable> (<stub>)
  ((constant?      :init-keyword :constant? :accessor constant?)
   (symbol         :init-keyword :symbol :accessor symbol-of)
   ;; - <literal> : symbol object
   (initializer    :init-keyword :initializer :accessor initializer-of)
   ;; - <literal> : constant value to be initialized
   ))

(define-method emit-initializer ((self <cvariable>))
  (emit-initializer (symbol-of self))
  (emit-initializer (initializer-of self))
  (f "  ~a(module, SCM_SYMBOL(~a), ~a);"
     (if (constant? self) "Scm_DefineConst" "Scm_Define")
     (value-getter-of (symbol-of self))
     (value-getter-of (initializer-of self))))

(define-method emit-definition ((self <cvariable>))
  (emit-definition (symbol-of self))
  (emit-definition (initializer-of self)))

(define (variable-parser-common const? name init opts)
  (let* ((c-name (get-keyword :c-name opts #`",(get-c-name *file-prefix* name)__VAR"))
         (symbol (make <cvariable>
                   :constant? const?
                   :symbol (make-literal name :c-name c-name)
                   :initializer (make-literal init))))
    (with-cpp-condition symbol (emit-definition symbol))))

(define-form-parser define-variable (name init . opts)
  (check-arg symbol? name)
  (variable-parser-common #f name init opts))

(define-form-parser define-constant (name init . opts)
  (check-arg symbol? name)
  ;; hack to detect obsoleted syntax
  (if (and (pair? opts) (null? (cdr opts)) (string? init))
      (errorf "(define-constant ~a ...) : using obsoleted syntax" name)
      (variable-parser-common #t name init opts)))

;;-------------------------------------------------------------------
;; (define-enum name) - a special case of define-constant

(define-class <cenum> (<cvariable>)
  ())

(define-form-parser define-enum (name)
  (check-arg symbol? name)
  (variable-parser-common #t name (list 'c #`"Scm_MakeInteger(,name)") '()))

;;-------------------------------------------------------------------
;; (define-keyword scheme-name c-name)

(define-class <ckeyword> (<stub>)
  ((keyword :init-keyword :keyword :accessor keyword-of)
   ;; - <literal> : literal keyword
   ))

(define-method emit-definition ((self <ckeyword>))
  (emit-definition (keyword-of self)))

(define-method emit-initializer ((self <ckeyword>))
  (emit-initializer (keyword-of self)))

(define (get-static-keyword name c-name)
  (or (find (lambda (k)
              (equal? (x->string name)
                      (x->string (value-of (keyword-of k)))))
            (get-stubs <ckeyword>))
      (let* ((literal (make-literal (make-keyword name) :c-name c-name))
             (keyword (make <ckeyword> :keyword literal)))
        (with-cpp-condition keyword (emit-definition keyword))
        keyword)))

(define-form-parser define-keyword (name c-name)
  (check-arg symbol? name)
  (check-arg string? c-name)
  (get-static-keyword name c-name))

;;===================================================================
;; Procedure
;;

;; Common stuff for cproc and cmethod

(define-class <setter-mixin> ()
  ((setter          :initform #f  :accessor setter-of)
   (setter-c-name   :initform #f  :accessor setter-c-name-of)
   ))

(define-class <procstub> (<setter-mixin> <stub>)
  ((args            :initform '() :accessor args-of :init-keyword :args)
   (num-reqargs     :initform 0   :accessor num-reqargs-of :init-keyword :num-reqargs)
   (have-rest-arg?  :initform #f  :accessor have-rest-arg? :init-keyword :have-rest-arg?)
   (decls           :initform '() :accessor decls-of)
   (stmts           :initform '() :accessor stmts-of)
   ))

(define (get-arg cproc arg)
  (find (lambda (x) (eq? arg (name-of x))) (args-of cproc)))

(define (push-stmt! cproc stmt)
  (push! (stmts-of cproc) stmt))

(define (process-assert cproc form)
  (let* ((op  (car form))
         (arg (get-arg cproc (cadr form))))
    (warn "~s: assert form obsoleted: use the new argument type annotation"
          (pair-attribute-get form 'source-info))
    (unless arg (error "assertion for unknown arg:" form))
    (set! (type-of arg) (predicate->type op))))

;;-----------------------------------------------------------------
;; (define-cproc scheme-name (argspec) body)
;;

(define-class <cproc> (<procstub>)
  ((num-optargs     :initform 0   :accessor num-optargs-of
                    :init-keyword :num-optargs)
   (keyword-args    :initform '() :accessor keyword-args-of)
   (inliner         :initform #f  :accessor inliner-of)
   (inline-insn     :initform #f  :accessor inline-insn-of)
   ))

(define-form-parser define-cproc (scheme-name argspec . body)
  (check-arg symbol? scheme-name)
  (check-arg list? argspec)
  (receive (args nreqs nopts rest?)
      (process-cproc-args argspec)
    (let ((cproc (make <cproc>
                   :scheme-name scheme-name
                   :c-name (get-c-name *file-prefix* scheme-name)
                   :args args
                   :num-reqargs nreqs
                   :num-optargs nopts
                   :have-rest-arg? rest?)))
      (set! (keyword-args-of cproc)
            (filter (lambda (x) (eq? (class-of x) <keyword-arg>)) args))
      (process-body cproc body)
      (with-cpp-condition cproc
        (emit-definition cproc)
        (emit-inliner cproc)
        (emit-record cproc)))))

;; create arg object.  used in cproc and cmethod
(define (make-arg class argname count . rest)
  (define (grok-argname argname)
    (let1 namestr (symbol->string argname)
      (receive (realname typename) (string-scan namestr "::" 'both)
        (if realname
            (values (string->symbol realname)
                    (name->type (string->symbol typename)))
            (values argname *scm-type*)))))
  (receive (arg type) (grok-argname argname)
    (apply make class :name arg :type type :count count rest)))

;; returns a list of args, # of reqargs,  # of optargs, and have-rest-arg?
(define (process-cproc-args argspecs)
  (define (badarg arg) (error "bad argument in argspec:" arg))

  (define (required specs args nreqs)
    (cond ((null? specs) (values (reverse args) nreqs 0 #f))
          ((eq? (car specs) '&optional) (optional (cdr specs) args nreqs 0))
          ((eq? (car specs) '&rest)     (rest (cdr specs) args nreqs 0))
          ((eq? (car specs) '&keyword)  (keyword (cdr specs) args nreqs 0))
          ((symbol? (car specs))
           (required (cdr specs)
                     (cons (make-arg <required-arg> (car specs) nreqs) args)
                     (+ nreqs 1)))
          (else (badarg (car specs)))))

  (define (optional specs args nreqs nopts)
    (cond ((null? specs) (values (reverse args) nreqs nopts #f))
          ((eq? (car specs) '&optional) (error "extra &optional parameter"))
          ((eq? (car specs) '&keyword)
           (error "&keyword and &optional can't be used together"))
          ((eq? (car specs) '&rest)  (rest (cdr specs) args nreqs nopts))
          ((symbol? (car specs))
           (optional (cdr specs)
                     (cons (make-arg <optional-arg>
                                     (car specs) (+ nreqs nopts))
                           args)
                     nreqs
                     (+ nopts 1)))
          ((and (list? (car specs)) (= (length (car specs)) 2))
           (optional (cdr specs)
                     (cons (make-arg <optional-arg>
                                     (caar specs) (+ nreqs nopts)
                                     :default (cadar specs))
                           args)
                     nreqs
                     (+ nopts 1)))
          (else (badarg (car specs)))))

  (define (keyword specs args nreqs nopts)
    (cond ((null? specs) (values (reverse args) nreqs nopts #f))
          ((eq? (car specs) '&keyword) (error "extra &keyword parameter"))
          ((eq? (car specs) '&optional)
           (error "&keyword and &optional can't be used together"))
          ((eq? (car specs) '&rest) (rest (cdr specs) args nreqs nopts))
          ((symbol? (car specs))
           (keyword (cdr specs)
                    (cons (make-arg <keyword-arg>
                                    (car specs) (+ nreqs nopts))
                          args)
                    nreqs
                    (+ nopts 1)))
          ((and (list? (car specs)) (= (length (car specs)) 2))
           (keyword (cdr specs)
                    (cons (make-arg <keyword-arg>
                                    (caar specs) (+ nreqs nopts)
                                    :default (cadar specs))
                          args)
                    nreqs
                    (+ nopts 1)))
          (else (badarg (car specs)))))

  (define (rest specs args nreqs nopts)
    (cond ((null? specs) (values (reverse args) nreqs nopts #f))
          ((and (null? (cdr specs)) (symbol? (car specs)))
           (values (reverse
                    (cons (make-arg <rest-arg> (car specs) (+ nreqs nopts))
                          args))
                   nreqs
                   (+ nopts 1)
                   #t))
          (else (badarg (car specs)))))

  (required argspecs '() 0)
  )

(define-method process-body ((cproc <cproc>) body)
  (let loop ((body body))
    (if (null? body)
        (set! (stmts-of cproc) (reverse (stmts-of cproc)))
        (receive (form next) (car+cdr body)
          (cond ((string? form) (push-stmt! cproc form) (loop next))
                ((not (pair? form)) (error "bad form in body:" form))
                ((eq? (car form) 'assert)
                 (process-assert cproc (cadr form))
                 (loop next))
                ((eq? (car form) 'inliner)
                 (unless (pair? (cdr form))
                   (error "bad `inliner' spec:" form))
                 (if (and (pair? (cadr form))
                          (eq? (caadr form) 'proc))
                     (if (not (string? (cadadr form)))
                         (error "inliner procedure name must be a string:"
                                form)
                         (set! (inliner-of cproc) (cadadr form)))
                     (set! (inline-insn-of cproc) (cadr form)))
                 (loop next))
                ((eq? (car form) 'setter)
                 (unless (pair? (cdr form))
                   (error "bad 'setter' spec:" form))
                 (process-setter cproc (cdr form))
                 (loop next))
                ((eq? (car form) 'return)
                 (process-return-spec cproc form)
                 (loop next))
                (else
                 (error "unknown body form:" form)))))))

(define-method process-setter ((cproc <cproc>) decl)
  (cond
   ((symbol? (car decl))
    (set! (setter-of cproc) (car decl))
    (set! (setter-c-name-of cproc) (get-c-name *file-prefix* (car decl))))
   ((< (length decl) 2)
    (error "bad form of anonymous setter:" `(setter ,decl)))
   (else
    (receive (args nreqs nopts rest?)
        (process-cproc-args (car decl))
      (let ((setter (make <cproc>
                      :scheme-name `(setter ,(scheme-name-of cproc))
                      :c-name (string-append (c-name-of cproc) "_SETTER")
                      :args args
                      :num-reqargs nreqs
                      :num-optargs nopts
                      :have-rest-arg? rest?)))
        (set! (setter-of cproc) setter)
        (set! (setter-c-name-of cproc) (c-name-of setter))
        (set! (keyword-args-of setter)
              (filter (lambda (x) (eq? (class-of x) <keyword-arg>)) args))
        (process-body setter (cdr decl))
        (with-cpp-condition cproc
          (emit-definition setter)
          (emit-inliner setter)
          (emit-record setter))))
    )))

(define-method process-return-spec ((cproc <cproc>) form)
  (define (err) (error "malformed return spec" form))
  (define (args)
    (string-join (map c-name-of (args-of cproc)) ", "))
  (case (length (cdr form))
    ((1)
     (unless (string? (cadr form)) (err))
     (push-stmt! cproc #`"SCM_RETURN(,(cadr form)(,(args)));"))
    ((2)
     (unless (and (symbol? (cadr form)) (string? (caddr form))) (err))
     (if (memq (cadr form) '(void <void>)) ;trick for transition
         (push-stmt! cproc #`",(caddr form)(,(args)); SCM_RETURN(SCM_UNDEFINED);")
         (push-stmt! cproc #`"SCM_RETURN(,(boxer-of (name->type (cadr form)))(,(caddr form)(,(args))));")))
    (else (err))))

;;; emit code

(define-method emit-definition ((cproc <cproc>))
  (for-each ensure-keyword-arg (keyword-args-of cproc))
  (f "static ScmObj ~a(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_)"
     (c-name-of cproc))
  (print "{")
  ;; argument decl
  (for-each emit-arg-decl (args-of cproc))
  (when (> (num-optargs-of cproc) 0)
    (print "  ScmObj SCM_OPTARGS = SCM_ARGREF(SCM_ARGCNT-1);"))
  (f "  SCM_ENTER_SUBR(\"~a\");" (scheme-name-of cproc))
  ;; argument count check (for optargs)
  (when (and (> (num-optargs-of cproc) 0)
             (null? (keyword-args-of cproc))
             (not (have-rest-arg? cproc)))
    (print #`"  if (Scm_Length(SCM_OPTARGS) > ,(num-optargs-of cproc))")
    (print #`"    Scm_Error(\"too many arguments: up to ,(num-optargs-of cproc) is expected, %d given.\",, Scm_Length(SCM_OPTARGS));"))
  ;; argument assertions & unbox op.
  (for-each emit-arg-unbox (args-of cproc))
  ;; body
  (print "  {")
  (for-each print (reverse (stmts-of cproc)))
  (print "  }")
  (print "}")
  (newline)
  )

(define-method emit-initializer ((cproc <cproc>))
  (when (symbol? (scheme-name-of cproc))
    (f "  SCM_DEFINE(module, ~s, SCM_OBJ(&~a__STUB));"
       (symbol->string (scheme-name-of cproc)) (c-name-of cproc)))
  (next-method)
  )

(define-method emit-initializer ((cproc <setter-mixin>))
  (when (setter-of cproc)
    (f "  Scm_SetterSet(SCM_PROCEDURE(&~a__STUB), SCM_PROCEDURE(&~a__STUB), TRUE);"
       (c-name-of cproc)
       (setter-c-name-of cproc))))

(define (emit-arg-decl arg)
  (f "  ScmObj ~a;" (scm-name-of arg))
  (f "  ~a ~a;" (c-type-of (type-of arg)) (c-name-of arg)))

(define (emit-arg-unbox arg)
  (let* ((class (class-of arg))
         (type  (type-of arg))
         (cname (c-name-of arg))
         (sname (scm-name-of arg))
         (count (count-of arg))
         (tdesc (description-of type))
         (pred  (c-predicate-of type))
         (unbox (unboxer-of type)))
    (cond
     ((eq? class <required-arg>)
      (f "  ~a = SCM_ARGREF(~a);" sname count))
     ((eq? class <optional-arg>)
      (f "  if (SCM_NULLP(SCM_OPTARGS)) ~a = ~a;"
         sname
         (scheme-constant->c-constant (default-of arg)))
      (f "  else {")
      (f "    ~a = SCM_CAR(SCM_OPTARGS);" sname)
      (f "    SCM_OPTARGS = SCM_CDR(SCM_OPTARGS);")
      (f "  }"))
     ((eq? class <keyword-arg>)
      (f "  ~a = Scm_GetKeyword(~a, SCM_OPTARGS, ~a);"
         sname (value-getter-of (keyword-of (c-keyword-of arg)))
         (scheme-constant->c-constant (default-of arg))))
     ((eq? class <rest-arg>)
      (f "  ~a = SCM_OPTARGS;" sname)))
    (when (and pred (not (string-null? pred)))
      (f "  if (!~a(~a)) Scm_Error(\"~a required, but got %S\", ~a);"
         pred sname tdesc sname))
    (if unbox
        (f "  ~a = ~a(~a);" cname unbox sname)
        (f "  ~a = ~a;" cname sname))))

(define (ensure-keyword-arg arg)
  (set! (c-keyword-of arg)
        (get-static-keyword (name-of arg)
                            (get-c-name "KEYARG_" (name-of arg)))))

;; TODO: arg type assertion
(define (emit-inliner cproc)
  (let* ((insn (inline-insn-of cproc)))
    (when insn
      (set! (inliner-of cproc) (string-append (c-name-of cproc) "_inline"))
      (emit-inliner-header cproc)
      (print "{")
      (cond ((string? insn) (emit-inliner-call cproc insn))
            ((and (pair? insn) (eq? (car insn) 'case-nargs))
             (print "  int nargs = Scm_Length(SCM_CDR(form));")
             (for-each (lambda (clause)
                         (let ((nargs (car clause))
                               (insn  (cadr clause)))
                           (if (eq? nargs 'else)
                               (display "else ")
                               (display #`"if (nargs == ,|nargs|) "))
                           (print "{")
                           (if insn
                               (emit-inliner-call cproc insn)
                               (print "  return SCM_FALSE;"))
                           (print "}")))
                       (cdr insn))))
      (print "}")
      ))
  )

(define (emit-inliner-header cproc)
  (let ((inliner (inliner-of cproc))
        (name (scheme-name-of cproc))
        (req  (num-reqargs-of cproc))
        (opt  (num-optargs-of cproc))
        )
    (f "static ScmObj ~a(ScmSubr *subr, ScmObj form, ScmObj env, int ctx, int *depth)" inliner)
    ))

(define (emit-inliner-call cproc insn)
  (f "  return Scm_CompileInliner(form, env, ~a, ~a, ~a, \"~a\", depth);"
     (num-reqargs-of cproc)
     (if (or (< 0 (num-optargs-of cproc)) (have-rest-arg? cproc)) "TRUE" "FALSE")
     insn
     (scheme-name-of cproc)))

(define (emit-record cproc)
  (let1 c-func-name (c-name-of cproc)
    (emit-static-string c-func-name (scheme-name-of cproc))
    (f "static SCM_DEFINE_SUBR(~a__STUB, ~a, ~a, SCM_OBJ(&~a__NAME), ~:*~a, ~a, NULL);"
       c-func-name
       (num-reqargs-of cproc)
       (if (or (have-rest-arg? cproc) (> (num-optargs-of cproc) 0)) 1 0)
       c-func-name
       (or (inliner-of cproc) "NULL")
       )
    (newline)))

;;-----------------------------------------------------------------
;; Generic function
;;

;; (define-cgeneric scheme-name c-name
;;    [(extern)]
;;    [(fallback "fallback")]
;;    [(setter setter-desc)])

(define-class <cgeneric> (<setter-mixin> <stub>)
  ((extern?  :initform #f :init-keyword :extern? :accessor extern?)
   (fallback :initform "NULL" :init-keyword :fallback
             :accessor fallback-of)
   ))

(define-method emit-definition ((self <cgeneric>))
  (unless (extern? self) (display "static "))
  (f "SCM_DEFINE_GENERIC(~a, ~a, NULL);" (c-name-of self) (fallback-of self))
  (newline))

(define-method emit-initializer ((self <cgeneric>))
  (f "  Scm_InitBuiltinGeneric(&~a, ~s, module);"
     (c-name-of self) (symbol->string (scheme-name-of self)))
  (next-method))

(define-form-parser define-cgeneric (scheme-name c-name . body)
  (check-arg symbol? scheme-name)
  (check-arg string? c-name)
  (let ((gf (make <cgeneric> :scheme-name scheme-name :c-name c-name)))
    (for-each (lambda (form)
                (cond ((not (pair? form))
                       (error "bad gf form:" form))
                      ((eq? (car form) 'extern)  (set! (extern? gf) #t))
                      ((eq? (car form) 'fallback)
                       (if (and (pair? (cdr form)) (string? (cadr form)))
                           (set! (fallback-of gf) (cadr form))
                           (error "bad fallback form:" form)))
                      ((eq? (car form) 'setter)
                       (unless (pair? (cdr form))
                         (error "bad setter form in" form))
                       (process-setter gf (cdr form)))
                      (else (error "bad gf form:" form))))
              body)
    (with-cpp-condition gf
      (emit-definition gf))))

(define-method process-setter ((gf <cgeneric>) setter)
  (cond
   ((symbol? (car decl))
    (set! (setter-of cproc) (car decl))
    (set! (setter-c-name-of cproc) (get-c-name *file-prefix* (car decl))))
   (else
    (error "bad form of anonymous setter:" `(setter ,decl)))))

(define (get-c-generic-name name)
  (cond ((find (lambda (x) (eq? (scheme-name-of x) name))
               (get-stubs <cgeneric>))
         => c-name-of)
        (else #f)))

;;-----------------------------------------------------------------
;; Methods
;;

;; (define-cmethod scheme-name (argspec ...)
;;    [ (c-generic-name "CGenericName") ]
;;    body ...)

(define-class <cmethod> (<procstub>)
  ((specializers :init-keyword :specializers :accessor specializers-of)
   (c-generic    :initform #f    :accessor c-generic-of)
   ))

(define-form-parser define-cmethod (scheme-name argspec . body)
  (check-arg symbol? scheme-name)
  (check-arg list? argspec)
  (receive (args specializers numargs have-optarg?)
      (parse-specialized-args argspec)
    (let ((method (make <cmethod>
                    :scheme-name scheme-name
                    :c-name (get-c-name *file-prefix*
                                        (gensym (symbol->string scheme-name)))
                    :specializers specializers
                    :num-reqargs numargs
                    :args args
                    :have-rest-arg? have-optarg?
                    )))
      (for-each (lambda (stmt)
                  (cond ((string? stmt) (push-stmt! method stmt))
                        ((and (pair? stmt) (eq? (car stmt) 'c-generic-name))
                         (unless (string? (cadr stmt))
                           (error "c-generic-name requires a string:"
                                  (cadr stmt)))
                         (set! (c-generic-of method) (cadr stmt)))
                        (else
                         (error "unrecognized form in body:" stmt))))
                body)
      (unless (c-generic-of method)
        (set! (c-generic-of method)
              (or (get-c-generic-name scheme-name)
                  (error "method can't find C name of the generic function:" scheme-name))))
      (with-cpp-condition method
        (emit-definition method))))
  )

(define-method emit-definition ((method <cmethod>))
  (f "static ScmObj ~a(ScmNextMethod *nm_, ScmObj *SCM_FP, int SCM_ARGCNT, void *d_)"
     (c-name-of method))
  (print "{")
  (for-each emit-arg-decl (args-of method))
  (when (have-rest-arg? method)
    (print "  ScmObj SCM_OPTARGS = SCM_ARGREF(SCM_ARGCNT-1);"))
  (for-each emit-arg-unbox (args-of method))
  ;; body
  (print "  {")
  (for-each print (stmts-of method))
  (print "  }")
  (print "}")
  (newline)
  (display #`"static ScmClass *,(c-name-of method)__SPEC[] = { ")
  (for-each (lambda (spec) (display #`"SCM_CLASS_STATIC_PTR(,|spec|), "))
            (reverse (specializers-of method)))
  (print "};")
  (f "static SCM_DEFINE_METHOD(~a__STUB, &~a, ~a, ~a, ~a__SPEC, ~:*~a, NULL);"
     (c-name-of method) (c-generic-of method)
     (num-reqargs-of method) (if (have-rest-arg? method) "1" "0")
     (c-name-of method))
  (newline)
  )

(define-method emit-initializer ((method <cmethod>))
  (f "  Scm_InitBuiltinMethod(&~a__STUB);" (c-name-of method)))

;; returns four values: args, specializers, numreqargs, have-optarg?
(define (parse-specialized-args arglist)
  (define (badlist) (error "malformed arglist:" arglist))
  (let loop ((arglist arglist)
             (args    '())
             (specs   '()))
    (cond ((null? arglist)
           (values args specs (length args) #f))
          ((symbol? arglist)
           (values (cons (make-arg <rest-arg> arglist (length args))
                         args)
                   (cons "Scm_ListClass" specs)
                   (length args) #t))
          ((not (pair? arglist)) (badlist))
          ((symbol? (car arglist))
           (loop (cdr arglist)
                 (cons (make-arg <required-arg> (car arglist) (length args))
                       args)
                 (cons "Scm_TopClass" specs)))
          ((not (and (pair? (car arglist))
                     (= (length (car arglist)) 2)
                     (symbol? (caar arglist))
                     (string? (cadar arglist))))
           (badlist))
          (else
           (loop (cdr arglist)
                 (cons (make-arg <required-arg> (caar arglist) (length args))
                       args)
                 (cons (cadar arglist) specs)))
          )))

;;===================================================================
;; Class
;;
;;  - Generates C stub for static class definition, slot accessors and
;;    initialization.   Corresponding C struct has to be defined elsewhere.
;;
;;  - <cclass> should be a <type> as well, but currently not.
;;    If not corresponding type is defined at the time define-cclass is
;;    parsed, the type is created with the default parameters.

;; (define-cclass scheme-name [qualifier] c-type-name c-class-name cpa
;;   (<slot-spec> ...)
;;   [(allocator <proc-spec>)]
;;   [(printer   <proc-spec>)]
;;   [(direct-supers <string> ...)]
;;   )
;;
;; <slot-spec> := slot-name
;;             |  (slot-name
;;                  [:type <type>]
;;                  [:c-name <c-name>]
;;                  [:c-spec <c-spec>]
;;                  [:getter <proc-spec>]
;;                  [:setter <proc-spec>])
;;                  
;; <proc-spec> := <c-code> | (c <c-name>) | #f | #t
;;
;; <cpa> := (<string> ...)
;;
;; qualifier := :base | :built-in

;; 'cpa' lists ancestor classes in precedence order.  They need to
;; be C identifiers of Scheme class (Scm_*Class), for the time being.
;; Scm_TopClass is added at the end automatically.
;;
;; 'direct-supers' specifies a list of direct superclass, if the
;; defined class does multiple inheritance.  When omitted, the first
;; element of 'cpa' is used as the only direct superclass.
;;
;; 'allocator' and 'printer' clause specifies custom allocator and/or
;; printer procedure.  You can either directly write C function body
;; as string, or specify a C function name by '(c <c-name>)' form.

(define-class <cclass> (<stub>)
  ((cpa       :init-keyword :cpa       :init-value '()
              :accessor cpa-of)
   (c-type    :init-keyword :c-type    :accessor c-type-of)
   (qualifier :init-keyword :qualifier :accessor qualifier-of)
   (allocator :init-keyword :allocator :init-value #f
              :accessor allocator-of)
   (printer   :init-keyword :printer   :init-value #f
              :accessor printer-of)
   (slot-spec :init-keyword :slot-spec :init-value '()
              :accessor slot-spec-of)
   (direct-supers :init-keyword :direct-supers :init-value '()
                  :accessor direct-supers-of)
   ))

(define-method initialize ((self <cclass>) initargs)
  (next-method)
  (unless (find-type-by-name (scheme-name-of self))
    (parse-form
     `(define-type ,(scheme-name-of self) ,(c-type-of self))))
  )

(define-class <cslot> ()
  ((cclass      :init-keyword :cclass :accessor cclass-of)
   (scheme-name :init-keyword :scheme-name :accessor scheme-name-of)
   (c-name      :init-keyword :c-name :accessor c-name-of)
   (c-spec      :init-keyword :c-spec :accessor c-spec-of)
   (type        :init-keyword :type   :accessor type-of :init-value '<top>)
   (getter      :init-keyword :getter :accessor getter-of :init-value #t)
   (setter      :init-keyword :setter :accessor setter-of :init-value #t)
   ))

(define-form-parser define-cclass (scm-name x . args)
  (check-arg symbol? scm-name)
  (receive (qual c-type c-name cpa slot-spec . more)
      (if (keyword? x)
          (apply values x args)
          (apply values :built-in x args))
    (check-arg string? c-name)
    (check-arg list? cpa)
    (check-arg list? slot-spec)
    (unless (memv qual '(:built-in :base))
      (error "unknown define-cclass qualifier" qual))
    (let* ((allocator (cond ((assq 'allocator more) => cadr) (else #f)))
           (printer   (cond ((assq 'printer more) => cadr) (else #f)))
           (dsupers   (cond ((assq 'direct-supers more) => cdr) (else '())))
           (cclass (make <cclass>
                     :scheme-name scm-name :c-type c-type :c-name c-name
                     :qualifier qual
                     :cpa cpa :direct-supers dsupers
                     :allocator allocator :printer printer)))
      (set! (slot-spec-of cclass) (process-cclass-slots cclass slot-spec))
      (with-cpp-condition cclass
        (emit-definition cclass)))))

(define-method c-printer-name-of ((self <cclass>))
  (let1 printer (printer-of self)
    (cond ((string? printer) #`",(c-name-of self)_PRINT")
          ((c-literal? printer) (cadr printer))
          ((not printer) "NULL")
          (else (errorf "bad printer specification ~s in class ~s" printer self)))))

(define-method c-allocator-name-of ((self <cclass>))
  (let1 allocator (allocator-of self)
    (cond ((string? allocator) #`",(c-name-of self)_ALLOCATE")
          ((c-literal? allocator) (cadr allocator))
          ((not allocator) "NULL")
          (else (errorf "bad allocator specification ~s in class ~s" allocator self)))))

(define-method c-slot-spec-name-of ((self <cclass>))
  (if (null? (slot-spec-of self))
      "NULL"
      #`",(c-name-of self)__SLOTS"))

(define-method c-type-size-of ((self <cclass>))
  (if (c-type-of self) #`"sizeof(,(c-type-of self))" 0))
      
(define-method emit-definition ((self <cclass>))
  (when (string? (allocator-of self))
    (print #`"static ScmObj ,(c-allocator-name-of self)(ScmClass *klass, ScmObj initargs)")
    (print "{")
    (print (allocator-of self))
    (print "}")
    (newline))
  (when (string? (printer-of self))
    (print #`"static void ,(c-printer-name-of self)(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)")
    (print "{")
    (print (printer-of self))
    (print "}")
    (newline))
  (emit-cpa self)
  (if (eqv? (qualifier-of self) :base)
      (let1 c-type (string-trim-right (c-type-of self))
        (unless (string-suffix? "*" c-type)
          (errorf "can't use C-type ~s as a base class; C-type must be a pointer type" c-type))
        (let1 c-instance-type (string-drop-right c-type 1)
          (print #`"SCM_DEFINE_BASE_CLASS(,(c-name-of self), ,|c-instance-type|, ,(c-printer-name-of self), NULL, NULL, ,(c-allocator-name-of self), ,(cpa-name-of self));")))
      (print #`"SCM_DEFINE_BUILTIN_CLASS(,(c-name-of self), ,(c-printer-name-of self), NULL, NULL, ,(c-allocator-name-of self), ,(cpa-name-of self));"))
  (newline)
  (when (pair? (slot-spec-of self))
    (for-each emit-getter-n-setter (slot-spec-of self))
    (print #`"static ScmClassStaticSlotSpec ,(c-slot-spec-name-of self)[] = {")
    (for-each emit-spec-definition (slot-spec-of self))
    (print "  { NULL }")
    (print "};")
    (newline))
  )

(define-method emit-initializer ((self <cclass>))
  (print #`"  Scm_InitBuiltinClass(&,(c-name-of self), \",(scheme-name-of self)\", ,(c-slot-spec-name-of self), TRUE, module);")
  ;; adjust direct-supers if necessary
  (let1 ds (direct-supers-of self)
    (when (not (null? ds))
      (format #t "  ~a.directSupers = Scm_List(" (c-name-of self))
      (for-each (lambda (s) (format #t "SCM_OBJ(&~a), " s)) ds)
      (format #t " NULL);\n"))))

;; cpa ----------
;;  For now, cpa should be a list of C class names, or c literal

(define-method cpa-name-of ((self <cclass>))
  (cond ((null? (cpa-of self)) "SCM_CLASS_DEFAULT_CPL")
        ((c-literal? (cpa-of self)) (cadr (cpa-of self)))
        (else #`",(c-name-of self)_CPL")))

(define-method emit-cpa ((self <cclass>))
  (let1 cpa (cpa-of self)
    (unless (or (null? cpa) (c-literal? (cpa-of self)))
      (print #`"static ScmClass *,(c-name-of self)_CPL[] = {")
      (for-each (lambda (class)
                  (print #`"  SCM_CLASS_STATIC_PTR(,|class|),"))
                cpa)
      (unless (equal? (car (last-pair cpa)) "Scm_TopClass")
        (print "  SCM_CLASS_STATIC_PTR(Scm_TopClass),"))
      (print "  NULL")
      (print "};"))))

;; slot ---------

(define (process-cclass-slots cclass slot-spec)
  (map (lambda (spec)
         (unless (list? spec) (error "bad slot spec" spec))
         (let* ((name (car spec))
                (type   (get-keyword :type (cdr spec) '<top>))
                (c-name (get-keyword :c-name (cdr spec) (get-c-name "" name)))
                (c-spec (get-keyword :c-spec (cdr spec) #f))
                (getter (get-keyword :getter (cdr spec) #t))
                (setter (get-keyword :setter (cdr spec) #t)))
           (make <cslot>
             :cclass cclass :scheme-name name :c-name c-name
             :c-spec c-spec :type (name->type type)
             :getter getter :setter setter)))
       slot-spec))

(define-method slot-getter-name ((slot <cslot>))
  (let1 getter (getter-of slot)
    (if (c-literal? getter)
        (cadr getter)
        #`",(c-name-of (cclass-of slot))_,(get-c-name \"\" (scheme-name-of slot))_GET")))

(define-method slot-setter-name ((slot <cslot>))
  (let1 setter (setter-of slot)
    (cond ((c-literal? setter) (cadr setter))
          ((not setter) "NULL")
          (else #`",(c-name-of (cclass-of slot))_,(get-c-name \"\" (scheme-name-of slot))_SET"))))

(define-method emit-getter-n-setter ((slot <cslot>))
  (unless (c-literal? (getter-of slot)) (emit-getter slot))
  (when (and (setter-of slot) (not (c-literal? (setter-of slot))))
    (emit-setter slot)))

(define-method emit-getter ((slot <cslot>))
  (let* ((type  (type-of slot))
         (class (cclass-of slot))
         (class-type (name->type (scheme-name-of class))))
    (print #`"static ScmObj ,(slot-getter-name slot)(ScmObj OBJARG)")
    (print "{")
    (print #`"  ,(c-type-of class-type) obj = ,(unboxer-of class-type)(OBJARG);")
    (cond ((string? (getter-of slot)) (print (getter-of slot)))
          ((string? (c-spec-of slot))
           (f "  return ~a(~a);" (boxer-of type) (c-spec-of slot)))
          (else
           (f "  return ~a(obj->~a);" (boxer-of type) (c-name-of slot))))
    (print "}")
    (newline)))

(define-method emit-setter ((slot <cslot>))
  (let* ((type (type-of slot))
         (class (cclass-of slot))
         (class-type (name->type (scheme-name-of class))))
    (print #`"static void ,(slot-setter-name slot)(ScmObj OBJARG, ScmObj value)")
    (print "{")
    (print #`"  ,(c-type-of class-type) obj = ,(unboxer-of class-type)(OBJARG);")
    (if (string? (setter-of slot))
        (print (setter-of slot))
        (begin
          (unless (eq? type *scm-type*)
            (f "  if (!~a(value)) Scm_Error(\"~a required, but got %S\", value);"
               (c-predicate-of type) (c-type-of type)))
          (if (c-spec-of slot)
              (f "  ~a = ~a(value);" (c-spec-of slot) (unboxer-of type))
              (f "  obj->~a = ~a(value);" (c-name-of slot) (unboxer-of type)))))
    (print "}")
    (newline)))

(define-method emit-spec-definition ((slot <cslot>))
  (print #`"  SCM_CLASS_SLOT_SPEC(\",(scheme-name-of slot)\", ,(slot-getter-name slot), ,(slot-setter-name slot)),"))

;;===================================================================
;; Extra initializers
;;

(define-class <initcode> (<stub>)
  ((code  :initform '() :init-keyword :code :accessor code-of)
   ))

(define-method emit-defintion ((self <initcode>))
  #f)
(define-method emit-initializer ((self <initcode>))
  (for-each display (code-of self)))

(define-form-parser initcode codes
  (make <initcode> :code codes))

;;===================================================================
;; Miscellaneous utilities
;;

;; Get C expression that returns Scheme constant value VALUE.
(define (scheme-constant->c-constant value)
  (cond ((boolean? value) (if value "SCM_TRUE" "SCM_FALSE"))
        ((null? value)    "SCM_NIL")
        ((char? value)
         (format #f "SCM_MAKE_CHAR(~a) /* #\\~a */"
                 (char->integer value) value))
        ((integer? value)
         (format #f "Scm_MakeInteger(~a)" value))
        ((string? value)
         (format #f "SCM_MAKE_STR(~s)" value))
        ((keyword? value)
         (format #f "SCM_MAKE_KEYWORD(\"~a\")" value))
        ((eq? value *unbound*)
         "SCM_UNBOUND")
        ((equal? value '(current-input-port))
         (format #f "SCM_OBJ(SCM_CURIN)"))
        ((equal? value '(current-output-port))
         (format #f "SCM_OBJ(SCM_CUROUT)"))
        ((equal? value '(current-error-port))
         (format #f "SCM_OBJ(SCM_CURERR)"))
        ((c-literal? value)
         (format #f "~a" (cadr value)))
        (else
         (errorf "Scheme constant ~s can't be used" value))))

;; Translate Scheme name to C name
(define (get-c-name prefix scheme-name)
  (with-output-to-string
    (lambda ()
      (display (x->string prefix)) 
      (with-input-from-string (x->string scheme-name)
        (lambda ()
          (let loop ((c (read-char)))
            (unless (eof-object? c)
              (case c
                ((#\-) (let ((d (read-char)))
                         (cond ((eof-object? d)
                                (display #\_))
                               ((eqv? d #\>)
                                (display "_TO") (loop (read-char)))
                               (else
                                (display #\_) (loop d)))))
                ((#\?) (display #\P) (loop (read-char)))
                ((#\!) (display #\X) (loop (read-char)))
                ((#\<) (display "_LT") (loop (read-char)))
                ((#\>) (display "_GT") (loop (read-char)))
                ((#\* #\> #\@ #\$ #\% #\^ #\& #\* #\+ #\=
                  #\: #\. #\/ #\~)
                 (display #\_)
                 (display (number->string (char->integer c) 16))
                 (loop (read-char)))
                (else (display c) (loop (read-char)))
                ))))
        )
      )
    )
  )

;; Emit static ScmString
(define (emit-static-string c-name scm-name)
  (let1 len (string-length (x->string scm-name))
    (f "static SCM_DEFINE_STRING_CONST(~a__NAME, \"~a\", ~a, ~:*~a);"
       c-name scm-name len)))

;; Check if item is in the form (c <string>)
(define (c-literal? item)
  (and (pair? item) (= (length item) 2) (eq? (car item) 'c) (string? (cadr item))))

;;===================================================================
;; Main parser
;;

(define-form-parser if (test then)
  (parameterize ((cpp-condition test))
    (parse-form then)))

(define-form-parser begin forms
  (for-each parse-form forms))

(define-form-parser include (file)
  (unless (file-exists? file)
    ;; TODO: search path
    (error "couldn't find include file: " file))
  (with-input-from-file file
    (lambda () (port-for-each parse-form read)))
  )

(define-method emit-initializer ((name <string>))
  (f "void Scm_Init_~a(ScmModule *module)" name)
  (print "{")
  (for-each (lambda (stub)
              (with-cpp-condition stub (emit-initializer stub)))
            (reverse (instance-pool->list <stub>)))
  (print "}")
  )

;;===================================================================
;; main entry point
;;

(define (main args)
  (let* ((predef-syms '())
         (args (parse-options (cdr args)
                (("D=s"  (sym) (push! predef-syms sym))
                 (else _ (usage))))))
    (unless (and (= (length args) 1)
                 (> (string-length (car args)) 5))
      (usage))

    (let* ((file (car args))
           (base (sys-basename file))
           (filelen (string-length file))
           (baselen (string-length base))
           (prefix (substring base 0 (- baselen 5)))
           (outfile (string-append (substring file 0 (- filelen 5)) ".c")))
      (unless (file-exists? file)
        (f "Couldn't open ~a" file)
        (exit 1))
      (set! *file-prefix* (string-append (get-c-name "" prefix) "_"))
      (with-output-to-file outfile
        (lambda ()
          (f "/* Generated by genstub.  Do not edit. */")
          (f "/* source: ~a */" file)
          (for-each (lambda (sym) (f "#define ~a" sym)) predef-syms)
          (f "#include <gauche.h>")
          (newline)
          (with-input-from-file file
            (lambda () (port-for-each parse-form read)))
          (emit-initializer (get-c-name "" prefix))
          )))
    )
  0)

(define (usage)
  (print "Usage: genstub [-D symbol] FILE.stub")
  (exit 1))


;; Local variables:
;; mode: scheme
;; end:
