1: ;;;
    2: ;;; genstub - simple stub generator for Gauche
    3: ;;;  
    4: ;;;   Copyright (c) 2000-2007 Shiro Kawai  <shiro@acm.org>
    5: ;;;   
    6: ;;;   Redistribution and use in source and binary forms, with or without
    7: ;;;   modification, are permitted provided that the following conditions
    8: ;;;   are met:
    9: ;;;   
   10: ;;;   1. Redistributions of source code must retain the above copyright
   11: ;;;      notice, this list of conditions and the following disclaimer.
   12: ;;;  
   13: ;;;   2. Redistributions in binary form must reproduce the above copyright
   14: ;;;      notice, this list of conditions and the following disclaimer in the
   15: ;;;      documentation and/or other materials provided with the distribution.
   16: ;;;  
   17: ;;;   3. Neither the name of the authors nor the names of its contributors
   18: ;;;      may be used to endorse or promote products derived from this
   19: ;;;      software without specific prior written permission.
   20: ;;;  
   21: ;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22: ;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23: ;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   24: ;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   25: ;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   26: ;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
   27: ;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   28: ;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   29: ;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
   30: ;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   31: ;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   32: ;;;  
   33: ;;;  $Id: genstub,v 1.145 2007/09/13 12:30:27 shirok Exp $
   34: ;;;
   35: 
   36: (use srfi-1)
   37: (use srfi-2)
   38: (use srfi-13)
   39: (use gauche.parseopt)
   40: (use gauche.parameter)
   41: (use gauche.mop.instance-pool)
   42: (use gauche.sequence)
   43: (use gauche.cgen)
   44: (use gauche.cgen.cise)
   45: (use file.util)
   46: (use util.match)
   47: (use text.tree)
   48: (use text.tr)
   49: 
   50: (define *file-prefix* "")
   51: (define *insert-sharp-line* #t)         ;if #t, output #line directive
   52: (define *unbound* (cons #f #f))         ;placeholder for unbound value
   53: 
   54: (define c++-exception-used? (make-parameter #f))
   55: 
   56: (define (f fmt . args) (apply format #t fmt args) (newline))
   57: (define (p . args)     (apply print args))
   58: 
   59: ;; NB: a small experiment to see how I feel this...
   60: ;;  [@ a b c d] => (ref (ref (ref a b) c) d)
   61: ;; In string interpolations I have to use ,(@ ...) instead of ,[@ ...], for
   62: ;; the previous versions of interpolation code doesn't like #`",[...]".
   63: ;; Ideally this should be a compiler-macro (we can't make it a macro,
   64: ;; for we want to say (set! [@ x'y] val).
   65: (define @
   66:   (getter-with-setter
   67:    (case-lambda
   68:      ((obj selector) (ref obj selector))
   69:      ((obj selector . more) (apply @ (ref obj selector) more)))
   70:    (case-lambda
   71:      ((obj selector val) ((setter ref) obj selector val))
   72:      ((obj selector selector2 . rest)
   73:       (apply (setter ref) (ref obj selector) selector2 rest)))))
   74: ;; end experiment
   75: 
   76: ;; Summary of forms
   77: ;;
   78: ;;   define-type name c-type [desc c-predicate unboxer boxer]
   79: ;;
   80: ;;      Register a new type to be recognized.  This is rather a declaration
   81: ;;      than definition; no C code will be generated directly by this form.
   82: ;;
   83: ;;   define-cproc name (args ...) body ...
   84: ;;
   85: ;;      Create a subr function.  Body can be:
   86: ;;        (code <C-code> ...)
   87: ;;             <C-code> is inserted at this position.  Useful to insert
   88: ;;             extra code before 'call' or 'expr' spec.
   89: ;;        (call [<rettype>] <C-function-name>)
   90: ;;             Calls C-function.  If <rettype> is omitted, C-function
   91: ;;             is assumed to return ScmObj.  Otherwise, a boxer of
   92: ;;             <rettype> is used.  As a special case, if <rettype> is
   93: ;;             <void>, the return value of C-function is ignored and
   94: ;;             the function returns #<undef>.
   95: ;;        (expr [<rettype>] <C-expr>) :
   96: ;;             <C-expr> must be a C expression of type <rettype>.  The
   97: ;;             value of C-expr is boxed and returned.  <void> isn't allowed
   98: ;;             as <rettype> (you can use 'body' directive).
   99: ;;        (body [<rettype>] <C-code> ...) :
  100: ;;             C-code becomes the body of the stub function.  In it,
  101: ;;             the code must assign to a variable SCM_RESULT.  The stub
  102: ;;             generator boxes the value and returns it.  (If <rettype>
  103: ;;             is <void>, though, C-code shouldn't assign SCM_RESULT.
  104: ;;             The generated function returns #<undef>.
  105: ;;        (body (<rettype> ...) <C-code> ...) :
  106: ;;             Procedure yields more than one value.  C variables
  107: ;;             SCM_RESULT0, SCM_RESULT1, ... are defined to receive the
  108: ;;             results.
  109: ;;        (setter <setter-name>) : specfy setter.  <setter-name> should
  110: ;;             be a cproc name defined in the same stub file
  111: ;;        (setter (args ...) body ...) : specify setter anonymously.
  112: ;;        (catch (<decl> <C-stmt> ...) ...) : when writing a stub
  113: ;;             for C++ function that may throw an exception, use this spec
  114: ;;             to ensure the exception will be caught and converted to
  115: ;;             Gauche error condition.
  116: ;;
  117: ;;        a string : becomes the body of C code.  DEPRECATED.
  118: ;;        (return [<rettype>] <C-function-name>)  same as 'call'.  DEPRECATED.
  119: ;;
  120: ;;   define-cgeneric name c-name property-clause ...)
  121: ;;
  122: ;;      Defines generic function.   C-name specifies a C variable name
  123: ;;      that keeps the generic function structure.  One or more of
  124: ;;      the following clauses can appear in property-clause ...:
  125: ;;        (extern) : makes c-name visible from other file (i.e. do
  126: ;;             not define the structure as 'static').
  127: ;;        (fallback "fallback") : specifies the fallback function.
  128: ;;        (setter . setter-spec) : specifies the setter.
  129: ;;
  130: ;;   define-cmethod name (arg ...) body ...
  131: ;;
  132: ;;   define-cclass scheme-name [qualifier] c-typename c-class-name cpa
  133: ;;      (slot-spec ...)
  134: ;;      property-clause ...
  135: ;;
  136: ;;   define-symbol scheme-name [c-name]
  137: ;;      Defines a Scheme symbol.  No Scheme binding is created.
  138: ;;      When c-name is given, the named C variable points to the
  139: ;;      created ScmSymbol.
  140: ;;
  141: ;;   define-variable scheme-name initializer
  142: ;;      Defines a Scheme variable.
  143: ;;
  144: ;;   define-constant scheme-name initializer
  145: ;;      Defines a Scheme constant.
  146: ;;
  147: ;;   define-enum name
  148: ;;      A define-constant Specialized for enum values.
  149: ;;
  150: ;;   define-enum-conditionally name
  151: ;;      Abbreviation of (if "defined(name)" (define-enum name))
  152: ;;
  153: ;;   define-cise-stmt name clause ...
  154: ;;   define-cise-expr name clause ...
  155: ;;      Cise macro definitions (see gauche.cgen.cise).
  156: ;;
  157: ;;   initcode <c-code>
  158: ;;      Insert <c-code> literally in the initialization function
  159: ;;
  160: ;;   begin <form> ...
  161: ;;      Treat each <form> as if they are toplevel stub forms.
  162: ;;
  163: ;;   <string>
  164: ;;      The string is inserted into the generated C body.
  165: ;;
  166: ;;   eval* <scheme-expr> ...
  167: ;;      Evaluates Scheme expressions inside a temporary anonymous
  168: ;;      module.  If the last expression returns a string or a list,
  169: ;;      it is processed again as a toplevel stub form.
  170: ;;      NB: This is highly experimental feature even the author is
  171: ;;      skeptical about.  Do not use this.
  172: 
  173: ;;===================================================================
  174: ;; Form parsers
  175: ;;
  176: 
  177: ;; just a device to register handlers of syntax elements.
  178: (define-class <form-parser> (<instance-pool-mixin>)
  179:   ((name    :init-keyword :name)
  180:    (args    :init-keyword :args)
  181:    (handler :init-keyword :handler)))
  182: 
  183: (define-macro (define-form-parser name args . body)
  184:   `(make <form-parser>
  185:      :name ',name
  186:      :args ',args
  187:      :handler (lambda ,args ,@body)))
  188: 
  189: (define-method invoke ((self <form-parser>) form)
  190:   (define (badform)
  191:     (errorf "malformed ~a: ~s" [@ self'name] form))
  192:   (let1 args
  193:       ;; need to check if given form matches args
  194:       (let loop ((llist [@ self'args])
  195:                  (form  (cdr form)))
  196:         (cond ((null? llist)
  197:                (if (null? form) '() (badform)))
  198:               ((pair? llist)
  199:                (if (null? form)
  200:                  (badform)
  201:                  (cons (car form) (loop (cdr llist) (cdr form)))))
  202:               (else form)))
  203:     (apply [@ self'handler] args)))
  204: 
  205: (define (parse-form form)
  206:   (cond ((string? form) (cgen-body form))
  207:         ((not (pair? form)) (error "bad form:" form))
  208:         ((find (lambda (p) (eq? (car form) [@ p'name]))
  209:                (instance-pool->list <form-parser>))
  210:          => (cut invoke <> form))
  211:         (else (error "bad form:" form))))
  212: 
  213: ;; meta stuff
  214: (define-form-parser define-cise-stmt args
  215:   (eval `(define-cise-stmt ,@args) (current-module)))
  216: 
  217: (define-form-parser define-cise-expr args
  218:   (eval `(define-cise-expr ,@args) (current-module)))
  219: 
  220: ;;===================================================================
  221: ;; Type handling
  222: ;;
  223: 
  224: ;; Stub's type system doesn't exactly match Scheme's, since stub has
  225: ;; to handle internal guts of Scheme implementations as well as
  226: ;; C type systems.  We call the types used in the stub generator
  227: ;; "stub type", apart from "C type" and "Scheme type".
  228: ;;
  229: ;; For each existing conversion between C type and Scheme type, a stub
  230: ;; type is defined.  For types that has one-to-one mapping between
  231: ;; C and Scheme (such as most aggregate types, for example, Scheme's
  232: ;; <u32vector> and C's ScmU32Vector*), there is only one stub type,
  233: ;; which uses the same name as the Scheme's.  There are some stub types
  234: ;; that reflects C type variations: <int>, <int8>, <int16>, <int32>,
  235: ;; <uint>, <uint8>, <uint16>, <uint32> --- these are mapped to Scheme's
  236: ;; integer, but the range limit is taken into account.   <fixnum>
  237: ;; refers to the integers that can be represented in an immediate integer.
  238: ;; Note that a stub type <integer> corresponds to Scheme's exact integers,
  239: ;; but it is mapped to C's ScmObj, since C's integer isn't enough to
  240: ;; represent all of Scheme integers.   A stub type <void> is
  241: ;; used to denote a procedure return type.
  242: ;;
  243: ;; Each stub type has a "boxer" and an "unboxer".  A boxer is a C name
  244: ;; of a function or a macro that takes an object of C type of the stub
  245: ;; type and returns a Scheme object.  An unboxer is a C name of a function
  246: ;; or a macro that takes Scheme object and checks its vailidy, then
  247: ;; returns a C object of the C type or throws an error.
  248: ;;
  249: ;; Here's a summary of primitive stub types and the mapping each one
  250: ;; represents.
  251: ;;
  252: ;;   stub type    Scheme       C           Notes
  253: ;;  -----------------------------------------------------------------
  254: ;;   <fixnum>     <integer>    int         Integers within fixnum range
  255: ;;   <integer>    <integer>    ScmObj      Any exact integers
  256: ;;   <real>       <real>       double
  257: ;;   <number>     <number>     ScmObj      Any numbers
  258: ;;
  259: ;;   <int>        <integer>    int         Integers representable in C
  260: ;;   <int8>       <integer>    int
  261: ;;   <int16>      <integer>    int
  262: ;;   <int32>      <integer>    int
  263: ;;   <short>      <integer>    short
  264: ;;   <long>       <integer>    long
  265: ;;   <uint>       <integer>    uint        Integers representable in C
  266: ;;   <uint8>      <integer>    uint
  267: ;;   <uint16>     <integer>    uint
  268: ;;   <uint32>     <integer>    uint
  269: ;;   <ushort>     <integer>    ushort
  270: ;;   <ulong>      <integer>    ulong
  271: ;;   <float>      <real>       float       Unboxed value casted to float
  272: ;;   <double>     <real>       double      Alias of <real>
  273: ;;
  274: ;;   <boolean>    <boolean>    int         Boolean value
  275: ;;   <char>       <char>       ScmChar     NB: not a C char
  276: ;;
  277: ;;   <void>       -            void        (Used only as a return type.
  278: ;;                                          Scheme function returns #<undef>)
  279: ;;
  280: ;;   <const-cstring> <string>  const char* For arguments, string is unboxed
  281: ;;                                         by Scm_GetStringConst.
  282: ;;                                         For return values, C string is boxed
  283: ;;                                         by SCM_MAKE_STR_COPYING.
  284: ;;
  285: ;;   <pair>       <pair>       ScmPair*
  286: ;;   <list>       <list>       ScmObj
  287: ;;   <string>     <string>     ScmString*
  288: ;;   <symbol>     <symbol>     ScmSymbol*
  289: ;;   <vector>     <vector>     ScmVector*
  290: ;;    :
  291: ;;
  292: ;; Pointer types can be qualified as 'maybe', by adding '?' at the
  293: ;; end of type name, e.g. '<string>?'.
  294: ;; If 'maybe' type appears as an argument type, the argument accepts #f
  295: ;; as well as the specified type, and translates #f to NULL.  If 'maybe'
  296: ;; type appears as the return type, the result of C expression can be NULL
  297: ;; and the stub translates it to #f.
  298: 
  299: ;; Stub type definition
  300: (define-class <type> (<instance-pool-mixin>)
  301:   ((name        :init-keyword :name)
  302:    ;; ::<symbol> - name of this stub type.
  303:    (c-type      :init-keyword :c-type)
  304:    ;; ::<string> - C type name this stub type represents
  305:    (description :init-keyword :description)
  306:    ;; ::<string> - used in the type error message
  307:    (c-predicate :init-keyword :c-predicate)
  308:    ;; ::<string> - name of a C function (macro) to find out the given
  309:    ;;              ScmObj has a valid type for this stub type.
  310:    (unboxer     :init-keyword :unboxer)
  311:    ;; ::<string> - name of a C function (macro) that takes Scheme object
  312:    ;;              and returns a C object.
  313:    (boxer       :init-keyword :boxer :init-value "SCM_OBJ_SAFE")
  314:    ;; ::<string> - name of a C function (macro) that takes C object
  315:    ;;              and returns a Scheme Object.
  316:    (maybe       :init-keyword :maybe       :init-value #f)
  317:    ;; ::<type>? - base type, if this is 'maybe' qualified type.
  318:    ))
  319: 
  320: (define (find-type-by-name name)
  321:   (or (find (lambda (type) (eq? [@ type'name] name))
  322:             (instance-pool->list <type>))
  323:       ;; when 'maybe' qualified type is used for the first time, we
  324:       ;; create it from the base type.
  325:       (and-let* ((m (#/\?$/ (symbol->string name)))
  326:                  (basename (string->symbol (m 'before)))
  327:                  (basetype (find-type-by-name basename)))
  328:         (make <type> :name name :c-type [@ basetype'c-type]
  329:               :description #`",(@ basetype'description) or #f"
  330:               :c-predicate [@ basetype'c-predicate]
  331:               :unboxer     [@ basetype'unboxer]
  332:               :boxer       [@ basetype'boxer]
  333:               :maybe       basetype))))
  334: 
  335: (define (name->type name)
  336:   (or (find-type-by-name name) (error "unknown type" name)))
  337: 
  338: ;; define-type name c-type [desc c-predicate unboxer boxer]
  339: ;;
  340: ;;   Creates a new stub type for existing scheme type.
  341: 
  342: (define-form-parser define-type args
  343:   (define (strip<> name) (string-trim-both name #[<>]))
  344:   (define (default-cpred name)
  345:     (if (string-index name #\-)
  346:       (string-append "SCM_"
  347:                      (string-tr (strip<> name) "a-z-" "A-Z_")
  348:                      "_P")
  349:       #`"SCM_,(string-upcase (strip<> name))P"))
  350:   (define (default-unbox name)
  351:     #`"SCM_,(string-tr (strip<> name) \"a-z-\" \"A-Z_\")")
  352:   (define (default-box name)
  353:     #`"SCM_MAKE_,(string-tr (strip<> name) \"a-z-\" \"A-Z_\")")
  354: 
  355:   (unless (<= 2 (length args) 6)
  356:     (error "malformed define-type:" args))
  357:   (let-optionals* args ((name #f)
  358:                         (c-type #f)
  359:                         (desc   #f)
  360:                         (c-pred #f)
  361:                         (unbox  #f)
  362:                         (box    #f))
  363:     (make <type>
  364:       :name name :c-type c-type
  365:       :description (or desc (x->string name))
  366:       :c-predicate (or c-pred (default-cpred (x->string name)))
  367:       :unboxer     (or unbox (default-unbox (x->string name)))
  368:       :boxer       (or box "SCM_OBJ_SAFE"))))
  369: 
  370: ;; Returns C expr
  371: (define (box-expr type c-expr)
  372:   (if [@ type'maybe]
  373:     #`"SCM_MAKE_MAYBE(,(@ type'boxer),, ,c-expr)"
  374:     #`",(@ type'boxer)(,c-expr)"))
  375: 
  376: (define (unbox-expr type c-expr)
  377:   (if [@ type'maybe]
  378:     #`"SCM_MAYBE(,(@ type'unboxer),, ,c-expr)"
  379:     #`",(@ type'unboxer)(,c-expr)"))
  380: 
  381: (define (pred-expr type c-expr)
  382:   (if [@ type'maybe]
  383:     #`"SCM_MAYBE_P(,(@ type'c-predicate),, ,c-expr)"
  384:     #`",(@ type'c-predicate)(,c-expr)"))
  385: 
  386: (define (return-stmt expr)
  387:   #`"SCM_RETURN(,expr);")
  388: 
  389: ;; Builtin types
  390: (for-each
  391:  parse-form
  392:  '(;; Numeric types
  393:    (define-type <fixnum>  "int" "small integer"
  394:      "SCM_INTP" "SCM_INT_VALUE" "SCM_MAKE_INT")
  395:    (define-type <integer> "ScmObj" "exact integer"
  396:      "SCM_EXACTP" "")
  397:    (define-type <real>    "double" "real number"
  398:      "SCM_REALP" "Scm_GetDouble" "Scm_MakeFlonum")
  399:    (define-type <number>  "ScmObj" "number"
  400:      "SCM_NUMBERP" "")
  401:    (define-type <int>     "int" "C integer"
  402:      "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
  403:    (define-type <long>    "long" "C long integer"
  404:      "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
  405:    (define-type <short>   "short" "C short integer"
  406:      "SCM_INTP" "(short)SCM_INT_VALUE" "SCM_MAKE_INT")
  407:    (define-type <int8>    "int" "C integer"
  408:      "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
  409:    (define-type <int16>   "int" "C integer"
  410:      "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
  411:    (define-type <int32>   "int" "C integer"
  412:      "SCM_EXACTP" "Scm_GetInteger" "Scm_MakeInteger")
  413:    (define-type <uint>    "u_int" "C integer"
  414:      "SCM_UINTEGERP" "Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
  415:    (define-type <ulong>   "u_long" "C integer"
  416:      "SCM_UINTEGERP" "Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
  417:    (define-type <ushort>  "u_short" "C short integer"
  418:      "SCM_EXACTP" "(unsigned short)Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
  419:    (define-type <uint8>   "u_int" "C integer"
  420:      "SCM_UINTP" "Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
  421:    (define-type <uint16>  "u_int" "C integer"
  422:      "SCM_UINTP" "Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
  423:    (define-type <uint32>  "u_int" "C integer"
  424:      "SCM_UINTEGERP" "Scm_GetIntegerU" "Scm_MakeIntegerFromUI")
  425:    (define-type <float>   "float" "real number"
  426:      "SCM_REALP" "(float)Scm_GetDouble" "Scm_MakeFlonum")
  427:    (define-type <double>  "double" "real number"
  428:      "SCM_REALP" "Scm_GetDouble" "Scm_MakeFlonum")
  429:    
  430:    ;; Basic immediate types
  431:    (define-type <boolean> "int" "boolean"
  432:      "SCM_BOOLP"   "SCM_BOOL_VALUE" "SCM_MAKE_BOOL")
  433:    (define-type <char>    "ScmChar" "character"
  434:      "SCM_CHARP" "SCM_CHAR_VALUE" "SCM_MAKE_CHAR")
  435:    (define-type <void>    "void" "void"
  436:      ""      ""  "SCM_VOID_RETURN_VALUE")
  437:    (define-type <top>     "ScmObj" "scheme object" "" "")
  438: 
  439:    ;; C string
  440:    (define-type <const-cstring> "const char *" "const C string"
  441:      "SCM_STRINGP" "SCM_STRING_CONST_CSTRING" "SCM_MAKE_STR_COPYING")
  442: 
  443:    ;; Aggregate types
  444:    (define-type <pair> "ScmPair*" "pair"
  445:      "SCM_PAIRP" "SCM_PAIR" "SCM_OBJ")
  446:    (define-type <list> "ScmObj" "list"
  447:      "SCM_LISTP" "")
  448:    (define-type <vector> "ScmVector*" "vector"
  449:      "SCM_VECTORP" "SCM_VECTOR")
  450:    (define-type <string> "ScmString*" "string"
  451:      "SCM_STRINGP" "SCM_STRING")
  452:    (define-type <symbol> "ScmSymbol*" "symbol"
  453:      "SCM_SYMBOLP" "SCM_SYMBOL")
  454:    (define-type <keyword> "ScmKeyword*" "keyword"
  455:      "SCM_KEYWORDP" "SCM_KEYWORD")
  456:    (define-type <identifier> "ScmIdentifier*" "identifier"
  457:      "SCM_IDENTIFIERP" "SCM_IDENTIFIER")
  458:    (define-type <char-set> "ScmCharSet*" "char-set"
  459:      "SCM_CHARSETP" "SCM_CHARSET")
  460:    (define-type <regexp> "ScmRegexp*" "regexp"
  461:      "SCM_REGEXPP" "SCM_REGEXP")
  462:    (define-type <regmatch> "ScmRegMatch*" "regmatch"
  463:      "SCM_REGMATCHP" "SCM_REGMATCH")
  464:    (define-type <port> "ScmPort*" "port"
  465:      "SCM_PORTP" "SCM_PORT")
  466:    (define-type <input-port> "ScmPort*" "input port"
  467:      "SCM_IPORTP" "SCM_PORT")
  468:    (define-type <output-port> "ScmPort*" "output port"
  469:      "SCM_OPORTP" "SCM_PORT")
  470:    (define-type <procedure> "ScmProcedure*" "procedure"
  471:      "SCM_PROCEDUREP" "SCM_PROCEDURE")
  472:    (define-type <closure> "ScmClosure*" "closure"
  473:      "SCM_CLOSUREP" "SCM_CLOSURE")
  474:    (define-type <promise> "ScmPromise*" "promise"
  475:      "SCM_PROMISEP" "SCM_PROMISE")
  476:    (define-type <hash-table> "ScmHashTable*" "hash table"
  477:      "SCM_HASH_TABLE_P" "SCM_HASH_TABLE")
  478:    (define-type <tree-map> "ScmTreeMap*" "tree map"
  479:      "SCM_TREE_MAP_P" "SCM_TREE_MAP")
  480:    (define-type <class> "ScmClass*" "class"
  481:      "SCM_CLASSP" "SCM_CLASS")
  482:    (define-type <method> "ScmMethod*" "method"
  483:      "SCM_METHODP" "SCM_METHOD")
  484:    (define-type <module> "ScmModule*" "module"
  485:      "SCM_MODULEP" "SCM_MODULE")
  486:    (define-type <thread> "ScmVM*" "thread"
  487:      "SCM_VMP" "SCM_VM")
  488:    (define-type <mutex> "ScmMutex*" "mutex"
  489:      "SCM_MUTEXP" "SCM_MUTEX")
  490:    (define-type <condition-variable> "ScmConditionVariable*"
  491:      "condition variable" "SCM_CONDITION_VARIABLE_P" "SCM_CONDITION_VARIABLE")
  492:    (define-type <weak-vector> "ScmWeakVector*" "weak vector"
  493:      "SCM_WEAK_VECTOR_P" "SCM_WEAK_VECTOR")
  494:    (define-type <weak-hash-table> "ScmWeakHashTable*" "weak hash table"
  495:      "SCM_WEAK_HASH_TABLE_P" "SCM_WEAK_HASH_TABLE")
  496:    (define-type <compiled-code> "ScmCompiledCode*" "compiled code"
  497:      "SCM_COMPILED_CODE_P" "SCM_COMPILED_CODE")
  498:    (define-type <foreign-pointer> "ScmForeignPointer*" "foreign pointer"
  499:      "SCM_FOREIGN_POINTER_P" "SCM_FOREIGN_POINTER")
  500:    ))
  501: 
  502: ;; default
  503: (define *scm-type* (name->type '<top>))
  504: 
  505: ;;===================================================================
  506: ;; Stub : base class of declarations
  507: ;;
  508: 
  509: (define-class <stub> (<cgen-node>)
  510:   ((scheme-name :init-keyword :scheme-name :init-form #f)
  511:    (c-name      :init-keyword :c-name)
  512:    ))
  513: 
  514: (define (get-stubs class)
  515:   (filter (cut is-a? <> class) (cgen-unit-toplevel-nodes (cgen-current-unit))))
  516: 
  517: ;;===================================================================
  518: ;; Literals
  519: ;;
  520: 
  521: ;; we define some special literals
  522: 
  523: ;; A special literal to include raw C expr in place of Scheme literal
  524: (define-class <special-literal> () ()) ;; dummy class.  not really used.
  525: (define-cgen-literal <raw-c-literal> <special-literal>
  526:   ()
  527:   (static (self) #t))
  528: 
  529: ;; NB: (make <special-literal>) is just to fake the literal hash.
  530: (define (make-literal obj . args)
  531:   (match obj
  532:     (('c (? string? c-expr))
  533:      (make <raw-c-literal> :value (make <special-literal>) :c-name c-expr))
  534:     (('current-input-port)
  535:      (make <raw-c-literal>
  536:        :value (make <special-literal>) :c-name "SCM_OBJ(SCM_CURIN)"))
  537:     (('current-output-port)
  538:      (make <raw-c-literal>
  539:        :value (make <special-literal>) :c-name "SCM_OBJ(SCM_CUROUT)"))
  540:     (('current-error-port)
  541:      (make <raw-c-literal>
  542:        :value (make <special-literal>) :c-name "SCM_OBJ(SCM_CURERR)"))
  543:     (_ (cgen-literal obj))))
  544: 
  545: ;;===================================================================
  546: ;; Arg
  547: ;;
  548: 
  549: ;; <arg> is used to keep procedure's argument information.
  550: (define-class <arg> ()
  551:   ((name     :init-keyword :name)
  552:    ;; - <symbol>: the name as appears in the Scheme argument list.
  553:    (c-name)
  554:    ;; - <string>: C variable name for unboxed value
  555:    (scm-name)
  556:    ;; - <string>: C variable name to hold boxed ScmObj value
  557:    (count    :init-keyword :count)
  558:    ;; - <integer>: This arg is count-th in the procedure
  559:    (type     :init-keyword :type)
  560:    ;; - <type>: Stub type of this arg
  561:    (default  :init-keyword :default :init-value #f)
  562:    ;; - #f or <cgen-literal> : default value for optiona/keyword arg
  563:    ))
  564: 
  565: (define-class <required-arg> (<arg>) ())
  566: (define-class <optional-arg> (<arg>) ())
  567: (define-class <keyword-arg>  (<arg>) (keyword))
  568: (define-class <rest-arg>     (<arg>) ())
  569: 
  570: (define-method write-object ((self <arg>) out)
  571:   (format out "#<~a ~a>" (class-of self) [@ self'name]))
  572: 
  573: (define-method initialize ((self <arg>) initargs)
  574:   (next-method)
  575:   (set! [@ self'c-name]   (get-c-name "" [@ self'name]))
  576:   (set! [@ self'scm-name] (string-append [@ self'c-name] "_scm")))
  577: 
  578: (define-method initialize ((self <keyword-arg>) initargs)
  579:   (next-method)
  580:   (set! [@ self'keyword] (cgen-literal (make-keyword [@ self'name]))))
  581: 
  582: ;;===================================================================
  583: ;; Symbol and keyword definition
  584: ;;
  585: 
  586: ;;-------------------------------------------------------------------
  587: ;; (define-symbol scheme-name c-name)
  588: 
  589: (define-form-parser define-symbol (name c-name . maybe-init)
  590:   (check-arg symbol? name)
  591:   (check-arg string? c-name)
  592:   (let1 literal (make-literal name :c-name c-name)
  593:     (cgen-decl #`"#define ,c-name (,(cgen-c-name literal))")
  594:     (cgen-add! literal)))
  595: 
  596: ;;-------------------------------------------------------------------
  597: ;; (define-variable scheme-name init &keyword c-name)
  598: ;; (define-constant scheme-name init &keyword c-name)
  599: ;; (define-enum name) - a special case of define-constant
  600: 
  601: (define (variable-parser-common const? name init opts)
  602:   (let ((c-name  (get-keyword :c-name opts #f))
  603:         (symbol  (make-literal name))
  604:         (initval (make-literal init)))
  605:     (when c-name
  606:       (cgen-decl #`"#define ,c-name (,(cgen-cexpr symbol))"))
  607:     (cgen-init (format "  ~a(module, SCM_SYMBOL(~a), ~a);\n"
  608:                        (if const? "Scm_DefineConst" "Scm_Define")
  609:                        (cgen-cexpr symbol)
  610:                        (cgen-cexpr initval)))
  611:     (cgen-add! symbol)
  612:     (cgen-add! initval)))
  613: 
  614: (define-form-parser define-variable (name init . opts)
  615:   (check-arg symbol? name)
  616:   (variable-parser-common #f name init opts))
  617: 
  618: (define-form-parser define-constant (name init . opts)
  619:   (check-arg symbol? name)
  620:   (variable-parser-common #t name init opts))
  621: 
  622: (define-form-parser define-enum (name)
  623:   (check-arg symbol? name)
  624:   (variable-parser-common #t name (list 'c #`"Scm_MakeInteger(,name)") '()))
  625: 
  626: (define-form-parser define-enum-conditionally (name)
  627:   (check-arg symbol? name)
  628:   (parameterize ((cgen-cpp-condition #`"defined(,name)"))
  629:     (variable-parser-common #t name (list 'c #`"Scm_MakeInteger(,name)") '())))
  630: 
  631: ;;-------------------------------------------------------------------
  632: ;; (define-keyword scheme-name c-name)
  633: 
  634: (define-form-parser define-keyword (name c-name)
  635:   (check-arg symbol? name)
  636:   (check-arg string? c-name)
  637:   (let1 literal (make-literal (make-keyword name) :c-name c-name)
  638:     (cgen-decl #`"#define ,c-name (,(cgen-c-name literal))")
  639:     (cgen-add! literal)))
  640: 
  641: ;;===================================================================
  642: ;; Procedure
  643: ;;
  644: 
  645: ;; Common stuff for cproc and cmethod
  646: 
  647: (define-class <setter-mixin> ()
  648:   ((setter          :initform #f)
  649:    ;; setter keeps the name of the setter, or a string of c-name of the
  650:    ;; setter in case of anonymous setter.
  651:    ))
  652: 
  653: (define-class <procstub> (<setter-mixin> <stub>)
  654:   ((args              :initform '() :init-keyword :args)
  655:    (keyword-args      :initform '() :init-keyword :keyword-args)
  656:    (num-reqargs       :initform 0   :init-keyword :num-reqargs)
  657:    (num-optargs       :initform 0   :init-keyword :num-optargs)
  658:    (have-rest-arg?    :initform #f  :accessor have-rest-arg? :init-keyword :have-rest-arg?)
  659:    (allow-other-keys? :initform '() :accessor allow-other-keys?
  660:                       :init-keyword :allow-other-keys?)
  661:    (decls             :initform '())
  662:    (stmts             :initform '())
  663:       ;; reverse list of C stmt lines.
  664:    (c++-handlers      :initform '())
  665:       ;; ((<c++-exception-decl> <handler-stmt> ...) ...)
  666:       ;; If not null, the entire procedure body is wrapped by 'try' and
  667:       ;; an appropriate handlers are emitted.  Necessary to write a stub
  668:       ;; for C++ functions that may throw an exception.
  669:    ))
  670: 
  671: (define (get-arg cproc arg)
  672:   (find (lambda (x) (eq? arg [@ x'name])) [@ cproc'args]))
  673: 
  674: (define (push-stmt! cproc stmt)
  675:   (push! [@ cproc'stmts] stmt))
  676: 
  677: (define-generic c-stub-name )
  678: 
  679: ;;-----------------------------------------------------------------
  680: ;; (define-cproc scheme-name (argspec) body)
  681: ;;
  682: 
  683: (define-class <cproc> (<procstub>)
  684:   ((inline-insn  :initform #f)
  685:    (proc-name    :init-keyword :proc-name)  ; string literal
  686:    ))
  687: 
  688: (define-form-parser define-cproc (scheme-name argspec . body)
  689:   (check-arg symbol? scheme-name)
  690:   (check-arg list? argspec)
  691:   (receive (args keyargs nreqs nopts rest? other-keys?)
  692:       (process-cproc-args argspec)
  693:     (let ((cproc (make <cproc>
  694:                    :scheme-name scheme-name
  695:                    :c-name (get-c-name *file-prefix* scheme-name)
  696:                    :proc-name (make-literal (x->string scheme-name))
  697:                    :args args
  698:                    :keyword-args keyargs
  699:                    :num-reqargs nreqs
  700:                    :num-optargs nopts
  701:                    :have-rest-arg? rest?
  702:                    :allow-other-keys? other-keys?)))
  703:       (process-body cproc body)
  704:       (cgen-add! cproc))))
  705: 
  706: (define-method c-stub-name ((cproc <cproc>))
  707:   #`",(@ cproc'c-name)__STUB")
  708: 
  709: ;; create arg object.  used in cproc and cmethod
  710: (define (make-arg class argname count . rest)
  711:   (define (grok-argname argname)
  712:     (let1 namestr (symbol->string argname)
  713:       (receive (realname typename) (string-scan namestr "::" 'both)
  714:         (if realname
  715:           (values (string->symbol realname)
  716:                   (name->type (string->symbol typename)))
  717:           (values argname *scm-type*)))))
  718:   (receive (arg type) (grok-argname argname)
  719:     (apply make class :name arg :type type :count count rest)))
  720: 
  721: ;; returns a list of args list of keyword args, # of reqargs, # of
  722: ;; optargs, have-rest-arg?, and allow-other-keys?
  723: (define (process-cproc-args argspecs)
  724:   (define (badarg arg) (error "bad argument in argspec:" arg))
  725: 
  726:   (define (required specs args nreqs)
  727:     (match specs
  728:       (()                   (values (reverse args) '() nreqs 0 #f #f))
  729:       (('&optional . specs) (optional specs args nreqs 0))
  730:       (('&rest . specs)     (rest specs args '() nreqs 0 #f))
  731:       (('&keyword . specs)  (keyword specs args '() nreqs 0))
  732:       (('&allow-other-keys . specs)
  733:        (error "misplaced &allow-other-key parameter"))
  734:       (((? symbol? sym) . specs)
  735:        (required specs
  736:                  (cons (make-arg <required-arg> sym nreqs) args)
  737:                  (+ nreqs 1)))
  738:       (_ (badarg (car specs)))))
  739: 
  740:   (define (optional specs args nreqs nopts)
  741:     (match specs
  742:       (() (values (reverse args) '() nreqs nopts #f #f))
  743:       (('&optional . specs) (error "extra &optional parameter"))
  744:       (('&keyword . specs)  (error "&keyword and &optional can't be used together"))
  745:       (('&rest . specs)     (rest specs args '() nreqs nopts #f))
  746:       (('&allow-other-keys . specs)
  747:        (error "misplaced &allow-other-key parameter"))
  748:       (((? symbol? sym) . specs)
  749:        (optional specs
  750:                  (cons (make-arg <optional-arg> sym (+ nreqs nopts))
  751:                        args)
  752:                  nreqs
  753:                  (+ nopts 1)))
  754:       ((((? symbol? sym) default) . specs)