`(Hello ,world)

ツッコミ、添削大歓迎です。いろいろ教えてください。

2009-07-14

Gaucheでのエラーの捕捉

CからGaucheの関数を呼び出すときに

	ScmEvalPacket epak;
	if (Scm_Apply(proc, args, &epak) >= 0) {
		...

としていたが、Scheme内でエラーが発生したときに例外オブジェクトは ScmEvalPacket::exception で取れるが、どこでエラーが起きたかとかの情報が出ないので困る。

404 Error - FC2ブログを見て、Gauchereplをまねてみたがうまくいかず…。

C側ではほとんど何もしてなくて、エラーをキャッチできてもどうやって復帰させるかの方法は知らないのでScheme側でキャッチしちゃっていいんじゃないの?と考えてguardなどを使えばいいんじゃないかと思ったけど、これも例外が取れるだけでどこで発生したかがわからない。

すったもんだしてたところ、Scm_Apply()の代わりにScm_ApplyRec()を使えばgoshで出るエラーメッセージが出力されスタックトレースも出力されることがわかった。ただこれだと、例外が投げられてめぐりめぐってvm.cのuser_eval_inner()内の

            ...
            else if (vm->cstack->prev == NULL) {
                /* This loop is the outermost C stack, and nobody will
                   capture the error.  Usually this means we're running
                   scripts.  We can safely exit here, for the dynamic
                   stack is already rewound. */
                exit(EX_SOFTWARE);
            } ...

exit()が呼び出されてアプリが強制終了してしまう。

あれこれ試してたところ、SCM_UNWIND_PROTECT を使えばいいことがわかった:

	SCM_UNWIND_PROTECT {
		ScmObj r = Scm_ApplyRec(Scm_SymbolValue(module, SCM_SYMBOL(SCM_INTERN("main"))), SCM_NIL);
	} SCM_WHEN_ERROR {
		printf("error\n");
	} SCM_END_PROTECT;

まだAPIが確定してないから勝手に使われると困るからドキュメント書かない、とかもわかるんだけどあれこれ手探りで探すの大変なので、将来変わってもいいから現在はこうなってるとかこう想定して作ってるとかいうメモ書きがあるといいなぁと思う。

トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20090714

2009-07-12

Gaucheの拡張ライブラリ作成

genstubでスタブ生成 - `(Hello ,world) - cadr groupで、genstub で作った拡張ライブラリのソースを直接プロジェクトに含めるとクラスのdllのリンケージが異なっていてエラーが出てしまう。なので別プロジェクトとしてdllを作成してやってみる。

dllのリンケージ指定

プリプロセッサでEXTSDL_EXPORTSと指定して、

#if defined(EXTSDL_EXPORTS)
#define LIBGAUCHE_EXT_BODY
#endif
#include <gauche/extern.h>      /* redefine SCM_EXTERN  */

とする。

dllのリンクエラー

自分で拡張ライブラリを作ろうとするとリンク時にエラーが出る:

リンクしています...
   ライブラリ D:\home\repos\lisp\gauche\sdlbind\Debug\ext-sdl.lib とオブジェクト D:\home\repos\lisp\gauche\sdlbind\Debug\ext-sdl.exp を作成中
sdl-lib.obj : error LNK2001: 外部シンボル "__imp__Scm_ProcedureClass" は未解決です。
sdl-lib.obj : error LNK2001: 外部シンボル "__imp__Scm_StringClass" は未解決です。
sdl-lib.obj : error LNK2019: 未解決の外部シンボル __imp__GC_malloc が関数 _sdl_lib_sdlrect_new で参照されました。
sdl-bind.obj : error LNK2001: 外部シンボル "__imp__GC_malloc" は未解決です。
sdl-lib.obj : error LNK2019: 未解決の外部シンボル __imp__Scm_Define が関数 _Scm_Init_sdl_lib で参照されました。
sdl-lib.obj : error LNK2019: 未解決の外部シンボル __imp__Scm_Intern が関数 _Scm_Init_sdl_lib で参照されました。
sdl-bind.obj : error LNK2001: 外部シンボル "__imp__Scm_Intern" は未解決です。
sdl-lib.obj : error LNK2019: 未解決の外部シンボル __imp__Scm_MakeString が関数 _Scm_Init_sdl_lib で参照されました。
sdl-bind.obj : error LNK2001: 外部シンボル "__imp__Scm_MakeString" は未解決です。
sdl-bind.obj : error LNK2001: 外部シンボル "__imp__Scm_ClassClass" は未解決です。
sdl-bind.obj : error LNK2019: 未解決の外部シンボル __imp__Scm_InitStaticClass が関数 _Scm_Init_SDL で参照されました。
sdl-bind.obj : error LNK2019: 未解決の外部シンボル __imp__Scm_FindModule が関数 _Scm_Init_SDL で参照されました。
D:\home\repos\lisp\gauche\sdlbind\Debug\ext-sdl.dll : fatal error LNK1120: 外部参照 9 が未解決です。
ビルドログは "file://d:\home\repos\lisp\gauche\sdlbind\Debug\BuildLog.htm" に保存されました。
ext-sdl - エラー 13、警告 0

これはプロジェクト依存関係でlibgaucheにチェックを入れればOK。

gauche-package generate

進めていくうちに、Gaucheではgauche-packageに拡張ライブラリを作るための作業を多少簡単にしてくれるコマンドがあることを知った。Gauche:拡張ライブラリ入門を参考に、

$ gauche-package generate sdl

とすると

などを作ってくれる。これを元に作っていったほうがいいだろう。

WinGaucheの拡張ライブラリの規則にのっとって、プロジェクト名はext-sdlとしよう。作成するdllの名前はsdlだと本当のsdlとかぶってしまうのでgauche-sdl.dllとしよう。そうするとdllのエントリ名も合わせる必要があるので、

SCM_EXTENSION_ENTRY void Scm_Init_gauche_sdl(void)

とする。

GAUCHE_API_0_9

スタブから.cの生成は、ラベルGAUCHE_API_0_9を定義させるために

$ gosh genstub -D GAUCHE_API_0_9 sdl-bind.stub

とする。

Cの構造体に対応するSchemeのクラス定義

構造体の定義は、スタブに

(define-cclass <SDL_Rect> "ScmSDL_Rect*" "Scm_SDL_RectClass"
  ()
  ((x :type <short> :setter "obj->rc.x = (short)SCM_INT_VALUE(value);" :getter "return SCM_MAKE_INT(obj->rc.x);")
   ...)
  (allocator (c "alloc_SDL_Rect")))

などと書く。スロットの定義を書けばSchemeからslot-refやslot-set!でアクセスできるようになる。

cclassの定義に親クラスを書かないとSCM_CLASS_DEFAULT_CPLを参照するようになってるが、VCだと外部dllの実体の参照が静的に置けないのでSCM_DEFINE_BUILTIN_CLASSでエラーが出てしまう。なので親クラステーブルをNULLとするためスタブに

#undef SCM_CLASS_DEFAULT_CPL
#define SCM_CLASS_DEFAULT_CPL NULL

を挿入しておく。

ForeignPointer

SDL_Surfaceのように、ポインタだけでScheme側からは中身に直接触らないものはScm_MakeForeignPointerClassを使って

ScmClass *Scm_SDL_SurfaceClass;
	Scm_SDL_SurfaceClass = Scm_MakeForeignPointerClass(mod, "<SDL_SurfacePtr>", SDL_SurfacePtr_print, SDL_SurfacePtr_cleanup, SCM_FOREIGN_POINTER_KEEP_IDENTITY|SCM_FOREIGN_POINTER_MAP_NULL);

などと書く。

gauche-init.scm

以前やったときに(use)が使えなかったのは起動時にgauche-init.scmを読み込めば解決した。これを読み込まないとuvectorを使おうとしたときにエラーが出て気がついた。gauche-init.scmはgoshなどでも起動時に読まれるスクリプト。

こんなところかな…。ドキュメントとしてまとまってないのでググッたり他の拡張ライブラリ見たり推測したり大変だった。誰かまとめないですかね。

ソース

以下、SDLの拡張ライブラリを使ってキー操作でスプライトを動かすテスト:

entry.scm

(define (/= a b) (not (= a b)))

