;;;
;;; genstub - simple stub generator
;;;
;;;  Copyright(C) 2000-2002 by Shiro Kawai (shiro@acm.org)
;;;
;;;  Permission to use, copy, modify, distribute this software and
;;;  accompanying documentation for any purpose is hereby granted,
;;;  provided that existing copyright notices are retained in all
;;;  copies and that this notice is included verbatim in all
;;;  distributions.
;;;  This software is provided as is, without express or implied
;;;  warranty.  In no circumstances the author(s) shall be liable
;;;  for any damages arising out of the use of this software.
;;;
;;;  $Id: genstub,v 1.66 2002/05/21 04:46:45 shirok Exp $
;;;

(use srfi-1)
(use srfi-2)
(use srfi-13)
(use gauche.let-opt)
(use gauche.parseopt)
(use gauche.regexp)
(use gauche.parameter)

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

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

;; (define-type name assert-predicate c-type c-predicate unboxer [boxer])
;;
;;  name := <string>             ; used for messages
;;  assert-predicate := <symbol> ; used in assert declaration
;;  c-type := <string>           ; corresponding C type name when unboxed
;;  c-predicate := <string>      ; name of C function or macro that maps
;;                               ;   ScmObj -> C boolean
;;  unboxer := <string>          ; name of C function or macro that maps
;;                               ;   ScmObj -> c-type
;;                               ;   Can be "" if no unboxing needed
;;  boxer := <string>            ; name of C function or macro that maps
;;                               ;   c-type -> ScmObj
;;                               ;   Can be "" if no boxing needed
;;                               ;   Can be #f if no boxing available

