;;;
;;; genstub - simple stub generator for Gauche
;;;  
;;;   Copyright (c) 2000-2006 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.124 2006/03/09 15:48:24 shirok Exp $
;;;

(use srfi-1)
(use srfi-2)
(use srfi-13)
(use gauche.parseopt)
(use gauche.parameter)
(use gauche.mop.instance-pool)
(use gauche.sequence)
(use gauche.cgen)
(use file.util)
(use util.match)
(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 c++-exception-used? (make-parameter #f))

(define (f fmt . args)
  (cgen-body (apply format fmt args)))

;; 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:
;;        (code <C-code> ...)
;;             <C-code> is inserted at this position.  Useful to insert
;;             extra code before 'call' or 'expr' spec.
;;        (call [<rettype>] <C-function-name>)
;;             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>.
;;        (expr [<rettype>] <C-expr>) :
;;             <C-expr> must be a C expression of type <rettype>.  The
;;             value of C-expr is boxed and returned.  <void> isn't allowed
;;             as <rettype> (you can use 'body' directive).
;;        (body [<rettype>] <C-code> ...) :
;;             C-code becomes the body of the stub function.  In it,
;;             the code must assign to a variable SCM_RESULT.  The stub
;;             generator boxes the value and returns it.  (If <rettype>
;;             is <void>, though, C-code shouldn't assign SCM_RESULT.
;;             The generated function returns #<undef>.
;;        (body (<rettype> ...) <C-code> ...) :
;;             Procedure yields more than one value.  C variables
;;             SCM_RESULT0, SCM_RESULT1, ... are defined to receive the
;;             results.
;;        (setter <setter-name>) : specfy setter.  <setter-name> should
;;             be a cproc name defined in the same stub file
;;        (setter (args ...) body ...) : specify setter anonymously.
;;        (catch (<decl> <C-stmt> ...) ...) : when writing a stub
;;             for C++ function that may throw an exception, use this spec
;;             to ensure the exception will be caught and converted to
;;             Gauche error condition.
;;
;;        a string : becomes the body of C code.  DEPRECATED.
;;        (return [<rettype>] <C-function-name>)  same as 'call'.  DEPRECATED.
;;
;;   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.
;;
;;   define-enum-conditionally name
;;      Abbreviation of (if "defined(name)" (define-enum name))
;;
;;   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) (cgen-body 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>)
;;
;;   <const-cstring> <string>  const char* For arguments, string is unboxed
;;                                         by Scm_GetStringConst.
;;                                         For return values, C string is boxed
;;                                         by SCM_MAKE_STR_COPYING.
;;
;;   <pair>       <pair>       ScmPair*
;;   <list>       <list>       ScmObj
;;   <string>     <string>     ScmString*
;;   <symbol>     <symbol>     ScmSymbol*
;;   <vector>     <vector>     ScmVector*
;;    :
;;
;; Pointer types can be qualified as 'maybe', by adding '?' at the
;; end of type name, e.g. '<string>?'.
;; If 'maybe' type appears as an argument type, the argument accepts #f
;; as well as the specified type, and translates #f to NULL.  If 'maybe'
;; type appears as the return type, the result of C expression can be NULL
;; and the stub translates it to #f.

;; 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.
   (maybe       :init-keyword :maybe       :init-value #f)
   ;; ::<type>? - base type, if this is 'maybe' qualified type.
   ))

(define (find-type-by-name name)
  (or (find (lambda (type) (eq? (name-of type) name))
            (instance-pool->list <type>))
      ;; when 'maybe' qualified type is used for the first time, we
      ;; create it from the base type.
      (and-let* ((m (#/\?$/ (symbol->string name)))
                 (basename (string->symbol (m 'before)))
                 (basetype (find-type-by-name basename)))
        (make <type> :name name :c-type (ref basetype 'c-type)
              :description #`",(ref basetype 'description) or #f"
              :c-predicate (ref basetype 'c-predicate)
              :unboxer     (ref basetype 'unboxer)
              :boxer       (ref basetype 'boxer)
              :maybe       basetype))))

(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_\")")

  (unless (<= 2 (length args) 6)
    (error "malformed define-type:" args))
  (let-optionals* args ((name #f)
                        (c-type #f)
                        (desc   #f)
                        (c-pred #f)
                        (unbox  #f)
                        (box    #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"))))

;; Returns C expr
(define (box-expr type c-expr)
  (if (ref type 'maybe)
    #`"SCM_MAKE_MAYBE(,(ref type 'boxer),, ,c-expr)"
    #`",(ref type 'boxer)(,c-expr)"))

(define (unbox-expr type c-expr)
  (if (ref type 'maybe)
    #`"SCM_MAYBE(,(ref type 'unboxer),, ,c-expr)"
    #`",(ref type 'unboxer)(,c-expr)"))

(define (pred-expr type c-expr)
  (if (ref type 'maybe)
    #`"SCM_MAYBE_P(,(ref type 'c-predicate),, ,c-expr)"
    #`",(ref type 'c-predicate)(,c-expr)"))

(define (return-stmt expr)
  #`"SCM_RETURN(,expr);")

;; 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_UINTEGERP" "Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
   (define-type <ulong>   "u_long" "C integer"
     "SCM_UINTEGERP" "Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
   (define-type <ushort>  "u_short" "C short integer"
     "SCM_EXACTP" "(unsigned short)Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
   (define-type <uint8>   "u_int" "C integer"
     "SCM_UINTP" "Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
   (define-type <uint16>  "u_int" "C integer"
     "SCM_UINTP" "Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
   (define-type <uint32>  "u_int" "C integer"
     "SCM_UINTEGERP" "Scm_GetIntegerU" "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" "" "")

   ;; C string
   (define-type <const-cstring> "const char *" "const C string"
     "SCM_STRINGP" "SCM_STRING_CONST_CSTRING" "SCM_MAKE_STR_COPYING")

   ;; 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 <promise> "ScmPromise*" "promise"
     "SCM_PROMISEP" "SCM_PROMISE")
   (define-type <hash-table> "ScmHashTable*" "hash table"
     "SCM_HASH_TABLE_P" "SCM_HASH_TABLE")
   (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_WEAK_VECTOR_P" "SCM_WEAK_VECTOR")
   (define-type <compiled-code> "ScmCompiledCode*" "compiled code"
     "SCM_COMPILED_CODE_P" "SCM_COMPILED_CODE")
   (define-type <foreign-pointer> "ScmForeignPointer*" "foreign pointer"
     "SCM_FOREIGN_POINTER_P" "SCM_FOREIGN_POINTER")
   ))

;; 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)
  (filter (cut is-a? <> 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 to 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>))
  (cgen-init (format "  ~a = ~a(~a)"
                     (c-name-of self)
                     (if (positive? (value-of self))
                       "Scm_MakeIntegerFromUI"
                       "Scm_MakeInteger")
                     (value-of self))))

;; 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>))
  (cgen-init (format "  ~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>))
  (cgen-init (format "  ~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 :scheme-name name)))
    (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))
  (cgen-init
   (format "  ~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? :scheme-name name
                   :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-form-parser define-enum-conditionally (name)
  (check-arg symbol? name)
  (parameterize ((cpp-condition #`"defined(,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 :scheme-name name)))
        (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 keeps the name of the setter, or a string of c-name of the
   ;; setter in case of anonymous setter.
   ))

(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)
      ;; reverse list of C stmt lines.
   (c++-handlers    :initform '() :accessor c++-handlers-of)
      ;; ((<c++-exception-decl> <handler-stmt> ...) ...)
      ;; If not null, the entire procedure body is wrapped by 'try' and
      ;; an appropriate handlers are emitted.  Necessary to write a stub
      ;; for C++ functions that may throw an exception.
   ))

(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-generic c-stub-name-of )

;;-----------------------------------------------------------------
;; (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)))))

(define-method c-stub-name-of ((cproc <cproc>))
  #`",(c-name-of cproc)__STUB")

;; 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)
  (dolist (form body)
    (match form
      ((? string?) (push-stmt! cproc form))
      (('inliner opcode) (set! (inline-insn-of cproc) opcode))
      (('setter . spec) (process-setter cproc spec))
      (('return . spec) (process-call-spec cproc form))
      (('call . spec) (process-call-spec cproc form))
      (('body . spec) (process-body-spec cproc form))
      (('expr . spec) (process-expr-spec cproc form))
      (('catch . spec) (process-catch-spec cproc form))
      (('code . stmts) (for-each (cut push-stmt! cproc <>) stmts))
      (else (error "unknown body form:" form)))))

(define-method process-setter ((cproc <cproc>) decl)
  (cond
   ((symbol? (car decl))
    (set! (setter-of cproc) (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 #`",(c-name-of cproc)_SETTER"
                      :args args
                      :num-reqargs nreqs
                      :num-optargs nopts
                      :have-rest-arg? rest?)))
        (set! (setter-of cproc) #`",(c-name-of setter)__STUB")
        (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-call-spec ((cproc <procstub>) form)
  (define (err) (error "malformed 'call' spec:" form))
  (define (args)
    (string-join (map c-name-of (args-of cproc)) ", "))
  (define (typed-result rettype c-func-name)
    (push-stmt! cproc "{")
    (push-stmt! cproc #`",(c-type-of rettype) SCM_RESULT;")
    (push-stmt! cproc #`"SCM_RESULT = ,c-func-name(,(args));")
    (push-stmt! cproc (return-stmt (box-expr rettype "SCM_RESULT")))
    (push-stmt! cproc "}"))
  (match form
    ((_ (? string? expr))
     (typed-result *scm-type* expr))
    ((_ typename expr)
     (unless (and (symbol? typename) (string? expr)) (err))
     (cond
      (;(eq? typename '<void>)
       (memq typename '(<void> void)) ;; tolerate old name for transition
       (push-stmt! cproc #`",(caddr form)(,(args));")
       (push-stmt! cproc "SCM_RETURN(SCM_UNDEFINED);"))
      (else
       (typed-result (name->type typename) expr))))
    (else (err))))

(define-method process-body-spec ((cproc <procstub>) form)
  (define (typed-result rettype stmts)
    (push-stmt! cproc "{")
    (push-stmt! cproc #`",(c-type-of rettype) SCM_RESULT;")
    (for-each (cut push-stmt! cproc <>) stmts)
    (push-stmt! cproc (return-stmt (box-expr rettype "SCM_RESULT")))
    (push-stmt! cproc "}"))
  (define (typed-results rettypes stmts)
    (let1 nrets (length rettypes)
      (for-each-with-index
       (lambda (i rettype)
         (push-stmt! cproc #`",(c-type-of rettype) SCM_RESULT,i;"))
       rettypes)
      (push-stmt! cproc "{")
      (for-each (cut push-stmt! cproc <>) stmts)
      (push-stmt! cproc "}")
      (let1 results
          (string-join
           (map-with-index (lambda (i rettype)
                             (box-expr rettype #`"SCM_RESULT,i"))
                           rettypes)
           ",")
        (push-stmt! cproc
                    (case nrets
                      ((0) (return-stmt "Scm_Values(SCM_NIL)"))
                      ((1) (return-stmt results))
                      ((2) (return-stmt #`"Scm_Values2(,results)"))
                      ((3) (return-stmt #`"Scm_Values3(,results)"))
                      ((4) (return-stmt #`"Scm_Values4(,results)"))
                      ((5) (return-stmt #`"Scm_Values5(,results)"))
                      (else (return-stmt #`"Scm_Values(Scm_List(,results,, NULL))"))))
        )))
  (define (err) (error "malformed 'body' spec:" form))
  (match form
    ((_ '<void> . stmts)
     (for-each (cut push-stmt! cproc <>) stmts)
     (push-stmt! cproc "SCM_RETURN(SCM_UNDEFINED);"))
    ((_ (? symbol? rettype) . stmts)
     (typed-result (name->type rettype) stmts))
    ((_ (? list? rettypes) . stmts)
     (unless (every symbol? rettypes) (err))
     (typed-results (map name->type rettypes) stmts))
    ((_ . stmts)
     (typed-result *scm-type* stmts))
    (else (err))))

(define-method process-expr-spec ((cproc <procstub>) form)
  (define (typed-result rettype expr)
    (push-stmt! cproc "{")
    (push-stmt! cproc #`",(c-type-of rettype) SCM_RESULT;")
    (push-stmt! cproc #`" SCM_RESULT = (,expr);")
    (push-stmt! cproc (return-stmt (box-expr rettype "SCM_RESULT")))
    (push-stmt! cproc "}"))
  (match form
    ((_ '<void> . stmts)
     (error "<void> type isn't allowed in 'expr' directive:" form))
    ((_ (? symbol? rettype) expr)
     (typed-result (name->type rettype) expr))
    ((_ expr)
     (typed-result *scm-type* expr))
    (else (error "malformed 'expr' spec:" form))))

(define-method process-catch-spec ((cproc <procstub>) form)
  (match form
    ((_ (decl . handler-stmts) ...)
     ;; push default handlers
     (push! (ref cproc 'c++-handlers)
            (list "..."
                  (format "Scm_Error(\"C++ exception is thrown in ~s\");"
                          (scheme-name-of cproc))))
     (push! (ref cproc 'c++-handlers)
            (list "std::exception& e"
                  (format "Scm_Error(\"~a: %s\", e.what());"
                          (scheme-name-of cproc))))
     (for-each (lambda (d s) (push! (ref cproc 'c++-handlers) (cons d s)))
               decl handler-stmts)
     ;; if this is the first time, make sure we include <stdexcept>.
     (unless (c++-exception-used?)
       (cgen-decl "#include <stdexcept>")
       (c++-exception-used? #t))
     )
    (else (error "malformed 'catch' spec:" form))))

;;; 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))
  (cgen-body "{")
  ;; argument decl
  (for-each emit-arg-decl (args-of cproc))
  (when (> (num-optargs-of cproc) 0)
    (cgen-body "  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)))
    (cgen-body #`"  if (Scm_Length(SCM_OPTARGS) > ,(num-optargs-of cproc))")
    (cgen-body #`"    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
  (unless (null? (ref cproc 'c++-handlers))
    (cgen-body "try {"))
  (cgen-body "  {")
  (apply cgen-body (reverse (stmts-of cproc)))
  (cgen-body "  }")
  (unless (null? (ref cproc 'c++-handlers))
    (cgen-body "}")
    (dolist (h (ref cproc 'c++-handlers))
      (cgen-body (format "catch (~a) {" (car h)))
      (dolist (s (cdr h)) (cgen-body s))
      (cgen-body "}")))
  ;; closing the function
  (cgen-body "}")
  (cgen-body "")
  )

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

(define-method emit-initializer ((cproc <setter-mixin>))
  (define (emit setter-name)
    (cgen-init
     (format "  Scm_SetterSet(SCM_PROCEDURE(&~a), SCM_PROCEDURE(&~a), TRUE);"
             (c-stub-name-of cproc) setter-name)))
  (match (setter-of cproc)
    ((? string? x) (emit x))
    ((? symbol? x)
     (or (and-let* ((setter (find (lambda (z) (eq? (scheme-name-of z) x))
                                  (get-stubs <stub>))))
           (emit (c-stub-name-of setter)))
         (errorf "unknown setter name '~a' is used in the definition of '~a'"
                 x (scheme-name-of cproc))))
    (_ #f)))

(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) Scm_Error(\"~a required, but got %S\", ~a);"
         (pred-expr type sname) tdesc sname))
    (if unbox
      (f "  ~a = ~a;" cname (unbox-expr type 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)
  (when (inline-insn-of cproc)
    (set! (inliner-of cproc)
          (format "SCM_MAKE_INT(SCM_VM_~a)"
                  (string-tr (x->string (inline-insn-of cproc)) "-" "_"))))
  )

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

(define (emit-record cproc)
  (let ((inliner-name "NULL"))
    (emit-static-string (c-name-of cproc) (scheme-name-of cproc))
    (when (inliner-of cproc)
      (set! inliner-name (inliner-of cproc)))
    (f "static SCM_DEFINE_SUBR(~a, ~a, ~a, SCM_OBJ(&~a__NAME), ~:*~a, ~a, NULL);"
       (c-stub-name-of cproc)
       (num-reqargs-of cproc)
       (if (or (have-rest-arg? cproc) (> (num-optargs-of cproc) 0)) 1 0)
       (c-name-of cproc)
       inliner-name
       )
    (cgen-body "")))

;;-----------------------------------------------------------------
;; 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 c-stub-name-of ((self <cgeneric>))
  (c-name-of self))

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

(define-method emit-initializer ((self <cgeneric>))
  (cgen-init (format "  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>) decl)
  (cond
   ((symbol? (car decl))
    (set! (setter-of gf) (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?
                    )))
      (dolist (stmt body)
        (match stmt
          ((? string?) (push-stmt! method stmt))
          (('c-generic-name gen-name)
           (unless (string? (cadr stmt))
             (error "c-generic-name requires a string:"
                    gen-name)
             (set! (c-generic-of method) gen-name)))
          (('body . spec) (process-body-spec method stmt))
          (('call . spec) (process-call-spec method stmt))
          (('expr . spec) (process-expr-spec method stmt))
          (('code . stmts) (for-each (cut push-stmt! method <>) stmts))
          (else
           (error "unrecognized form in body:" stmt))))
      (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))
  (cgen-body "{")
  (for-each emit-arg-decl (args-of method))
  (when (have-rest-arg? method)
    (cgen-body "  ScmObj SCM_OPTARGS = SCM_ARGREF(SCM_ARGCNT-1);"))
  (for-each emit-arg-unbox (args-of method))
  ;; body
  (cgen-body "  {")
  (apply cgen-body (reverse (stmts-of method)))
  (cgen-body "  }")
  (cgen-body "}")
  (cgen-body "")
  (cgen-body #`"static ScmClass *,(c-name-of method)__SPEC[] = { ")
  (for-each (lambda (spec) (cgen-body #`"SCM_CLASS_STATIC_PTR(,|spec|), "))
            (reverse (specializers-of method)))
  (cgen-body "};")
  (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))
  (cgen-body "")
  )

(define-method emit-initializer ((method <cmethod>))
  (cgen-init (format "  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))
    (cgen-body #`"static ScmObj ,(c-allocator-name-of self)(ScmClass *klass, ScmObj initargs)")
    (cgen-body "{")
    (cgen-body (allocator-of self))
    (cgen-body "}")
    (cgen-body ""))
  (when (string? (printer-of self))
    (cgen-body #`"static void ,(c-printer-name-of self)(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)")
    (cgen-body "{")
    (cgen-body (printer-of self))
    (cgen-body "}")
    (cgen-body ""))
  (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)
          (cgen-body #`"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));")))
      (cgen-body #`"SCM_DEFINE_BUILTIN_CLASS(,(c-name-of self), ,(c-printer-name-of self), NULL, NULL, ,(c-allocator-name-of self), ,(cpa-name-of self));"))
  (cgen-body "")
  (when (pair? (slot-spec-of self))
    (for-each emit-getter-n-setter (slot-spec-of self))
    (cgen-body #`"static ScmClassStaticSlotSpec ,(c-slot-spec-name-of self)[] = {")
    (for-each emit-spec-definition (slot-spec-of self))
    (cgen-body "  { NULL }")
    (cgen-body "};")
    (cgen-body ""))
  )

(define-method emit-initializer ((self <cclass>))
  (cgen-init #`"  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))
      (cgen-init (format "  ~a.directSupers = Scm_List(" (c-name-of self)))
      (for-each (lambda (s) (cgen-init (format "SCM_OBJ(&~a), " s))) ds)
      (cgen-init (format " 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)))
      (cgen-body #`"static ScmClass *,(c-name-of self)_CPL[] = {")
      (for-each (lambda (class)
                  (cgen-body #`"  SCM_CLASS_STATIC_PTR(,|class|),"))
                cpa)
      (unless (equal? (car (last-pair cpa)) "Scm_TopClass")
        (cgen-body "  SCM_CLASS_STATIC_PTR(Scm_TopClass),"))
      (cgen-body "  NULL")
      (cgen-body "};"))))

;; 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))))
    (cgen-body #`"static ScmObj ,(slot-getter-name slot)(ScmObj OBJARG)")
    (cgen-body "{")
    (cgen-body #`"  ,(c-type-of class-type) obj = ,(unbox-expr class-type \"OBJARG\");")
    (cond ((string? (getter-of slot)) (cgen-body (getter-of slot)))
          ((string? (c-spec-of slot))
           (f "  return ~a;" (box-expr type (c-spec-of slot))))
          (else
           (f "  return ~a;" (box-expr type #`"obj->,(c-name-of slot)"))))
    (cgen-body "}")
    (cgen-body "")))

(define-method emit-setter ((slot <cslot>))
  (let* ((type (type-of slot))
         (class (cclass-of slot))
         (class-type (name->type (scheme-name-of class))))
    (cgen-body #`"static void ,(slot-setter-name slot)(ScmObj OBJARG, ScmObj value)")
    (cgen-body "{")
    (cgen-body #`"  ,(c-type-of class-type) obj = ,(unbox-expr class-type \"OBJARG\");")
    (if (string? (setter-of slot))
      (cgen-body (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;" (c-spec-of slot) (unbox-expr type "value"))
          (f "  obj->~a = ~a;" (c-name-of slot) (unbox-expr type "value")))))
    (cgen-body "}")
    (cgen-body "")))

(define-method emit-spec-definition ((slot <cslot>))
  (cgen-body #`"  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>))
  (apply cgen-init (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 ()
  (for-each (lambda (stub)
              (let1 cpp (cpp-condition-of stub)
                (when cpp (cgen-init (format "#if ~a" cpp)))
                (emit-initializer stub)
                (when cpp (cgen-init (format "#endif /* ~a */" cpp)))))
            (instance-pool->list <stub>))
  )

;;===================================================================
;; 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))
           ;; NB: the following part should be replaced using
           ;; path-sans-extension etc. for simplicity, but it will be after
           ;; 0.8.6 release since 0.8.5 has a bug in it.
           (base (sys-basename file))
           (filelen (string-length file))
           (baselen (string-length base))
           (prefix  (get-c-name "" (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 prefix "_"))
      (parameterize ((cgen-current-unit
                      (make <cgen-unit>
                        :name (path-sans-extension file)
                        :preamble '("/* Generated by genstub.  Do not edit. */")
                        :pre-decl (map (cut format "#define ~a" <>)
                                       predef-syms)
                        :init-prologue (format "void Scm_Init_~a(ScmModule *module)\n{\n" prefix)
                        )))
        (with-input-from-file file
          (lambda () (port-for-each parse-form read)))
        (emit-initializer)
        (cgen-emit-c (cgen-current-unit))
        )))
  0)

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

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