(define-macro (iflet var val then . rest)
  (let1 g (gensym)
    `(let1 ,g ,val
       (if ,g
           (let1 ,var ,g
             ,then)
         ,@rest))))

(define-macro (vcase val . rest)
  (let1 g (gensym)
    `(let1 ,g ,val
       (cond ,@(map (lambda (exp)
                      (if (eq? (car exp) 'else)
                          exp
                        `((= ,(car exp) ,g) ,@(cdr exp))))
                    rest)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(use sdl)

(use gauche.uvector)
(define *key-state* (make-u8vector SDLK_LAST 0))

(define (keydown keysym)
  (u8vector-set! *key-state* keysym 1))

(define (keyup keysym)
  (u8vector-set! *key-state* keysym 0))

(define (key-pressed? keysym)
  (/= (u8vector-ref *key-state* keysym) 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-constant FRAME_TICKS 16) ;(div 1000 60))
(define-constant ScreenWidth 640)
(define-constant ScreenHeight 480)

(define *screen* '())
(define videoflags '())
(define video_bpp '())

(define (term)
  (SDL_Quit))

(define (init caption w h)
  (if (< (SDL_Init SDL_INIT_VIDEO) 0)
      #f
    (begin
      (SDL_WM_SetCaption caption '())
      
      (let* ((info (SDL_GetVideoInfo))
             (bpp (slot-ref info 'vfmt->BitsPerPixel)))
        (set! video_bpp (if (> bpp 8)
                            bpp
                          16)))
      
      (set! videoflags (logior SDL_HWSURFACE SDL_DOUBLEBUF))
      (set! *screen* (SDL_SetVideoMode w h video_bpp videoflags))
      *screen*)))

(define wait
  (let ((lastticks #f))
    (lambda (frame_ticks)
      (let1 ticks (SDL_GetTicks)
        (when lastticks
          (let1 d (- frame_ticks (- ticks lastticks))
            (when (> d 0)
              (SDL_Delay d))))
        (set! lastticks ticks)))))

(define proc-events
  (let ((event (make <SDL_Event>)))
    (lambda ()
      (let1 cont #t
        (while (SDL_PollEvent event)
          (vcase (slot-ref event 'type)
                 (SDL_QUIT         (set! cont #f))
                 (SDL_VIDEORESIZE  (SDL_SetVideoMode (slot-ref event 'resize.w) (slot-ref event 'resize.h) video_bpp videoflags))
                 (SDL_KEYDOWN      (keydown (slot-ref event 'key.keysym.sym)))
                 (SDL_KEYUP        (keyup   (slot-ref event 'key.keysym.sym)))
                 ))
        cont))))

(define (load-image fn)
  (iflet surface (SDL_LoadBMP fn)
      (iflet converted (SDL_DisplayFormat surface)
          (begin
            (SDL_FreeSurface surface)
            converted)
        surface)
    #f))

(define blit
  (let ((rc (make <SDL_Rect>)))
    (lambda (src-surface x y)
      (slot-set! rc 'x x)
      (slot-set! rc 'y y)
      (SDL_BlitSurface src-surface '() *screen* rc))))

(define (loop sprite)
  (let ((x 100)
        (y 100))
    (call/cc
     (lambda (break)
       (while (proc-events)
         (when (key-pressed? SDLK_ESCAPE)
           (break))
         (SDL_FillRect *screen* '() 0)

         (when (key-pressed? SDLK_LEFT)
           (dec! x 1))
         (when (key-pressed? SDLK_RIGHT)
           (inc! x 1))
         (when (key-pressed? SDLK_UP)
           (dec! y 1))
         (when (key-pressed? SDLK_DOWN)
           (inc! y 1))
         (blit sprite x y)

         (wait FRAME_TICKS)
         (SDL_Flip *screen*))))))

(define (main)
  (if (init "SDL Test" ScreenWidth ScreenHeight)
      (let1 sprite (load-image "icon.bmp")
        (loop sprite)
        (SDL_FreeSurface sprite)
        (term))
    (print "failed")))

sdllib.stub

;;-*-Scheme-*-
;;;
;;; sdllib.stub
;;;

"
#include \"sdl.h\"
#include <SDL/SDL.h>
#include \"gauche/class.h\"

#undef SCM_CLASS_DEFAULT_CPL
#define SCM_CLASS_DEFAULT_CPL NULL

typedef struct ScmSDL_RectRec {
	SCM_HEADER;
	SDL_Rect rc;
} ScmSDL_Rect;

SCM_CLASS_DECL(Scm_SDL_RectClass);
#define SCM_CLASS_SDL_RECT (&Scm_SDL_RectClass)
#define SCM_SDL_RECT(obj) ((ScmSDL_Rect*)(obj))
#define SCM_SDL_RECTP(obj) (SCM_XTYPEP(obj, SCM_CLASS_SDL_RECT))

ScmObj alloc_SDL_Rect(ScmClass *klass, ScmObj initargs)
{
    ScmSDL_Rect *obj = SCM_ALLOCATE(ScmSDL_Rect, klass);
    SCM_SET_CLASS(obj, klass);
    memset(&obj->rc, 0x00, sizeof(obj->rc));
    return SCM_OBJ(obj);
}

typedef struct ScmSDL_Event {
	SCM_HEADER;
	SDL_Event event;
} ScmSDL_Event;

SCM_CLASS_DECL(Scm_SDL_EventClass);
#define SCM_CLASS_SDL_EVENT (&Scm_SDL_EventClass)
#define SCM_SDL_EVENT(obj) ((ScmSDL_Event*)(obj))
#define SCM_SDL_EVENTP(obj) (SCM_XTYPEP(obj, SCM_CLASS_SDL_EVENT))

ScmObj alloc_SDL_Event(ScmClass *klass, ScmObj initargs)
{
    ScmSDL_Event *obj = SCM_ALLOCATE(ScmSDL_Event, klass);
    SCM_SET_CLASS(obj, klass);
    return SCM_OBJ(obj);
}

typedef struct ScmSDL_VideoInfo {
	SCM_HEADER;
	const SDL_VideoInfo* info;
} ScmSDL_VideoInfo;

SCM_CLASS_DECL(Scm_SDL_VideoInfoClass);
#define SCM_CLASS_SDL_VIDEOINFO (&Scm_SDL_VideoInfoClass)
#define SCM_SDL_VIDEOINFO(obj) ((ScmSDL_VideoInfo*)(obj))
#define SCM_SDL_VIDEOINFOP(obj) (SCM_XTYPEP(obj, SCM_CLASS_SDL_VIDEOINFO))
"

(define-cclass <SDL_Rect> "ScmSDL_Rect*" "Scm_SDL_RectClass"
  ()
  ((x :type <short> :setter "if (!SCM_INTP(value)) Scm_Error(\"short required, but got %S\", value);\nobj->rc.x = (short)SCM_INT_VALUE(value);" :getter "return SCM_MAKE_INT(obj->rc.x);")
   (y :type <short> :setter "if (!SCM_INTP(value)) Scm_Error(\"short required, but got %S\", value);\nobj->rc.y = (short)SCM_INT_VALUE(value);" :getter "return SCM_MAKE_INT(obj->rc.y);")
   (w :type <short> :setter "if (!SCM_INTP(value)) Scm_Error(\"short required, but got %S\", value);\nobj->rc.w = (short)SCM_INT_VALUE(value);" :getter "return SCM_MAKE_INT(obj->rc.w);")
   (h :type <short> :setter "if (!SCM_INTP(value)) Scm_Error(\"short required, but got %S\", value);\nobj->rc.h = (short)SCM_INT_VALUE(value);" :getter "return SCM_MAKE_INT(obj->rc.h);"))
  (allocator (c "alloc_SDL_Rect")))

(define-cclass <SDL_Event> "ScmSDL_Event*" "Scm_SDL_EventClass"
  ()
  ((type :type <char> :setter "" :getter "return SCM_MAKE_INT(obj->event.type);")
   (key.keysym.sym :type <int> :setter "" :getter "return SCM_MAKE_INT(obj->event.key.keysym.sym);")
   (resize.w :type <int> :setter "" :getter "return SCM_MAKE_INT(obj->event.resize.w);")
   (resize.h :type <int> :setter "" :getter "return SCM_MAKE_INT(obj->event.resize.h);")
   )
  (allocator (c "alloc_SDL_Event")))

(define-cclass <SDL_VideoInfo> "ScmSDL_VideoInfo*" "Scm_SDL_VideoInfoClass"
  ()
  ((vfmt->BitsPerPixel :type <char> :setter "" :getter "return SCM_MAKE_INT(obj->info->vfmt->BitsPerPixel);")
   ))

(define-type <SDL_SurfacePtr> "SDL_Surface*")

(define-cproc SDL_Init (flags::<int>)
  (expr <int> "SDL_Init(flags)"))

(define-cproc SDL_Quit ()
  (body <void> "SDL_Quit();"))

(define-cproc SDL_WM_SetCaption (caption::<string> icon)
  (body <void> "SDL_WM_SetCaption(Scm_GetStringConst(caption), NULL);"))

(define-cproc SDL_GetVideoInfo ()
  "const SDL_VideoInfo* info = SDL_GetVideoInfo();
    ScmSDL_VideoInfo *obj = SCM_ALLOCATE(ScmSDL_VideoInfo, &Scm_SDL_VideoInfoClass);
    SCM_SET_CLASS(obj, &Scm_SDL_VideoInfoClass);
    obj->info = info;
    return SCM_OBJ(obj);")

(define-cproc SDL_SetVideoMode (width::<int> height::<int> bpp::<int> flags::<int>)
  "SDL_Surface* screen = SDL_SetVideoMode(width, height, bpp, flags);
   SCM_RETURN(screen != NULL ? SCM_SDL_SURFACEPTR_BOX(screen) : SCM_FALSE);")

(define-cproc SDL_LoadBMP (fn::<string>)
  "SDL_Surface* surface = SDL_LoadBMP(Scm_GetStringConst(fn));
   SCM_RETURN(surface != NULL ? SCM_SDL_SURFACEPTR_BOX(surface) : SCM_FALSE);")

(define-cproc SDL_DisplayFormat (surface::<SDL_SurfacePtr>)
  "SDL_Surface* converted = SDL_DisplayFormat(surface);
   SCM_RETURN(converted != NULL ? SCM_SDL_SURFACEPTR_BOX(converted) : SCM_FALSE);")

(define-cproc SDL_FreeSurface (surface::<SDL_SurfacePtr>)
  (body <void> "SDL_FreeSurface(surface);"))

(define-cproc SDL_FillRect (dst::<SDL_SurfacePtr> dstrect_scm color::<int>)
  "SDL_Rect* dstrect;
   if (SCM_NULLP(dstrect_scm)) dstrect = NULL;
   else if (SCM_SDL_RECTP(dstrect_scm)) dstrect = &SCM_SDL_RECT(dstrect_scm)->rc;
   else Scm_Error(\"<SDL_Rect> required, but got %S\", dstrect_scm);"
  (expr <int> "SDL_FillRect(dst, dstrect, color)"))

(define-cproc SDL_BlitSurface (src::<SDL_SurfacePtr> srcrect_scm dst::<SDL_SurfacePtr> dstrect::<SDL_Rect>)
  "SDL_Rect *srcrect;
   if (SCM_NULLP(srcrect_scm)) srcrect = NULL;
   else if (SCM_SDL_RECTP(srcrect_scm)) srcrect = &SCM_SDL_RECT(srcrect_scm)->rc;
   else Scm_Error(\"<SDL_Rect> required, but got %S\", srcrect_scm);"
  (expr <int> "SDL_BlitSurface(src, srcrect, dst, &dstrect->rc)"))

(define-cproc SDL_Flip (surface::<SDL_SurfacePtr>)
  (expr <int> "SDL_Flip(surface)"))

(define-cproc SDL_GetTicks ()
  (expr <int> "SDL_GetTicks()"))

(define-cproc SDL_Delay (ms::<int>)
  (body <void> "SDL_Delay(ms);"))

(define-cproc SDL_PollEvent (event::<SDL_Event>)
  "SCM_RETURN(SDL_PollEvent(&event->event) ? SCM_TRUE : SCM_FALSE);")

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

sdl.c

/*
 * sdl.c
 */

#include "sdl.h"
#include <SDL/SDL.h>

/*
 * Module initialization function.
 */
extern void Scm_Init_sdllib(ScmModule*);

static void SDL_SurfacePtr_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx) {
	SDL_Surface *q = SCM_SDL_SURFACEPTR(obj);
	Scm_Printf(out, "#<SDL_Surface*: %p>", q);
}

static void SDL_SurfacePtr_cleanup(ScmObj obj) {
	SDL_Surface *q = SCM_SDL_SURFACEPTR(obj);
//	delete q;
}

ScmClass *Scm_SDL_SurfaceClass;

SCM_EXTENSION_ENTRY void Scm_Init_gauche_sdl(void)
{
	ScmModule *mod;

	/* Register this DSO to Gauche */
	SCM_INIT_EXTENSION(sdl);

	/* Create the module if it doesn't exist yet. */
	mod = SCM_MODULE(SCM_FIND_MODULE("sdl", TRUE));

	Scm_SDL_SurfaceClass = Scm_MakeForeignPointerClass(mod, "<SDL_SurfacePtr>", SDL_SurfacePtr_print, SDL_SurfacePtr_cleanup, SCM_FOREIGN_POINTER_KEEP_IDENTITY|SCM_FOREIGN_POINTER_MAP_NULL);

	SCM_DEFINE(mod, "SDL_INIT_VIDEO", Scm_MakeInteger(SDL_INIT_VIDEO));

	// flags for SDL_SetVideoMode
	SCM_DEFINE(mod, "SDL_HWSURFACE", Scm_MakeInteger(SDL_HWSURFACE));
	SCM_DEFINE(mod, "SDL_DOUBLEBUF", Scm_MakeInteger(SDL_DOUBLEBUF));
	SCM_DEFINE(mod, "SDL_FULLSCREEN", Scm_MakeInteger(SDL_FULLSCREEN));
	SCM_DEFINE(mod, "SDL_RESIZABLE", Scm_MakeInteger(SDL_RESIZABLE));

	// event
	SCM_DEFINE(mod, "SDL_KEYDOWN", Scm_MakeInteger(SDL_KEYDOWN));
	SCM_DEFINE(mod, "SDL_KEYUP", Scm_MakeInteger(SDL_KEYUP));
	SCM_DEFINE(mod, "SDL_QUIT", Scm_MakeInteger(SDL_QUIT));
	SCM_DEFINE(mod, "SDL_VIDEORESIZE", Scm_MakeInteger(SDL_VIDEORESIZE));

	// keysym
	SCM_DEFINE(mod, "SDLK_ESCAPE", Scm_MakeInteger(SDLK_ESCAPE));
	SCM_DEFINE(mod, "SDLK_UP", Scm_MakeInteger(SDLK_UP));
	SCM_DEFINE(mod, "SDLK_DOWN", Scm_MakeInteger(SDLK_DOWN));
	SCM_DEFINE(mod, "SDLK_RIGHT", Scm_MakeInteger(SDLK_RIGHT));
	SCM_DEFINE(mod, "SDLK_LEFT", Scm_MakeInteger(SDLK_LEFT));
	SCM_DEFINE(mod, "SDLK_LAST", Scm_MakeInteger(SDLK_LAST));

	/* Register stub-generated procedures */
	Scm_Init_sdllib(mod);
}

sdl.h

/*
 * sdl.h
 */

/* Prologue */
#ifndef GAUCHE_SDL_H
#define GAUCHE_SDL_H

#include <gauche.h>
#include <gauche/extend.h>

#if defined(EXTSDL_EXPORTS)
#define LIBGAUCHE_EXT_BODY
#endif
#include <gauche/extern.h>      /* redefine SCM_EXTERN  */

SCM_DECL_BEGIN

extern ScmClass *Scm_SDL_SurfaceClass;
#define SCM_SDL_SURFACEPTRP(obj)     SCM_XTYPEP(obj, Scm_SDL_SurfaceClass)
#define SCM_SDL_SURFACEPTR(obj)      SCM_FOREIGN_POINTER_REF(SDL_Surface*, obj)
#define SCM_SDL_SURFACEPTR_BOX(ptr)  Scm_MakeForeignPointer(Scm_SDL_SurfaceClass, ptr)

/* Epilogue */
SCM_DECL_END

#endif  /* GAUCHE_SDL_H */

sdl.scm

;;;
;;; sdl
;;;

(define-module sdl
  (export <SDL_Rect>
          <SDL_Event>
          
          SDL_Init
          SDL_Quit
          SDL_WM_SetCaption
          SDL_GetVideoInfo
          SDL_SetVideoMode
          SDL_LoadBMP
          SDL_DisplayFormat
          SDL_FreeSurface
          SDL_FillRect
          SDL_BlitSurface
          SDL_Flip
          
          SDL_GetTicks
          SDL_Delay
          
          SDL_PollEvent
          
          SDL_INIT_VIDEO
          ; flags for SDL_SetVideoMode
          SDL_HWSURFACE
          SDL_DOUBLEBUF
          SDL_FULLSCREEN
          SDL_RESIZABLE
          
          ; event
          SDL_KEYDOWN
          SDL_KEYUP
          SDL_QUIT
          SDL_VIDEORESIZE

          ; keysym
          SDLK_ESCAPE
          SDLK_UP
          SDLK_DOWN
          SDLK_RIGHT
          SDLK_LEFT
          SDLK_LAST
          )
  )
(select-module sdl)

;; Loads extension
(dynamic-load "gauche-sdl")

;;
;; Put your Scheme definitions here
;;

;; Epilogue
(provide "sdl")

main.cpp

#define	GAUCHE_API_0_9
#include <gauche.h>
#include <stdio.h>

#include <SDL/SDL.h>

//=============================================================================

/* Error handling */
void error_exit(ScmObj c) {
	ScmObj m = Scm_ConditionMessage(c);
	if (SCM_FALSEP(m)) {
		Scm_Printf(SCM_CURERR, "gosh: Thrown unknown condition: %S\n", c);
	} else {
		Scm_Printf(SCM_CURERR, "gosh: %S: %A\n", Scm_ConditionTypeName(c), m);
	}
	Scm_Exit(1);
}

int dofile(const char* fn) {
	ScmLoadPacket lpak;
	if (Scm_Load(fn, 0, &lpak) >= 0) {
		return TRUE;
	} else {
		error_exit(lpak.exception);
		return FALSE;
	}
}

int call_proc(ScmSymbol* proc_sym, ScmObj args) {
	ScmModule* module = Scm_UserModule();
	ScmObj proc = Scm_GlobalVariableRef(module, proc_sym, 0);
	ScmEvalPacket epak;
	if (Scm_Apply(proc, args, &epak) >= 0) {
		return TRUE;
	} else {
		error_exit(epak.exception);
		return FALSE;
	}
}

int main(int argc, char* argv[]) {
	GC_INIT();
	Scm_Init(GAUCHE_SIGNATURE);
	Scm_AddLoadPath(".", FALSE);
	Scm_AddLoadPath("../Gauche-0.8.14/winnt/share/gauche/0.8.14/lib", FALSE);
	Scm_AddLoadPath("../Gauche-0.8.14/winnt/lib/gauche/site/0.8.14/i686-pc-winnt", FALSE);

	dofile("gauche-init.scm");
	dofile("./entry.scm");
	call_proc(SCM_SYMBOL(SCM_INTERN("main")), SCM_NIL);
	Scm_Exit(0);

	return 0;
}
  • sdl.scmにエクスポートする関数や変数などを書かないといけないのがメンドイ
  • ポインタ構造体もしくはnil()を受け付ける、というのを簡単に書きたい

参考:

トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20090712

2009-07-09

genstubでスタブ生成

Gauche:MeCabを模倣。このページにCの構造体をGaucheのクラスにマップするやり方が書いてある。

例えばSDL_Rectだったら、sdl.stubというファイル

"
 #include <gauche/extend.h>
 #include <SDL/SDL.h>

 typedef struct ScmSDL_RectRec {
   SCM_HEADER;
   SDL_Rect rc;
 } ScmSDL_Rect;

 SCM_CLASS_DECL(Scm_SDL_RectClass);
 #define SCM_CLASS_SDL_RECT (&Scm_SDL_RectClass)
 #define SCM_SDL_RECT(obj) ((ScmSDL_Rect*)(obj))
 #define SCM_SDL_RECTP(obj) (SCM_XTYPEP(obj, SCM_CLASS_SDL_RECT))

 /* Hack for initialization stub */
 static void internal_init(ScmModule*);
 void Scm_Init_sdl(void)
 {
   ScmModule *mod;
   SCM_INIT_EXTENSION(sdlrect);
   mod = SCM_MODULE(SCM_FIND_MODULE(\"sdl\", TRUE));
   internal_init(mod);
 }
 #define Scm_Init_sdl internal_init
"

(define-cclass <sdlrect> "ScmSDL_Rect*" "Scm_SDL_RectClass"
  ()
  ())

(define-cproc sdlrect-new ()
  "  ScmSDL_Rect *m = SCM_NEW(ScmSDL_Rect);
  SCM_SET_CLASS(m, SCM_CLASS_SDL_RECT);
  SCM_RETURN(SCM_OBJ(m));")

を作る。定義したい構造体の頭に SCM_HEADER という共通の要素を置いて、実際の中身を続ける。元のページだとSCM_MODULEに渡す部分の「¥」がエスケープされて「?"mecab?"」というようになってしまっている。

これをgenstubで変換する:

gosh genstub sdl.stub

sdl.cというファイル

/* Generated by genstub.  Do not edit. */
#include <gauche.h>

 #include <gauche/extend.h>
 #include <SDL/SDL.h>

 typedef struct ScmSDL_RectRec {
   SCM_HEADER;
   SDL_Rect rc;
 } ScmSDL_Rect;

 SCM_CLASS_DECL(Scm_SDL_RectClass);
 #define SCM_CLASS_SDL_RECT (&Scm_SDL_RectClass)
 #define SCM_SDL_RECT(obj) ((ScmSDL_Rect*)(obj))
 #define SCM_SDL_RECTP(obj) (SCM_XTYPEP(obj, SCM_CLASS_SDL_RECT))

 /* Hack for initialization stub */
 static void internal_init(ScmModule*);
 void Scm_Init_sdl(void)
 {
   ScmModule *mod;
   SCM_INIT_EXTENSION(sdlrect);
   mod = SCM_MODULE(SCM_FIND_MODULE("sdlrect", TRUE));
   internal_init(mod);
 }
 #define Scm_Init_sdl internal_init

#if defined(__CYGWIN__) || defined(GAUCHE_WINDOWS)
#define SCM_CGEN_CONST /*empty*/
#else
#define SCM_CGEN_CONST const
#endif
static SCM_CGEN_CONST struct scm__scRec {
  ScmString d742[1];
} scm__sc = {
  {   /* ScmString d742 */
      SCM_STRING_CONST_INITIALIZER("sdlrect-new", 11, 11),
  },
};
SCM_DEFINE_BUILTIN_CLASS(Scm_SDL_RectClass, NULL, NULL, NULL, NULL, SCM_CLASS_DEFAULT_CPL);

static ScmObj sdl_sdlrect_new(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_)
{
  SCM_ENTER_SUBR("sdlrect-new");
  {
  ScmSDL_Rect *m = SCM_NEW(ScmSDL_Rect);
  SCM_SET_CLASS(m, SCM_CLASS_SDL_RECT);
  SCM_RETURN(SCM_OBJ(m));
  }
}

static SCM_DEFINE_SUBR(sdl_sdlrect_new__STUB, 0, 0, SCM_OBJ(&scm__sc.d742[0]), sdl_sdlrect_new, NULL, NULL);

void Scm_Init_sdl(ScmModule *mod)
{

  Scm_InitBuiltinClass(&Scm_SDL_RectClass, "<sdlrect>", NULL, TRUE, mod);
  SCM_DEFINE(mod, "sdlrect-new", SCM_OBJ(&sdl_sdlrect_new__STUB));
}

が生成される。うーん、こうやって構造体1個ごとに定義していくのは面倒すぎる。なんとかならないもんか。指定サイズのuvectorを確保して中身をCの任意の型として読み書きできるとかでいいんだけど。

ただこれをVCのプロジェクトに追加してコンパイルすると

sdlrect.c
d:\home\repos\lisp\gauche\sdlbind\src\sdl.c(40) : warning C4273: 'Scm_SDL_RectClass' : dll リンクが一貫していません。
        d:\home\repos\lisp\gauche\sdlbind\src\sdl.c(12) : 'Scm_SDL_RectClass' の前の定義を確認してください

というワーニングが出て、リンクにも失敗する:

リンクしています...
   ライブラリ D:\home\repos\lisp\gauche\sdlbind\Debug\sdlbind.lib とオブジェクト D:\home\repos\lisp\gauche\sdlbind\Debug\sdlbind.exp を作成中
MSVCRTD.lib(cinitexe.obj) : warning LNK4098: defaultlib 'msvcrt.lib' は他のライブラリの使用と競合しています。/NODEFAULTLIB:library を使用してください。
sdl.obj : error LNK2001: 外部シンボル "_Scm_DefaultCPL" は未解決です。
D:\home\repos\lisp\gauche\sdlbind\Debug\sdlbind.exe : fatal error LNK1120: 外部参照 1 が未解決です。

拡張モジュールは別プロジェクトにしてDLLを作らないとだめなんだろうか。

Gaucheドキュメントしっかりしてるのに、C APIとか拡張モジュールの作り方とかgenstubのドキュメントがほとんど整備されてないのは意図してやってるんだろうか。

参考になりそうなリンク:

トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20090709

2009-07-08

ここまでのソース

貼っておかないとなくすから

  • not equalは一般的にはどうするのかな?
  • Arcifletを取り入れてみた

entry.scm:

(define (/= a b) (not (= a b)))

(define-macro (iflet var val then . rest)
  (let1 g (gensym)
    `(let1 ,g ,val
       (if ,g
           (let1 ,var ,g
             ,then)
         ,@rest))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-constant FRAME_TICKS 16) ;(div 1000 60))
(define-constant ScreenWidth 640)
(define-constant ScreenHeight 480)

(define *screen* '())
(define videoflags '())
(define sprite '())

(define (load-image fn)
  (iflet surface (SDL_LoadBMP fn)
      (iflet converted (SDL_DisplayFormat surface)
          (begin
            (SDL_FreeSurface surface)
            converted)
        surface)
    #f))

(define (term)
  (SDL_Quit))

(define (init caption w h)
  (if (< (SDL_Init SDL_INIT_VIDEO) 0)
      #f
    (begin
      (SDL_WM_SetCaption caption '())

      (set! videoflags (logior SDL_HWSURFACE SDL_DOUBLEBUF))
      (set! *screen* (SDL_SetVideoMode w h 32 videoflags))
      *screen*)))

(define wait
  (let ((lastticks '()))
    (lambda (frame_ticks)
      (let1 ticks (SDL_GetTicks)
        (unless (null? lastticks)
          (let1 d (- frame_ticks (- ticks lastticks))
            (when (> d 0)
              (SDL_Delay d))))
        (set! lastticks ticks)))))

(define (loop)
  (let ((x 100)
        (y 100)
        (vx 2)
        (vy 2))
    (while (proc_events)
      (SDL_FillRect *screen* '() 0)
      (inc! x vx)
      (inc! y vy)
      (when (or (< x 0) (>= x ScreenWidth))
        (set! vx (- vx)))
      (when (or (< y 0) (>= y ScreenHeight))
        (set! vy (- vy)))
      (SDL_BlitSurface sprite '() *screen* x y)
      (wait FRAME_TICKS)
      (SDL_Flip *screen*))))

(define (main)
  (if (init "SDL Test" ScreenWidth ScreenHeight)
      (begin
        (set! sprite (load-image "icon.bmp"))
        (loop)
        (term))
    (print "初期化失敗")))

(main)

main.cpp:

#define	GAUCHE_API_0_9
#include <gauche.h>
#include <stdio.h>

#include <SDL/SDL.h>
#include <assert.h>

// 関数のバインド
#define	SCMBIND_FUNCTION(module, name, func, req, opt) { \
	static SCM_DEFINE_STRING_CONST(name##__NAME, #name, sizeof(#name)-1, sizeof(#name)-1); \
	static SCM_DEFINE_SUBR(name##__STUB, req, opt, SCM_OBJ(& name##__NAME), func, NULL, NULL); \
	SCM_DEFINE(module, #name, SCM_OBJ(& name##__STUB)); \
	}

//=============================================================================

/// Cのポインタクラス
ScmClass *cptr_ScmClass;

#define CPTR_P(obj)			SCM_XTYPEP(obj, cptr_ScmClass)
#define CPTR_UNBOX(obj)		SCM_FOREIGN_POINTER_REF(void*, obj)
#define CPTR_BOX(ptr)		Scm_MakeForeignPointer(cptr_ScmClass, ptr)

static void cptr_print(ScmObj obj, ScmPort *out, ScmWriteContext *ctx) {
	void* ptr = CPTR_UNBOX(obj);
	Scm_Printf(out, "#<cptr \"%p\">", ptr);
}
 
static void cptr_cleanup(ScmObj obj) {
	void* ptr = CPTR_UNBOX(obj);
	// what to do?
}
 
void init_cptr_class(ScmModule* module) {
	cptr_ScmClass = Scm_MakeForeignPointerClass(module, "<cptr>", cptr_print, cptr_cleanup, SCM_FOREIGN_POINTER_KEEP_IDENTITY|SCM_FOREIGN_POINTER_MAP_NULL);
}

//=============================================================================
// SDL バインディング

static ScmObj fnSDL_Quit(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	SDL_Quit();
	SCM_RETURN(SCM_UNDEFINED);
}

static ScmObj fnSDL_Init(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o = SCM_ARGREF(0);	assert(SCM_INTEGERP(o));
	int r = SDL_Init(Scm_GetInteger(o));
	SCM_RETURN(Scm_MakeInteger(r));
}

static ScmObj fnSDL_WM_SetCaption(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o0 = SCM_ARGREF(0);	assert(SCM_STRINGP(o0));
//	assert(SCM_INTEGERP(o1));
	const char* caption = Scm_GetStringConst(SCM_STRING(o0));
	SDL_WM_SetCaption(caption, NULL);
	SCM_RETURN(SCM_UNDEFINED);
}

static ScmObj fnSDL_SetVideoMode(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o0 = SCM_ARGREF(0);	assert(SCM_INTEGERP(o0));
	ScmObj o1 = SCM_ARGREF(1);	assert(SCM_INTEGERP(o1));
	ScmObj o2 = SCM_ARGREF(2);	assert(SCM_INTEGERP(o2));
	ScmObj o3 = SCM_ARGREF(3);	assert(SCM_INTEGERP(o3));
	SDL_Surface* screen = SDL_SetVideoMode(Scm_GetInteger(o0), Scm_GetInteger(o1), Scm_GetInteger(o2), Scm_GetInteger(o3));
	SCM_RETURN(screen != NULL ? CPTR_BOX(screen) : SCM_FALSE);
}

static ScmObj fnSDL_Flip(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o = SCM_ARGREF(0);	assert(CPTR_P(o));
	SDL_Surface* surface = (SDL_Surface*)CPTR_UNBOX(o);
	int r = SDL_Flip(surface);
	SCM_RETURN(Scm_MakeInteger(r));
}

static ScmObj fnSDL_Delay(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o = SCM_ARGREF(0);	assert(SCM_INTEGERP(o));
	SDL_Delay(Scm_GetInteger(o));
	SCM_RETURN(SCM_UNDEFINED);
}

static ScmObj fnSDL_GetTicks(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	Uint32 ticks = SDL_GetTicks();
	SCM_RETURN(Scm_MakeInteger(ticks));
}

static ScmObj fnSDL_LoadBMP(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o = SCM_ARGREF(0);	assert(SCM_STRINGP(o));
	SDL_Surface* surface = SDL_LoadBMP(Scm_GetStringConst(SCM_STRING(o)));
	SCM_RETURN(surface != NULL ? CPTR_BOX(surface) : SCM_FALSE);
}

static ScmObj fnSDL_BlitSurface(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o0 = SCM_ARGREF(0);	assert(CPTR_P(o0));			SDL_Surface* src = (SDL_Surface*)CPTR_UNBOX(o0);
	ScmObj o1 = SCM_ARGREF(1);			// ptr or null
	ScmObj o2 = SCM_ARGREF(2);	assert(CPTR_P(o2));			SDL_Surface* dst = (SDL_Surface*)CPTR_UNBOX(o2);
	ScmObj o3 = SCM_ARGREF(3);	assert(SCM_INTEGERP(o3));	int x = Scm_GetInteger(o3);
	ScmObj o4 = SCM_ARGREF(4);	assert(SCM_INTEGERP(o4));	int y = Scm_GetInteger(o4);
	SDL_Rect dstrect;
	dstrect.x = x;
	dstrect.y = y;
	dstrect.w = src->w;
	dstrect.h = src->h;
	int r = SDL_BlitSurface(src, NULL, dst, &dstrect);
	SCM_RETURN(Scm_MakeInteger(r));
}

static ScmObj fnSDL_FreeSurface(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o0 = SCM_ARGREF(0);	assert(CPTR_P(o0));			SDL_Surface* surface = (SDL_Surface*)CPTR_UNBOX(o0);
	SDL_FreeSurface(surface);
	SCM_RETURN(SCM_UNDEFINED);
}

static ScmObj fnSDL_DisplayFormat(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o0 = SCM_ARGREF(0);	assert(CPTR_P(o0));			SDL_Surface* surface = (SDL_Surface*)CPTR_UNBOX(o0);
	SDL_Surface* converted = SDL_DisplayFormat(surface);
	SCM_RETURN(converted != NULL ? CPTR_BOX(converted) : SCM_FALSE);
}

static ScmObj fnSDL_FillRect(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o0 = SCM_ARGREF(0);	assert(CPTR_P(o0));			SDL_Surface* surface = (SDL_Surface*)CPTR_UNBOX(o0);
//	ScmObj o1 = SCM_ARGREF(1);
	ScmObj o2 = SCM_ARGREF(2);	assert(SCM_INTEGERP(o2));	Uint32 color = Scm_GetInteger(o2);
	int r = SDL_FillRect(surface, NULL, color);
	SCM_RETURN(Scm_MakeInteger(r));
}


static ScmObj fn_proc_events(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	SDL_Event event;
	int cont = TRUE;
	while (SDL_PollEvent(&event)) {
		switch (event.type) {
		case SDL_QUIT:
			cont = FALSE;
			break;
		default:
			break;
		}
	}
	SCM_RETURN(cont ? SCM_TRUE : SCM_FALSE);
}

//-----------------------------------------------------------------------------

void Scm_Init_SDL(ScmModule *module) {
	SCMBIND_FUNCTION(module, SDL_Quit, fnSDL_Quit, 0, 0);
	SCMBIND_FUNCTION(module, SDL_Init, fnSDL_Init, 1, 0);
	SCMBIND_FUNCTION(module, SDL_WM_SetCaption, fnSDL_WM_SetCaption, 2, 0);
	SCMBIND_FUNCTION(module, SDL_SetVideoMode, fnSDL_SetVideoMode, 4, 0);
	SCMBIND_FUNCTION(module, SDL_Flip, fnSDL_Flip, 1, 0);
	SCMBIND_FUNCTION(module, SDL_Delay, fnSDL_Delay, 1, 0);
	SCMBIND_FUNCTION(module, SDL_GetTicks, fnSDL_GetTicks, 0, 0);
	SCMBIND_FUNCTION(module, SDL_LoadBMP, fnSDL_LoadBMP, 1, 0);
	SCMBIND_FUNCTION(module, SDL_BlitSurface, fnSDL_BlitSurface, 5, 2);
	SCMBIND_FUNCTION(module, SDL_FreeSurface, fnSDL_FreeSurface, 1, 0);
	SCMBIND_FUNCTION(module, SDL_DisplayFormat, fnSDL_DisplayFormat, 1, 0);
	SCMBIND_FUNCTION(module, SDL_FillRect, fnSDL_FillRect, 3, 0);
	SCMBIND_FUNCTION(module, proc_events, fn_proc_events, 0, 0);

	SCM_DEFINE(module, "SDL_INIT_VIDEO", Scm_MakeInteger(SDL_INIT_VIDEO));
	SCM_DEFINE(module, "SDL_HWSURFACE", Scm_MakeInteger(SDL_HWSURFACE));
	SCM_DEFINE(module, "SDL_DOUBLEBUF", Scm_MakeInteger(SDL_DOUBLEBUF));
}

//=============================================================================

/* Error handling */
void error_exit(ScmObj c) {
	ScmObj m = Scm_ConditionMessage(c);
	if (SCM_FALSEP(m)) {
		Scm_Printf(SCM_CURERR, "gosh: Thrown unknown condition: %S\n", c);
	} else {
		Scm_Printf(SCM_CURERR, "gosh: %S: %A\n", Scm_ConditionTypeName(c), m);
	}
	Scm_Exit(1);
}

int dofile(const char* fn) {
	ScmLoadPacket lpak;
	if (Scm_Load(fn, 0, &lpak) >= 0) {
		return TRUE;
	} else {
		error_exit(lpak.exception);
		return FALSE;
	}
}

int main(int argc, char* argv[]) {
	GC_INIT();
	Scm_Init(GAUCHE_SIGNATURE);
	Scm_AddLoadPath("../Gauche-0.8.14/winnt/share/gauche/0.8.14/lib", FALSE);

	ScmModule *module = Scm_UserModule();
	init_cptr_class(module);
	Scm_Init_SDL(module);

	dofile("./entry.scm");
	Scm_Exit(0);

	return 0;
}
  • todo:
    • 型チェックでassertにしているのを型エラーにする
    • 定数定義

hchbawhchbaw2009/07/09 14:36こんにちは、はじめまして!言及されたのに反応しました!

自分なら Gauche 側から触りやすくするために <SDL_Rect> などと定義しちゃいます。でもこれひとつひとつやっつけてゆくのって退屈なんですよね。そこで c-wrapper、となるのでしょうね。で試しに epeg でやってみたらば、(use c-wrapper) (c-load '("Epeg.h")) だけでマッピングやらなにやら全て終っちゃいました。(^^;

mokehehemokehehe2009/07/10 00:38c-wrapperすごいですね。どうやってるのか仕組みを知りたいところです。

トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20090708

2009-07-06

Gauche0.8.14をVC2008でビルドする

なんか毎回初めから挑戦しなおしてる気がする。

手始めにCygwinでビルド。最近はCygwinでビルドしようとするとなぜか configure の段階で「C compiler cannot create executable」とか出て困ってた。configure.log を見たら、単に環境変数 LIBS に Windows のパスが設定されていてあらぬエラーを引き起こしていただけだった。LIBS を空にしてビルド:

  • ./configure
  • シンボリックリンクがないので、gc/libatomic_ops-1.2 を libatomic_ops にリネーム(同名の空ファイル(シンボリックリンクの残骸?)があるので削除してから)
  • make

できた。次はVC2008でビルドする:

  • winnt ディレクトリにGauche.slnがあるのでVCで開く。
  • gc/include/gc.h で _beginthread などのマクロを定義しているがシステムの process.h とぶつかるので、先にprocess.hをincludeするようにする
...
# ifndef GC_NO_THREAD_REDIRECTS
#  ifdef _MSC_VER
#   include <process.h>
#  endif
#   define CreateThread GC_CreateThread
...
  • libgaucheの「追加のインクルードディレクトリ」に「..\gc\libatomic_ops\src」を追加
  • ext/net/gauche/net.hでinet_pton, inet_ntopが既定義エラーが出るので、コメントアウト
#if !(NTDDI_VERSION >= NTDDI_LONGHORN)
int inet_pton(int af, const char *src, void *dst);
const char *inet_ntop(int af, const void *src, char *dst, socklen_t size);
#endif
  • ext-digest-md5のプロジェクトに含まれるmd5.cがないのでプロジェクトから削除
  • ext-digest-sha1のプロジェクトに含まれるsha1.cがないのでプロジェクトから削除

でビルドに成功、winnt/Debugにlibgauche.lib,dllやgosh.exeなどができる。

プロジェクトgoshを「スタートアップ プロジェクトに設定」して実行する:

gosh: WARNING: Error while loading initialization file: cannot find file "gauche
-init.scm" in *load-path* ("/usr/local/share/gauche/site/lib" "/usr/local/share/
gauche/0.8.14/lib")(error).

というエラーが出る。

  • src/gauche/arch.h内のGAUCHE_LIB_DIR, GAUCHE_SITE_LIB_DIRをなどを修正する
#define GAUCHE_ARCH "i686-pc-cygwin"
#define GAUCHE_LIB_DIR "C:\\cygwin\\usr\\local\\share\\gauche\\0.8.14\\lib"
#define GAUCHE_ARCH_DIR "C:\\cygwin\\usr\\local\\lib\\gauche\\0.8.14\\i686-pc-cygwin"
#define GAUCHE_SITE_LIB_DIR "C:\\cygwin\\usr\\local\\share\\gauche\\site\\lib"
#define GAUCHE_SITE_ARCH_DIR "C:\\cygwin\\usr\\local\\lib\\gauche\\site\\0.8.14\\i686-pc-cygwin"
  • whileや、(use srfi-1)も普通に使えた
  • 毎回フルビルドがかかる。ビルドイベントの「ビルド前のイベント」に「cscript configure.js」が入ってるけど、毎回winnt/gauche/config.hが作られてしまうので「ビルドから除外」を「はい」にする
追記

winnt/winvc-prep.sh の実行を忘れてた

  • シェルから sh winnt/winvc-prep.sh を実行する
    • configureが行われて、src/gauche/arch.hも作られる
  • ビルド
  • winnt/share/gauche というディレクトリを掘って C:\cygwin\usr\local\share\gauche の中身をコピー
  • winnt/lib/gauche/site/0.8.14/i686-pc-winnt というディレクトリを掘って winnt/(Debug|Release)/*.dll をコピー
Release版は設定がちゃんとされてない
  • すべてのプロジェクトの「中間ディレクトリ」を「$(ProjectName)\$(ConfigurationName)」にする
  • libgaucheのプロパティの「追加のインクルードディレクトリ」と「プリプロセッサの定義」と「リンカ/追加の依存ファイル」をDebug版とあわせる
  • libgauche/srcのbuiltin-syms.c, dl_win.c, getdir_win.cを「ビルドから除外」を「はい」にする
  • gosh, test-vmstack, test-arithの「追加のインクルードディレクトリ」をDebug版とあわせる
  • ext-charconvの「プリコンパイル済みヘッダーの作成/使用」を「使用しない」にする
    • eucj2ucs.c, guess_tab.c, ucs2eucj.c を「ビルドから除外」
  • ext-auxsys, ext-net, gauche-configの「リンカ/追加の依存ファイル」をDebug版とあわせる

ext-netとext-charconvで_imp__Scm_StringClassがどうのというエラーが取れない…

------ ビルド開始: プロジェクト: ext-net, 構成: Release Win32 ------
リンクしています...
warning C4743: '_imp__Scm_StringClass' は、'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\net\netaux.c' および 'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\net\addr.c' 内で異なるサイズを含んでいます: 4 および 100 バイト
warning C4744: '_imp__Scm_StringClass' は、'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\net\netaux.c' および 'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\net\addr.c' 内で異なる型を含んでいます: 'pointer' および 'struct (100 bytes)'
warning C4743: '_imp__Scm_StringClass' は、'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\net\netlib.c' および 'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\net\addr.c' 内で異なるサイズを含んでいます: 4 および 100 バイト
warning C4744: '_imp__Scm_StringClass' は、'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\net\netlib.c' および 'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\net\addr.c' 内で異なる型を含んでいます: 'pointer' および 'struct (100 bytes)'
addr.obj : error LNK2001: 外部シンボル "_Scm_StringClass" は未解決です。
D:\gauche\Gauche-0.8.14\winnt\Release\ext-net.dll : fatal error LNK1120: 外部参照 1 が未解決です。

------ ビルド開始: プロジェクト: ext-charconv, 構成: Release Win32 ------
リンクしています...
warning C4743: '_imp__Scm_StringClass' は、'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\charconv\convaux.c' および 'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\charconv\charconv.c' 内で異なるサイズを含んでいます: 4 および 100 バイト
warning C4744: '_imp__Scm_StringClass' は、'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\charconv\convaux.c' および 'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\charconv\charconv.c' 内で異なる型を含んでいます: 'pointer' および 'struct (100 bytes)'
warning C4743: '_imp__Scm_StringClass' は、'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\charconv\convlib.c' および 'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\charconv\charconv.c' 内で異なるサイズを含んでいます: 4 および 100 バイト
warning C4744: '_imp__Scm_StringClass' は、'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\charconv\convlib.c' および 'd:\home\repos\lisp\gauche\Gauche-0.8.14\ext\charconv\charconv.c' 内で異なる型を含んでいます: 'pointer' および 'struct (100 bytes)'
charconv.obj : error LNK2001: 外部シンボル "_Scm_StringClass" は未解決です。
D:\gauche\Gauche-0.8.14\winnt\Release\ext-charconv.dll : fatal error LNK1120: 外部参照 1 が未解決です。

masa_edwmasa_edw2009/07/07 11:52結局mingwのSDLをcygwinのc-wrapperから使うことはあの時点で諦めてその後挑戦していませんでした。c-wrapper-0.5.5自体はcygwin上でビルドできていました。0.6.0では試していません。cygcheckはdllの依存性を確かめるツールです(dllに対しても使えます)。Linuxでいうところのlddのようなものです。

mokehehemokehehe2009/07/07 21:03Windows環境で使うのは難しそうですね。

トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20090706

2008-09-16

Gauche+SDLでテトリスを作ってみた

f:id:mokehehe:20080916225144p:image

CでSDLへのバインディングをちょっと書いて、Schemeでテトリスを作ってみた。逐次脳なので、Schemeの恩恵はあまり得られてないように感じる。Scheme のソースは全部で691行、使ってる ! の数は 61個。

クラスとかコルーチンとか使ってみた。

entry.scm
(require "util")
(require "coroutine")

;;; constant 

(define-constant ScreenWidth 320)
(define-constant ScreenHeight 400)

(define-constant FrameTicks (quotient 1000 60))

(define Blocks
  '#(
     (#(#(0 1 0 0)
        #(0 1 0 0)
        #(0 1 0 0)
        #(0 1 0 0))
      (255 0 0))
     (#(#(0 0 0 0)
        #(0 1 1 0)
        #(0 1 1 0)
        #(0 0 0 0))
      (255 255 0))
     (#(#(0 0 0 0)
        #(0 0 1 1)
        #(0 1 1 0)
        #(0 0 0 0))
      (255 0 255))
     (#(#(0 0 0 0)
        #(1 1 0 0)
        #(0 1 1 0)
        #(0 0 0 0))
      (0 255 0))
     (#(#(0 0 0 0)
        #(0 1 0 0)
        #(0 1 1 1)
        #(0 0 0 0))
      (0 0 255))
     (#(#(0 0 0 0)
        #(0 0 1 0)
        #(1 1 1 0)
        #(0 0 0 0))
      (255 128 0))
     (#(#(0 0 0 0)
        #(0 1 0 0)
        #(1 1 1 0)
        #(0 0 0 0))
      (0 255 255))
     ))


(define (color r g b)
  (list r g b))




;;; include
(require "font")
(require "random")
(require "field")
(require "player")
(require "pad")


;;; main-routine

(define (main-loop co)
  (let ((player (make <Player>))
        (*pad* 0)
        (*opad* 0)
        (*trg* 0)
        (*high-score* 0))

    (define (init-game-all)
      (init-game player)
      )
    
    (define (update-pad)
      (set! *opad* *pad*)
      (set! *pad* (get-pad-key-state))
      (set! *trg* (logand *pad* (lognot *opad*)))
      )
    
    (define (my-yield)
      (yield co)
      (rand)
      (update-pad))

    (define (render-high-score)
      (let1 sc (score-of player)
        (when (< *high-score* sc)
          (set! *high-score* sc)))
      (put-string 200 10 (string-append "HI-SC:" (number->string *high-score*))))
    
    (define (title)
      (let ((cnt 0))
        (let loop ()
          (my-yield)
          (render player)
          (render-high-score)
          
          (cond ((pad-active? *trg* 'PadA)
                 (game))
                (else
                 (inc! cnt)
                 (when (< (remainder cnt 120) 60)
                   (put-string 200 300 "PUSH SPACE KEY"))
                 (loop))))))
    
    (define (game)
      (init-game-all)
      (let loop ()
        (my-yield)
        
        (update player *pad* *trg*)
        (render player)
        (render-high-score)
        
        (if (game-over? player)
            (game-over)
          (loop))))
    
    (define (game-over)
      (let ((cnt 0))
        (let loop ()
          (my-yield)
          
          (render player)
          (render-high-score)
          (when (pad-active? *trg* 'PadA)
            (title))
          
          (inc! cnt)
          (put-string 200 300 "GAME OVER")
          (if (>= cnt (* 10 60))
              (title)
            (loop)))))
    
    (title)))

;;; entry point
(define (entry)
  (define (term)
    (term_SDL))
  
  (define (init)
    (unless (init_SDL "scheme-tetris" ScreenWidth ScreenHeight)
      #f)
    
    (init-font "font.png")
    
    #t)
  
  (when (init)
    (let ((loop-co (make-coroutine main-loop)))
      (while (and (flip FrameTicks) (zero? (get_key_state SDLK_ESCAPE)))
        (wake loop-co))))
  (term))
player.scm
(require "pad") 
;(require "coroutine")

(define-constant GroundTime (* 1 60))
(define-constant AdditionalTime 1)

(define-constant InitialFallSpeed 60)
(define-constant MinimumFallSpeed -5)

;stat:
;  Normal
;  Ground
;  EraseEffect
;  EraseEffect2
;  Dead
;  GameOver

(define (null-proc))

;;; Player
(define-class <Player> ()
  ((field :accessor field-of :init-value (make-field))
   (stat :accessor stat-of :init-value 'GameOver)
   (x :accessor x-of :init-value 0)
   (y :accessor y-of :init-value 0)
   (rot :accessor rot-of :init-value 0)
   (curblk :accessor curblk-of :init-value #f)
   (nextblk :accessor nextblk-of :init-value #f)
   (ycnt :accessor ycnt-of :init-value 0)
   (score :accessor score-of :init-value 0)
   (fall-speed :accessor fall-speed-of :init-value 0)
   (update-co :accessor update-co-of :init-value null-proc)
   ))

(define-method init-game ((this <Player>))
  (set! (field-of this) (make-field))
  (set! (nextblk-of this) (random-integer (vector-length Blocks)))
  (set! (fall-speed-of this) InitialFallSpeed)
  (set! (score-of this) 0)
  (set! (stat-of this) 'Normal)
  
  (set! (update-co-of this)
        (make-coroutine (lambda (co)
                          (update-co this co))))
  
  (next-block this))

(define-method next-block ((this <Player>))
  (set! (stat-of this) 'Normal)
  (set! (x-of this) (quotient (- FieldWidth 4) 2))
  (set! (y-of this) 0)
  (set! (curblk-of this) (nextblk-of this))
  (set! (nextblk-of this) (random-integer (vector-length Blocks)))
  (set! (rot-of this) 0)
  (dec! (fall-speed-of this))
  (when (< (fall-speed-of this) MinimumFallSpeed)
    (set! (fall-speed-of this) InitialFallSpeed))
  (set! (ycnt-of this) (fall-speed-of this))
  )

(define pad '())
(define trg '())

(define-method update ((this <Player>) pad_ trg_)
  (set! pad pad_)
  (set! trg trg_)
  (wake (update-co-of this)))

(define (update-co this co)
  (define (my-yield)
    (yield co))
  
  ; すでに壁があったら死亡
  (define (update-next-block)
    (next-block this)
    (if (can-move? (field-of this) (x-of this) (y-of this) (curblk-of this) (rot-of this))
        (update-normal)
      (update-dead)))
  
  (define (add-score add)
    (inc! (score-of this) add))
  
  (define (add-erase-line n)
    (add-score (* 10 (square n))))

  (define (move newx newy newrot)
    (if (can-move? (field-of this) newx newy (curblk-of this) newrot)
        (begin
          (set! (x-of this) newx)
          (set! (y-of this) newy)
          (set! (rot-of this) newrot)
          #t)
      #f))
  
  (define (control-block this)
    (let ((move? #f))
      (define (move-test newx newy newrot)
        (when (move newx newy newrot)
          (set! move? #t)))
      (when (pad-active? trg 'PadL)
        (move-test (-1+ (x-of this)) (y-of this) (rot-of this)))
      (when (pad-active? trg 'PadR)
        (move-test (1+ (x-of this)) (y-of this) (rot-of this)))
      
      (let ((dr (+
                 (if (pad-active? trg 'PadA) 1 0)
                 (if (pad-active? trg 'PadB) 3 0))))
        (when (!= dr 0)
          (unless (move-test (x-of this) (y-of this) (remainder (+ dr (rot-of this)) 4))
            (move-test (x-of this) (-1+ (y-of this)) (remainder (+ dr (rot-of this)) 4))))
        )
      move?))
  
  (define (erase-field-lines lines)
    (dolist (y lines)
      (clear-field-line (field-of this) y)))
  
  (define (fall-field-lines lines)
    (let ((n (length lines)))
      (dolist (y lines)
        (for (i y 0 -1)
          (copy-field-line (field-of this) (-1+ i) i)))
      (clear-field-line (field-of this) 0)
      (add-erase-line n)))
  
  (define (update-normal)
    (my-yield)
    
    (control-block this)
    (when (pad-active? pad 'PadD)
      (move (x-of this) (1+ (y-of this)) (rot-of this)))
    
    (dec! (ycnt-of this))
    (if (<= (ycnt-of this) 0)
      (if (move (x-of this) (1+ (y-of this)) (rot-of this))
          (begin
            (set! (ycnt-of this) (fall-speed-of this))
            (update-normal))
        (begin
          (set! (stat-of this) 'Ground)
          (set! (ycnt-of this) GroundTime)
          (update-ground)))
      (update-normal)))
  
  (define (update-ground)
    (my-yield)
    
    (when (control-block this)
      (inc! (ycnt-of this) AdditionalTime))
    
    (when (move (x-of this) (1+ (y-of this)) (rot-of this))
      (set! (ycnt-of this) GroundTime))
    
    (dec! (ycnt-of this))
    (if (<= (ycnt-of this) 0)
        (begin
          (store-block (field-of this) (x-of this) (y-of this) (curblk-of this) (rot-of this))
          (let1 erase-lines (check-erase-line (field-of this) (y-of this))
            (if (null? erase-lines)
                (update-next-block)
              (update-erase-effect erase-lines))))
      (update-ground)))
  
  (define (update-erase-effect lines)
    (erase-field-lines lines)
    (set! (stat-of this) 'EraseEffect)
    
    (let loop ((ycnt 0))
      (my-yield)
      
      (if (>= ycnt 60)
          (update-erase-effect2 lines)
        (loop (1+ ycnt)))))
  
  (define (update-erase-effect2 lines)
    (fall-field-lines lines)
    (set! (stat-of this) 'EraseEffect2)
    
    (let loop ((ycnt 0))
      (my-yield)
      
      (if (>= ycnt 60)
          (update-next-block)
        (loop (1+ ycnt)))))
  
  (define (update-dead)
    (store-block (field-of this) (x-of this) (y-of this) (curblk-of this) (rot-of this))
    (set! (nextblk-of this) #f)
    (set! (stat-of this) 'Dead)
    
    ;; death effect
    (for (i 0 (-1+ FieldHeight))
      (my-yield)
      (set-field-gray (field-of this) i)
      (dotimes (j 7)
        (my-yield)))
    
    ;; wait
    (dotimes (i (* 2 60))
      (my-yield))
    
    (set! (stat-of this) 'GameOver)
    (update-game-over))
  
  (define (update-game-over)
    (for-ever
     (my-yield)))
  
  (update-normal))

(define-method render ((this <Player>))
  (define (render-block)
    (render-tetromino (x-of this) (y-of this) (curblk-of this) (rot-of this)))

  (define (render-next-block)
    (when (nextblk-of this)
      (render-tetromino (+ FieldWidth 3) 5 (nextblk-of this) 0)))

  (define (render-ghost-block)
    (define (calc-fall-y)
      (let loop ((y (y-of this)))
        (if (can-move? (field-of this) (x-of this) (1+ y) (curblk-of this) (rot-of this))
            (loop (1+ y))
          y)))
    (let1 y (calc-fall-y)
      (render-tetromino (x-of this) y (curblk-of this) (rot-of this) 'ghost)))

  (put-string 200 20 (string-append "SCORE:" (number->string (score-of this))))
  
  (render-field (field-of this) 0 0)
  (when (or (eq? (stat-of this) 'Normal)
            (eq? (stat-of this) 'Ground))
    (render-ghost-block)
    (render-block))
  (render-next-block))

(define-method game-over? ((this <Player>))
  (eq? (stat-of this) 'GameOver))
field.scm
(require "util") 

;;;; Field 

(define-constant FieldWidth (+ 10 2)) 
(define-constant FieldHeight (+ 20 4)) 

(define-constant BlockWidth 16)
(define-constant BlockHeight 16)

(define-constant Empty -1)
(define-constant Wall -2)

;;; constructor
(define (make-field)
  (let ((field (make-2dvector FieldWidth FieldHeight Empty)))
    (dotimes (i FieldHeight)
      (field-set! field 0 i Wall)
      (field-set! field (-1+ FieldWidth) i Wall))
    (dotimes (j FieldWidth)
      (field-set! field j (-1+ FieldHeight) Wall))
    field))

(define (field-range? x y)
  (and (<= 0 x) (<= 0 y) (< x FieldWidth) (< y FieldHeight)))

(define (field-set! field x y c)
  (if (field-range? x y)
      (vector-set! (vector-ref field y) x c)))

(define (field-ref field x y)
  (if (field-range? x y)
      (vector-ref (vector-ref field y) x)
    (raise "Illegal range of field: (%d, %d)" x y)))

;;; copy line of field, src to dst
(define (copy-field-line field src dst)
  (for (x 1 (-1+ FieldWidth))
       (field-set! field x dst (field-ref field x src))))

;;; clear 1 line of field
(define (clear-field-line field y)
  (for (x 1 (-1+ FieldWidth))
       (field-set! field x y Empty)))

;;; gray-nize
(define (set-field-gray field y)
  (for (x 1 (-1+ FieldWidth))
    (when (!= (field-ref field x y) Empty)
      (field-set! field x y Wall))))

;;; render
(define (render-field field bx by)
  (define (get-cell-color c)
    (cond ((= c Wall) (color 128 128 128))
          ((>= c 0)
           (let ((cc (cadr (vector-ref Blocks c))))
             (color (car cc) (cadr cc) (caddr cc))))
          (else (raise "get-cell-color"))))
  
  (dotimes (i FieldHeight)
    (dotimes (j FieldWidth)
      (let ((c (field-ref field j i)))
        (if (!= c Empty)
            (render-cell (+ j bx) (+ i by) (get-cell-color c)))))))

(define (render-cell j i col)
  (let* ((x (* j BlockWidth))
         (y (* i BlockHeight))
         (rc (list x y (-1+ BlockWidth) (-1+ BlockHeight))))
    (fill rc col)))



;;; execute block point with field
(define (block-field-do x y c rot proc)
  (let* ((blk (vector-ref Blocks c))
         (pat (rotate-2dvector (car blk) rot)))
    (dotimes (i 4)
      (dotimes (j 4)
        (if (!= (2dvector-ref pat j i) 0)
            (let ((xx (+ x j))
                  (yy (+ y i)))
              (if (field-range? xx yy)
                  (proc xx yy))))))))

;;; can move?
(define (can-move? field x y c rot)
  (call/cc
   (lambda (return)
     (block-field-do x y c rot
                     (lambda (xx yy)
                       (if (!= (field-ref field xx yy) Empty)
                           (return #f))))
     #t)))

(define (store-block field x y c rot)
  (block-field-do x y c rot
                  (lambda (xx yy)
                    (field-set! field xx yy c))))

(define (line-filled? field y)
  (call/cc
   (lambda (return)
     (dotimes (j FieldWidth)
       (if (= (field-ref field j y) Empty)
           (return #f)))
     #t)))

(define (check-erase-line field y)
  (let ((res '()))
    (dotimes (i (min 4 (- FieldHeight y 1))
                (reverse! res))
      (if (line-filled? field (+ y i))
          (push! res (+ y i))))))

(define (render-tetromino x y c rot . rest)
  (let* ((blk (vector-ref Blocks c))
         (pat (rotate-2dvector (car blk) rot))
         (c (cadr blk))
         (col (if (null? rest)
                  (color (car c) (cadr c) (caddr c))
                (color (int (* 0.25 (car c)))
                       (int (* 0.25 (cadr c)))
                       (int (* 0.25 (caddr c)))))))
    (dotimes (i 4)
      (dotimes (j 4)
        (if (!= (2dvector-ref pat j i) 0)
            (render-cell (+ x j) (+ y i) col))))))
coroutine.scm
(define-class <Coroutine> ()
  ((cc :accessor cc-of)))

(define (make-coroutine f)
  (define (end co)
    (yield co)
    (end co))
  (let ((co (make <Coroutine>)))
    (set! (cc-of co)
          (lambda (co)
            (f co)
            (end co)))
    co))

(define-method yield ((this <Coroutine>))
  (call/cc
   (lambda (next-cc)
     (let ((ret-cc (cc-of this)))
       (set! (cc-of this) next-cc)
       (ret-cc)))))

(define-method wake ((this <Coroutine>))
  (call/cc
   (lambda (ret-cc)
     (let ((cc (cc-of this)))
       (set! (cc-of this) ret-cc)
       (cc this)))))
pad.scm
;(use srfi-1)  ; list-index
(require "srfi-1")
(import srfi-1)

(define PadKeys 
  '((PadU SDLK_UP) 
    (PadD SDLK_DOWN) 
    (PadR SDLK_RIGHT) 
    (PadL SDLK_LEFT) 
    (PadA SDLK_SPACE) 
    (PadB SDLK_z) 
    ))

(define (get-pad-key-state)
  (let ((pad 0)
        (module (find-module 'user))) 
    (dotimes (i (length PadKeys) pad)
      (let ((k (global-variable-ref module (cadr (list-ref PadKeys i)))))
        (if (!= (get_key_state k) 0)
            (set! pad (logior pad (ash 1 i))))))))

(define (pad-active? pad btn)
  (let ((idx (list-index (lambda (x) (eq? (car x) btn)) PadKeys)))
    (!= 0 (logand pad (ash 1 idx)))))
font.scm
;(use srfi-13)  ; string-for-each
(require "srfi-13")
(import srfi-13)

(define *font* '())

(define-constant FontW 8)
(define-constant FontH 8)

(define (init-font font-fn)
  (set! *font* (load_image font-fn)))

(define (put-char x y c)
  (let ((i (char->integer c)))
    (receive (q r) (quotient&remainder i 32)
             (let ((u (* r FontW))
                   (v (* q FontH)))
               (put_image *font* x y u v FontW FontH)))))

(define (put-string x y s)
  (string-for-each (lambda (c)
                     (put-char x y c)
                     (inc! x FontW))
                   s))
random.scm
;(require "srfi-27") 組み込むとなぜか使えなかった 
;(import srfi-27) 

(define-constant RAND_MAX 32767) 

(define *rand-seed* 1)

(define (srand seed)
  (set! *rand-seed* seed))

(define (rand)
  (set! *rand-seed* (remainder (+ (* *rand-seed* 1566083941) 1) (* 65536 65536)))
  (quotient *rand-seed* (* 2 65536)))

(define (random-integer n)
  (quotient (* (rand) n) (+ RAND_MAX 1)))
util.scm
(define-syntax for
  (syntax-rules ()
    ((_ (%i %from %to) %body ...)
     (for (%i %from %to 1)
          %body ...))
    ((_ (%i %from %to %step) %body ...)
     (let ((to %to)
           (step %step))
       (let1 yet? (if (> step 0) < >)
          (let loop ((%i %from))
            (when (yet? %i to)
              %body ...
              (loop (+ %i step)))))))))

(define-syntax for-ever
  (syntax-rules ()
    ((_ body ...)
     (let loop ()
       body ...
       (loop)))))

(define (1+ x)
  (+ x 1))

(define (-1+ x)
  (- x 1))

;(define != (compose not =))  うまくいかない 
(define (!= x y) (not (= x y)))

;;; float->integer
(define (int x)
  (floor->exact x))

(define (square x) (* x x))


;;; vector
(define (make-vector-with len proc)
  (let ((vec (make-vector len)))
    (dotimes (i len vec)
      (vector-set! vec i (proc i)))))

(define (make-2dvector w h . args)
  (let-optionals* args ((init (undefined)))
                  (make-vector-with h (lambda (i)
                                        (make-vector w init)))))

;;; 2d vector
(define (2dvector-ref vec x y)
  (vector-ref (vector-ref vec y) x))

;;; rotate 2dvector clock-wise
(define (rotate-2dvector vec n)
  (if (<= n 0)
      vec
    (let* ((w (vector-length (vector-ref vec 0)))
           (h (vector-length vec))
           (newvec (make-2dvector w h)))
      (dotimes (i h)
        (dotimes (j w)
          (let ((c (2dvector-ref vec i (- h j 1))))
            (vector-set! (vector-ref newvec i) j c))))
      (rotate-2dvector newvec (-1+ n)))))
Cのソース(起動部のみ)
#define	GAUCHE_API_0_9
#include <gauche.h>
#include <SDL/SDL.h>
#include <stdio.h>

#include "sdl-lib.h"
#include "sdl-binding.h"

bool load_scm(const char* scriptfile) {
	ScmLoadPacket lpak;
	return Scm_Load(scriptfile, 0, &lpak) >= 0;
}

void call_proc(ScmSymbol* proc_sym, ScmObj args) {
	ScmModule* module = Scm_UserModule();
	ScmObj proc = Scm_GlobalVariableRef(module, proc_sym, 0);
	Scm_Apply(proc, args, NULL);
}

int main(int argc, char* argv[]) {
	GC_INIT();
	Scm_Init(GAUCHE_SIGNATURE);
	Scm_AddLoadPath("./scm", FALSE);
	Scm_AddLoadPath("./scmlib", FALSE);
	ScmModule *module = Scm_UserModule();
	init_sdl_funcs(module);

	if (!load_scm("entry.scm")) {
		fprintf(stderr, "Can't load script file\n");
	} else {
		ScmSymbol* sym_entry = SCM_SYMBOL(SCM_INTERN("entry"));
		call_proc(sym_entry, SCM_NIL);
	}

	Scm_Exit(0);
	return 0;
}
  • Gaucheを組み込んで使うには、なかなかヘビーだと思った
    • gauche/common-macros.scm などを実行時に読み込む
    • srfi-1-lib.dll, srfi-13-lib.dll などの dll を組み込む必要がある
    • GC が Boehm

g000001g0000012008/09/18 00:21Shibuya.lispのLTとかこれから募集すると思いますが、お一つどうですか!

mokehehemokehehe2008/09/18 14:21それはいい話ですね、ぜひお願いします!

g000001g0000012008/09/19 23:07LT募集の告知がそのうち出ると思いますので是非応募してみてください! イベント自体は10/18日(土)というところまでは決まっています。

mokehehemokehehe2008/09/20 19:25了解です。ネタを考えてます。

g000001g0000012008/09/23 02:33こんにちは、LTの募集が告知になりました。
http://shibuya.lisp-users.org/2008/09/23/sltt-1/
の下にあるようにメールで申し込んでもらうことになりました。
もの凄く期待していますので、よろしくお願いします!!

mokehehemokehehe2008/09/23 20:50たいした話はできませんが、応募してみます!

トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20080916

2008-09-11

srfi-1 を使おうとするとエラー

list-index が使いたいので

(use srfi-1)

とするとエラー。use がスペシャルフォームになってなくて srfi-1 が変数として扱われてしまってるぽい。use の代わりに、

(require "srfi-1")
(import srfi-1)

とするも、"srfi-1-lib.dll" を読みにいってる。srfi-1.scm はあるけど dll はなかったので load-path にコピー。

組み込んだ Gauche で while とかを使うとエラーが発生する

VC上のプロジェクトにGaucheを組み込んで、簡単なスクリプトを動かすのはできた。さてなんかアプリを作ろうかと Scheme のスクリプトを書き出したら実行時エラーが出るようになった。エラーメッセージの出力方法がわからないので追うのがすごく辛い。Scm_Error() とか Scm_VMThrowException() にブレークを張ってなんとかひっかける。

どこでエラーが出るようになるかスクリプトを削っていくと、while を使うとエラーが発生するようになるっぽい。VM を1命令ごとに実行させていくと while を使うところで load() が呼び出されて、"gauche/common-macros.scm" なるソースを勝手に読みに行っている。でファイルを探す(Scm_FindFile())ときのパスが libgauche.dll のある位置の一つ上(get_install_dir())からの相対(GAUCHE_LIB_DIR "@\\share\\gauche\\0.8.13\\lib", GAUCHE_SITE_LIB_DIR "@\\share\\gauche\\site\\lib")になっていて、そこにファイルがなくてエラーになっていた。構成的には

usr/
  local/
    bin/
      libgauche.dll
    share/
      gauche/
        0.8.13/
          [ライブラリ群]
        site/
          [ライブラリ群]

解決するには、ライブラリのscmソースをそのような位置に配置するか、add-load-path を使うかするといい:

	Scm_AddLoadPath("./scmlib", FALSE);

while を使ったときに自動的に読み込まれるファイルは gauche/common-macros.scmsrfi-26.scm(cutとか)。autoload で必要なライブラリだけ読み込むってのはハイテクで、便利だなぁ。

g000001g0000012008/09/11 21:04ですね、クオートされたような感じですよね。
確かに表記が紛らわしい気もしますねー。
ちなみにCLだとバッククオートが使えて
(let ((foo '(1 2 3))) `#(,@foo))
;=> #(1 2 3)
みたいにも書けます。GaucheでもOKみたいですが、Scheme仕様でも決まっているんでしょうか('-'*)

mokehehemokehehe2008/09/11 21:22バッククォートはベクトルにも効くんですか、それもビビりました。深いなぁ…。

ka-nachtka-nacht2008/09/11 23:11R5RSの6.3.6を読む限りだとそういうもののようですね。
#(a b c ...) => (vector 'a 'b 'c ...)ということでしょうか。

本題とは全然関係ありませんが、#(obj ...)はベクトルの外部表現であってベクトルへと評価される式ではないので、厳密にはクォートしなければならないようです。Gaucheは自己評価しているようですけれど。

mokehehemokehehe2008/09/12 08:36なるほど。調べたところ、「プログラミングGauche」の中にも記述がありました:「クォートされていないベクタリテラルの振舞いはSchemeの規格では定義されていません」
http://books.google.com/books?id=cf7gMn3zx1AC&printsec=frontcover&as_brr=3&hl=ja#PRA2-PA215,M1
クォートをつけるなら内部が評価されないのは自然ですね。

mokehehemokehehe2009/08/27 08:05http://d.hatena.ne.jp/leque/20090825/p2

2008-09-09

Gauche を Windows/VisualC でビルド

  • Cygwin上 で Gaucheのルートディレクトリに行って $ sh winnt/winvc-prep.sh
  • VCgaucheのヘッダがあるディレクトリ(C:\cygwin\usr\local\lib\gauche\0.8.13\include\gauche)にパスを通す
  • winnt/Gauche.sln を開いてビルド
    • libgauche のビルド前イベントで「cscript configure.js」をしている
      • これによってwinnt/gauche/config.h が作られる
  • winnt/Debug or Release に lib とか exe ができる
組み込んで使いたい
  • Gauche は現在のところコンパイル結果を保存しておけないので、組み込みにはいまいちか
    • つっても内部ソースはコンパイル済みの形式で持ってるから、なんか手はあるのかも
  • 参考:gosh のメインルーチン:src/main.c
  • VCからビルドするとき:
    • VC 用の config.h をインクルードするために、インクルードパスに winnt を追加する
    • win-compat.h をインクルードできるように、src にパスを通す(gauche.h から include されてる)
    • 「文字セット」は「マルチバイト文字」、「64ビット移植への対応」は「いいえ」にする
  • リンク:
    • libgauche.lib だけでも OK
      • libgauche で使ってるのは、src と gc の中のソースだけ
  • 実行:
    • DLL になってるので、libgauche.dll を読める位置に置く
#include <gauche.h>
#include <stdio.h>
int main() {
	ScmObj obj, r;
	GC_INIT();
	Scm_Init(GAUCHE_SIGNATURE);
	obj = Scm_ReadFromCString("(+ 3 4)");
	r = Scm_Eval(obj, SCM_OBJ(Scm_UserModule()));
	printf("result=%d\n", SCM_INT_VALUE(r));
	Scm_Exit(0);
	return 0;
}
  • 入力文字コードを確かめたい
		ScmObj oport = Scm_Stdout();
		Scm_SetCurrentOutputPort(SCM_PORT(oport));
    • * - hogeなlog
    • Scm_ReadFromCString を Scm_EvalCString にしたらそのまま出た
      • 「#define GAUCHE_API_0_9」しないとプロトタイプ宣言がない。宣言すると、引数の数が違くて怒られる
		Scm_EvalCString("(print \"こんにちは、世界!\n\")", SCM_NIL, NULL);
    • ソースがSJISでもUTF-8でも漢字が表示されない…
      • config.h では「#define GAUCHE_CHAR_ENCODING_UTF_8 1」となっていてソースもUTF-8で保存してるのになぁ?
schemeの関数を呼び出す
Cの関数を呼び出す
#define	GAUCHE_API_0_9
#include <gauche.h>
#include <stdio.h>

static ScmObj cfunc(ScmObj *SCM_FP, int SCM_ARGCNT, void *data_) {
	ScmObj o = SCM_ARGREF(0);
	if (SCM_STRINGP(o)) {
		const char* s = Scm_GetStringConst(SCM_STRING(o));
		printf("arg: [%s]\n", s);
	}
	SCM_RETURN(SCM_MAKE_INT(1234));
}

static SCM_DEFINE_STRING_CONST(cfunc__NAME, "cfunc", 5, 5);
static SCM_DEFINE_SUBR(cfunc__STUB, 1, 0, SCM_OBJ(&cfunc__NAME), cfunc, NULL, NULL);

void test_call_c_func() {
	ScmModule *module = Scm_UserModule();
	SCM_DEFINE(module, "cfunc", SCM_OBJ(&cfunc__STUB));
	Scm_EvalCString("(print (cfunc \"Hello, cfunc!\"))", SCM_NIL, NULL);
}

int main() {
	GC_INIT();
	Scm_Init(GAUCHE_SIGNATURE);
	test_call_c_func();
	Scm_Exit(0);
	return 0;
}
ToDo
  • エラーハンドリング
トラックバック - http://cadr.g.hatena.ne.jp/mokehehe/20080909