(define-class <type> ()
  ((scheme-name :init-keyword :scheme-name :accessor scheme-name-of)
   (c-name      :init-keyword :c-name      :accessor c-name-of)
   (predicate   :getter predicate-of)
   (c-type      :init-keyword :c-type      :accessor c-type-of)
   (c-predicate :init-keyword :c-predicate :accessor c-predicate-of)
   (unboxer     :init-keyword :unboxer     :accessor unboxer-of)
   (boxer       :init-keyword :boxer       :accessor boxer-of
                :init-value "SCM_OBJ_SAFE")
   (all-types   :allocation :class :initform '())
   ))

(define-method initialize ((self <type>) initargs)
  (next-method)
  (slot-set! self 'predicate (string->symbol #`",(scheme-name-of self)?"))
  (slot-push! self 'all-types self))

;; Builtin types
(for-each
 (lambda (data)
   (receive (name c-name c-type c-pred unbox . box) (apply values data)
     (make <type> :scheme-name name :c-name c-name :c-type c-type
           :c-predicate c-pred :unboxer unbox
           :boxer (if (null? box) "SCM_OBJ_SAFE" (car box)))))
 '((pair "pair" "ScmObj" "SCM_PAIRP" "")
   (list "list" "ScmObj" "SCM_LISTP" "")
   (vector "vector" "ScmVector*" "SCM_VECTORP" "SCM_VECTOR")
   (string "string" "ScmString*" "SCM_STRINGP" "SCM_STRING")
   (symbol "symbol" "ScmSymbol*" "SCM_SYMBOLP" "SCM_SYMBOL")
   (keyword "keyword" "ScmKeyword*" "SCM_KEYWORDP" "SCM_KEYWORD")
   (identifier "identifier" "ScmIdentifier*" "SCM_IDENTIFIERP" "SCM_IDENTIFIER")
   (boolean "boolean" "int" "SCM_BOOLP" "!SCM_FALSEP" "SCM_MAKE_BOOL")
   (small-integer "small integer" "int" "SCM_INTP" "SCM_INT_VALUE" "SCM_MAKE_INT")
   (small-positive-integer "small positive integer" "unsigned int" "SCM_UINTP" "(unsigned int)SCM_INT_VALUE" "SCM_MAKE_INT")
   (exact "exact integer" "int" "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
   (positive-exact "positive exact integer" "unsigned int" "SCM_UINTEGERP" "Scm_MakeUInteger")
   (real "real" "double" "SCM_REALP" "Scm_GetDouble" "Scm_MakeFlonum")
   (number "number" "ScmObj" "SCM_NUMBERP" "")
   (char "character" "ScmChar" "SCM_CHARP" "SCM_CHAR_VALUE" "SCM_MAKE_CHAR")
   (char-set "char-set" "ScmCharSet*" "SCM_CHARSETP" "SCM_CHARSET")
   (port "port" "ScmPort*" "SCM_PORTP"  "SCM_PORT")
   (input-port "input port" "ScmPort*" "SCM_IPORTP" "SCM_PORT")
   (output-port "output port" "ScmPort*" "SCM_OPORTP" "SCM_PORT")

   (procedure "procedure" "ScmProcedure*" "SCM_PROCEDUREP" "SCM_PROCEDURE")
   (closure "closure" "ScmClosure*" "SCM_CLOSUREP" "SCM_CLOSURE")
   (hash-table "hash table" "ScmHashTable*" "SCM_HASHTABLEP" "SCM_HASHTABLE")
   (class "class" "ScmClass*" "SCM_CLASSP" "SCM_CLASS")
   (module "module" "ScmModule*" "SCM_MODULEP" "SCM_MODULE")
   (thread "thread" "ScmVM*" "SCM_VMP" "SCM_VM")
   (mutex "mutex" "ScmMutex*" "SCM_MUTEXP"  "SCM_MUTEX")
   (condition-variable "condition variable" "ScmConditionVariable*" "SCM_CONDITION_VARIABLE_P"  "SCM_CONDITION_VARIABLE")
   (weak-vector "weak vector" "ScmWeakVector*" "SCM_WEAKVECTORP" "SCM_WEAKVECTOR")
   ))

;; default
(define *scm-type*
  (make <type> :scheme-name 'scheme-object :c-name "scheme object"
        :c-predicate #f :c-type "ScmObj" :unboxer ""))

(define (predicate->type pred)
  (or (find (lambda (type) (eq? (predicate-of type) pred))
            (class-slot-ref <type> 'all-types))
      (error "unknown predicate to assert" pred)))

(define (scheme-name->type name)
  (or (find (lambda (type) (eq? (scheme-name-of type) name))
            (class-slot-ref <type> 'all-types))
      (error "unknown type" name)))

;; process type definition in stub file
;; (this keeps backward compatibility)
(define (process-define-type form)
  (unless (= (length form) 6) (error "malformed define-type:" form))
  (receive (name pred c-type c-pred unbox) (apply values (cdr form))
    (make <type>
      :scheme-name (string->symbol (string-drop-right (symbol->string pred) 1))
      :c-name name
      :c-type c-type
      :c-predicate c-pred
      :unboxer unbox)))

;;===================================================================
;; Stub
;;
;;   - Each declaration makes a stub.
;;   - Stub is used to generate three things: immediate definition,
;;     initialization, and (optionally) declaration.
;;     Those should be implemented by the following methods:
;;        emit-definition
;;        emit-initializer
;;        emit-record

(define-class <stub> ()
  ((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)
   (all-stubs       :allocation :class :initform '())
   ))

(define-method initialize ((self <stub>) initargs)
  (next-method)
  (set! (cpp-condition-of self) (cpp-condition))
  (slot-push! self 'all-stubs self))

(define (get-stubs class)
  (reverse (filter (lambda (s) (is-a? s class))
                   (class-slot-ref <stub> 'all-stubs))))

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

;;--------------------------------------------------------------------
;; Symbol and keyword definition
;;

;; (define-symbol scheme-name c-name [init])

(define-class <csymbol> (<stub>)
  ((initializer    :init-keyword :initializer :accessor initializer-of)
   ))

(define-method emit-definition ((self <csymbol>))
  (with-cpp-condition self
    (emit-static-string (c-name-of self) (scheme-name-of self))
    (f "static ScmObj ~a;" (c-name-of self))
    (newline)))

(define-method emit-initializer ((self <csymbol>))
  (with-cpp-condition self
    (f "  ~a = Scm_Intern(&~a_NAME);" (c-name-of self) (c-name-of self))
    (when (initializer-of self)
      (f "  Scm_Define(module, SCM_SYMBOL(~a), SCM_OBJ(~a));"
         (c-name-of self) (initializer-of self)))))

(define (process-define-symbol form)
  (unless (and (<= 3 (length form) 4)
               (symbol? (cadr form))
               (string? (caddr form)))
    (error "malformed define-symbol:" form))
  (let ((symbol (make <csymbol>
                  :scheme-name (cadr form) :c-name (caddr form)
                  :initializer (if (pair? (cdddr form)) (cadddr form) #f))))
    (emit-definition symbol)
    ))

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

(define-class <ckeyword> (<stub>)
  ()
  )

(define (get-ckeyword key)
  (find (lambda (k) (equal? (x->string key) (x->string (scheme-name-of k))))
        (get-stubs <ckeyword>)))

(define-method emit-definition ((self <ckeyword>))
  (with-cpp-condition self
    (emit-static-string (c-name-of self) (scheme-name-of self))
    (f "static ScmObj ~a;" (c-name-of self))
    (newline)))

(define-method emit-initializer ((self <ckeyword>))
  (with-cpp-condition self
    (f "  ~a = Scm_MakeKeyword(&~a_NAME);" (c-name-of self) (c-name-of self))))

(define (process-define-keyword form)
  (unless (and (= (length form) 3)
               (symbol? (cadr form))
               (string? (caddr form)))
    (error "malformed define-keyword:" form))
  (emit-definition (make <ckeyword>
                     :scheme-name (cadr form) :c-name (caddr form))))
    

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

;; argument
(define-class <arg> ()
  ((name     :init-keyword :name :accessor name-of)
   (c-name   :accessor c-name-of)
   (scm-name :accessor scm-name-of)
   (count    :init-keyword :count :accessor count-of)
   (c-type   :initform *scm-type* :accessor c-type-of)
   (category :init-keyword :category :initform :required :accessor category-of)
   (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 "#<arg ~a ~a>" (name-of self) (category-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")))

(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))))
    (unless arg (error "assertion for unknown arg:" form))
    (set! (c-type-of arg) (predicate->type op))))

;; (define-cproc scheme-name (argspec)
;;   assertions ...
;;   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 (process-define-cproc form)
  (unless (and (>= (length form) 4)
               (symbol? (cadr form))
               (list? (caddr form)))
    (error "malformed define-cproc:" form))
  (receive (args nreqs nopts rest?)
      (process-cproc-args (caddr form))
    (let ((cproc (make <cproc>
                   :scheme-name (cadr form)
                   :c-name (get-c-name *file-prefix* (cadr form))
                   :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 (cdddr form))
      (emit-definition cproc)
      (emit-inliner cproc)
      (emit-record cproc))))

;; 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 <required-arg>
                                 :name (car specs) :count 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 <optional-arg>
                                 :name (car specs) :count (+ nreqs nopts))
                           args)
                     nreqs
                     (+ nopts 1)))
          ((and (list? (car specs)) (= (length (car specs)) 2))
           (optional (cdr specs)
                     (cons (make <optional-arg> :default (cadar specs)
                                 :name (caar specs) :count (+ nreqs nopts))
                           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 <keyword-arg>
                                :name (car specs) :count (+ nreqs nopts))
                          args)
                    nreqs
                    (+ nopts 1)))
          ((and (list? (car specs)) (= (length (car specs)) 2))
           (keyword (cdr specs)
                    (cons (make <keyword-arg> :default (cadar specs)
                                :name (caar specs) :count (+ nreqs nopts))
                          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 <rest-arg>
                                :name (car specs) :count (+ 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))
                (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))
        (emit-definition setter)
        (emit-inliner setter)
        (emit-record setter)))
    )))

;;; emit code

(define-method emit-definition ((cproc <cproc>))
  (with-cpp-condition 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>))
  (with-cpp-condition 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 (c-type-of arg)) (c-name-of arg)))

(define (emit-arg-unbox arg)
  (let* ((class (class-of arg))
         (type  (c-type-of arg))
         (cname (c-name-of arg))
         (sname (scm-name-of arg))
         (count (count-of arg))
         (tname (c-name-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 (c-name-of (c-keyword-of arg))
         (scheme-constant->c-constant (default-of arg))))
     ((eq? class <rest-arg>)
      (f "  ~a = SCM_OPTARGS;" sname)))
    (when pred
      (f "  if (!~a(~a)) Scm_Error(\"~a required, but got %S\", ~a);"
         pred sname tname sname))
    (if unbox
        (f "  ~a = ~a(~a);" cname unbox sname)
        (f "  ~a = ~a;" cname sname))))

(define (ensure-keyword-arg arg)
  (let ((c-key (get-ckeyword (name-of arg))))
    (if c-key
        (set! (c-keyword-of arg) c-key)
        (let ((c-key (make <ckeyword>
                           :scheme-name (name-of arg)
                           :c-name (get-c-name "KEYARG_" (name-of arg)))))
          (set! (c-keyword-of arg) c-key)
          (emit-definition c-key)))))

(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)" inliner)
    ))

(define (emit-inliner-call cproc insn)
  (f "  return Scm_CompileInliner(form, env, ~a, ~a, ~a, \"~a\");"
     (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)
  (with-cpp-condition 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
         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>))
  (with-cpp-condition self
   (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>))
  (with-cpp-condition self
    (f "  Scm_InitBuiltinGeneric(&~a, ~s, module);"
       (c-name-of self) (symbol->string (scheme-name-of self)))
    (next-method)))

(define (process-define-cgeneric form)
  (unless (and (>= (length form) 3)
               (symbol? (cadr form))
               (string? (caddr form)))
    (error "malformed define-cgeneric"))
  (let ((gf (make <cgeneric> :scheme-name (cadr form) :c-name (caddr form))))
    (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))))
              (cdddr form))
    (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") ]
;;    assertions ...
;;    body ...)

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

(define (process-define-cmethod form)
  (unless (>= (length form) 4) (error "malformed define-cmetihod:" form))
  (let ((scheme-name (cadr form))
        (arglist     (caddr form))
        (body        (cdddr form)))
    (unless (symbol? scheme-name)
      (error "malformed define-cmethod:" form))
    (receive (args specializers numargs have-optarg?)
        (parse-specialized-args arglist)
      (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))))
        (emit-definition method)))
    ))

(define-method emit-definition ((method <cmethod>))
  (with-cpp-condition method
    (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) (c-name-of method))
    (newline)
    ))

(define-method emit-initializer ((method <cmethod>))
  (with-cpp-condition method
    (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 <rest-arg> :name arglist :count (length args))
                         args)
                   (cons "Scm_ListClass" specs)
                   (length args) #t))
          ((not (pair? arglist)) (badlist))
          ((symbol? (car arglist))
           (loop (cdr arglist)
                 (cons (make <required-arg>
                             :name (car arglist) :count (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 <required-arg>
                                  :name (caar arglist) :count (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.

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

(define-class <cclass> (<stub>)
  ((cpa       :init-keyword :cpa       :init-value '()
              :accessor cpa-of)
   (c-type    :init-keyword :c-type    :accessor c-type-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)
   ))

(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)
   (type        :init-keyword :type   :accessor type-of :init-value 'scheme-object)
   (getter      :init-keyword :getter :accessor getter-of :init-value #t)
   (setter      :init-keyword :setter :accessor setter-of :init-value #t)
   ))

(define (process-define-cclass form)
  (unless (>= (length form) 6)
    (error "malformed define-cclass" form))
  (receive (_ scm-name c-type c-name cpa slot-spec . more) (apply values form)
    (unless (and (symbol? scm-name) (string? c-name) (list? cpa) (list? slot-spec))
      (error "malformed define-cclass" form))
    (let* ((allocator (cond ((assq 'allocator more) => cadr) (else #f)))
           (printer   (cond ((assq 'printer more) => cadr) (else #f)))
           (cclass (make <cclass>
                     :scheme-name scm-name :c-type c-type :c-name c-name 
                     :cpa cpa
                     :allocator allocator :printer printer)))
      (set! (slot-spec-of cclass) (process-cclass-slots cclass slot-spec))
      (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)
  (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), ,(c-type-size-of self), module);"))

;; 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) 'scheme-object))
                (c-name (get-keyword :c-name (cdr spec) (get-c-name "" name)))
                (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
             :type (scheme-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)))
    (print #`"static ScmObj ,(slot-getter-name slot)(,(c-type-of (cclass-of slot)) *obj)")
    (print "{")
    (if (string? (getter-of slot))
        (print (getter-of slot))
        (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)))
    (print #`"static void ,(slot-setter-name slot)(,(c-type-of (cclass-of slot)) *obj, ScmObj value)")
    (print "{")
    (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)))
          (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>))
  (with-cpp-condition self
    (for-each display (code-of self))))

(define (process-initcode form)
  (make <initcode> :code (cdr form)))

;;---------------------------------------------------------------
;; 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 (char-downcase 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 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 (process-if form)
  (unless (= 3 (length form))
    (error "malformed if: " form))
  (parameterize ((cpp-condition (cadr form)))
    (parse-form (caddr form))))

(define (process-begin form)
  (let loop ((f (cdr form)))
    (unless (null? f)
      (parse-form (car f))
      (loop (cdr f)))))

(define *syntax-table*
  `((define-cproc     . ,process-define-cproc)
    (define-symbol    . ,process-define-symbol)
    (define-keyword   . ,process-define-keyword)
    (define-type      . ,process-define-type)
    (define-cgeneric  . ,process-define-cgeneric)
    (define-cmethod   . ,process-define-cmethod)
    (define-cclass    . ,process-define-cclass)
    (if               . ,process-if)
    (begin            . ,process-begin)
    (initcode         . ,process-initcode)
    ))

(define (parse-form form)
  (cond ((string? form) (print form))
        ((not (pair? form))
         (error "bad form:" form))
        ((assq (car form) *syntax-table*)
         => (lambda (p) ((cdr p) form)))
        (else (error "bad form:" form))))

(define-method emit-initializer ((name <string>))
  (f "void Scm_Init_~a(ScmModule *module)" name)
  (print "{")
  (for-each emit-initializer (get-stubs <cclass>))
  (for-each emit-initializer (get-stubs <cproc>))
  (for-each emit-initializer (get-stubs <csymbol>))
  (for-each emit-initializer (get-stubs <ckeyword>))
  (for-each emit-initializer (get-stubs <cgeneric>))
  (for-each emit-initializer (get-stubs <cmethod>))
  (for-each emit-initializer (get-stubs <initcode>))
  (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 ()
              (let loop ((form (read)))
                (unless (eof-object? form)
                (parse-form form)
                (loop (read))))))
          (emit-initializer (get-c-name "" prefix))
          )))
    )
  0)

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


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