Artifact
a5eab89f2a99cffbb7a0d9779db153b6ca3ba39b:
0000: 28 72 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 (require-library
0010: 0a 09 6c 6f 6c 65 76 65 6c 20 64 61 74 61 2d 73 ..lolevel data-s
0020: 74 72 75 63 74 75 72 65 73 20 65 78 74 72 61 73 tructures extras
0030: 20 73 72 66 69 2d 31 20 73 72 66 69 2d 31 33 20 srfi-1 srfi-13
0040: 73 72 66 69 2d 34 32 20 69 72 72 65 67 65 78 20 srfi-42 irregex
0050: 70 6f 73 69 78 29 0a 0a 28 6d 6f 64 75 6c 65 20 posix)..(module
0060: 69 75 70 2d 62 61 73 65 0a 09 28 69 68 61 6e 64 iup-base..(ihand
0070: 6c 65 2d 3e 70 6f 69 6e 74 65 72 20 70 6f 69 6e le->pointer poin
0080: 74 65 72 2d 3e 69 68 61 6e 64 6c 65 20 69 68 61 ter->ihandle iha
0090: 6e 64 6c 65 2d 6c 69 73 74 2d 3e 70 6f 69 6e 74 ndle-list->point
00a0: 65 72 2d 76 65 63 74 6f 72 20 69 68 61 6e 64 6c er-vector ihandl
00b0: 65 3f 0a 09 20 69 73 74 61 74 75 73 2d 3e 69 6e e?.. istatus->in
00c0: 74 65 67 65 72 20 69 6e 74 65 67 65 72 2d 3e 69 teger integer->i
00d0: 73 74 61 74 75 73 0a 09 20 69 6e 61 6d 65 2d 3e status.. iname->
00e0: 73 74 72 69 6e 67 20 73 74 72 69 6e 67 2d 3e 69 string string->i
00f0: 6e 61 6d 65 0a 09 20 74 68 72 65 61 64 2d 77 61 name.. thread-wa
0100: 74 63 68 64 6f 67 20 69 75 70 2d 76 65 72 73 69 tchdog iup-versi
0110: 6f 6e 20 6c 6f 61 64 2f 6c 65 64 0a 09 20 61 74 on load/led.. at
0120: 74 72 69 62 75 74 65 20 61 74 74 72 69 62 75 74 tribute attribut
0130: 65 2d 73 65 74 21 20 61 74 74 72 69 62 75 74 65 e-set! attribute
0140: 2d 72 65 73 65 74 21 0a 09 20 68 61 6e 64 6c 65 -reset!.. handle
0150: 2d 6e 61 6d 65 20 68 61 6e 64 6c 65 2d 6e 61 6d -name handle-nam
0160: 65 2d 73 65 74 21 20 68 61 6e 64 6c 65 2d 72 65 e-set! handle-re
0170: 66 0a 09 20 6d 61 69 6e 2d 6c 6f 6f 70 20 6d 61 f.. main-loop ma
0180: 69 6e 2d 6c 6f 6f 70 2d 73 74 65 70 20 6d 61 69 in-loop-step mai
0190: 6e 2d 6c 6f 6f 70 2d 6c 65 76 65 6c 20 6d 61 69 n-loop-level mai
01a0: 6e 2d 6c 6f 6f 70 2d 65 78 69 74 20 6d 61 69 6e n-loop-exit main
01b0: 2d 6c 6f 6f 70 2d 66 6c 75 73 68 0a 09 20 63 61 -loop-flush.. ca
01c0: 6c 6c 62 61 63 6b 20 63 61 6c 6c 62 61 63 6b 2d llback callback-
01d0: 73 65 74 21 0a 09 20 6d 61 6b 65 2d 63 6f 6e 73 set!.. make-cons
01e0: 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 tructor-procedur
01f0: 65 20 6f 70 74 69 6f 6e 61 6c 2d 61 72 67 73 0a e optional-args.
0200: 09 20 63 72 65 61 74 65 20 64 65 73 74 72 6f 79 . create destroy
0210: 21 20 6d 61 70 2d 70 65 65 72 21 20 75 6e 6d 61 ! map-peer! unma
0220: 70 2d 70 65 65 72 21 0a 09 20 63 6c 61 73 73 2d p-peer!.. class-
0230: 6e 61 6d 65 20 63 6c 61 73 73 2d 74 79 70 65 20 name class-type
0240: 73 61 76 65 2d 61 74 74 72 69 62 75 74 65 73 21 save-attributes!
0250: 0a 09 20 70 61 72 65 6e 74 20 70 61 72 65 6e 74 .. parent parent
0260: 2d 64 69 61 6c 6f 67 20 73 69 62 6c 69 6e 67 0a -dialog sibling.
0270: 09 20 63 68 69 6c 64 2d 61 64 64 21 20 63 68 69 . child-add! chi
0280: 6c 64 2d 72 65 6d 6f 76 65 21 20 63 68 69 6c 64 ld-remove! child
0290: 2d 6d 6f 76 65 21 0a 09 20 63 68 69 6c 64 2d 72 -move!.. child-r
02a0: 65 66 20 63 68 69 6c 64 2d 70 6f 73 20 63 68 69 ef child-pos chi
02b0: 6c 64 2d 63 6f 75 6e 74 0a 09 20 3a 63 68 69 6c ld-count.. :chil
02c0: 64 72 65 6e 20 63 68 69 6c 64 72 65 6e 0a 09 20 dren children..
02d0: 72 65 66 72 65 73 68 20 72 65 64 72 61 77 0a 09 refresh redraw..
02e0: 20 63 68 69 6c 64 2d 78 2f 79 2d 3e 70 6f 73 0a child-x/y->pos.
02f0: 09 20 73 68 6f 77 20 68 69 64 65 0a 09 20 64 69 . show hide.. di
0300: 61 6c 6f 67 0a 09 20 66 69 6c 6c 20 68 62 6f 78 alog.. fill hbox
0310: 20 76 62 6f 78 20 7a 62 6f 78 20 63 62 6f 78 20 vbox zbox cbox
0320: 73 62 6f 78 0a 09 20 72 61 64 69 6f 20 6e 6f 72 sbox.. radio nor
0330: 6d 61 6c 69 7a 65 72 20 73 70 6c 69 74 0a 09 20 malizer split..
0340: 69 6d 61 67 65 2f 70 61 6c 65 74 74 65 20 69 6d image/palette im
0350: 61 67 65 2f 72 67 62 20 69 6d 61 67 65 2f 72 67 age/rgb image/rg
0360: 62 61 20 69 6d 61 67 65 2f 66 69 6c 65 20 69 6d ba image/file im
0370: 61 67 65 2d 73 61 76 65 0a 09 20 63 75 72 72 65 age-save.. curre
0380: 6e 74 2d 66 6f 63 75 73 20 66 6f 63 75 73 2d 6e nt-focus focus-n
0390: 65 78 74 20 66 6f 63 75 73 2d 70 72 65 76 69 6f ext focus-previo
03a0: 75 73 0a 09 20 6d 65 6e 75 20 6d 65 6e 75 2d 69 us.. menu menu-i
03b0: 74 65 6d 20 6d 65 6e 75 2d 73 65 70 61 72 61 74 tem menu-separat
03c0: 6f 72 0a 09 20 63 6c 69 70 62 6f 61 72 64 20 74 or.. clipboard t
03d0: 69 6d 65 72 20 73 65 6e 64 2d 75 72 6c 29 0a 09 imer send-url)..
03e0: 28 69 6d 70 6f 72 74 0a 09 09 73 63 68 65 6d 65 (import...scheme
03f0: 20 63 68 69 63 6b 65 6e 20 66 6f 72 65 69 67 6e chicken foreign
0400: 0a 09 09 6c 6f 6c 65 76 65 6c 20 64 61 74 61 2d ...lolevel data-
0410: 73 74 72 75 63 74 75 72 65 73 20 65 78 74 72 61 structures extra
0420: 73 20 73 72 66 69 2d 31 20 73 72 66 69 2d 31 33 s srfi-1 srfi-13
0430: 20 73 72 66 69 2d 34 32 20 69 72 72 65 67 65 78 srfi-42 irregex
0440: 0a 09 09 28 6f 6e 6c 79 20 70 6f 73 69 78 20 73 ...(only posix s
0450: 65 74 65 6e 76 29 29 0a 0a 3b 3b 20 7b 7b 7b 20 etenv))..;; {{{
0460: 44 61 74 61 20 74 79 70 65 73 0a 0a 28 66 6f 72 Data types..(for
0470: 65 69 67 6e 2d 64 65 63 6c 61 72 65 0a 09 22 23 eign-declare.."#
0480: 69 6e 63 6c 75 64 65 20 3c 63 61 6c 6c 62 61 63 include <callbac
0490: 6b 2e 68 3e 5c 6e 22 0a 09 22 23 69 6e 63 6c 75 k.h>\n".."#inclu
04a0: 64 65 20 3c 69 75 70 2e 68 3e 5c 6e 22 0a 09 22 de <iup.h>\n".."
04b0: 23 69 6e 63 6c 75 64 65 20 3c 69 75 70 69 6d 2e #include <iupim.
04c0: 68 3e 5c 6e 22 0a 09 22 74 79 70 65 64 65 66 20 h>\n".."typedef
04d0: 73 74 72 75 63 74 20 49 63 6c 61 73 73 5f 20 49 struct Iclass_ I
04e0: 63 6c 61 73 73 3b 5c 6e 22 0a 09 22 73 74 72 75 class;\n".."stru
04f0: 63 74 20 49 68 61 6e 64 6c 65 5f 20 7b 20 63 68 ct Ihandle_ { ch
0500: 61 72 20 73 69 67 5b 34 5d 3b 20 49 63 6c 61 73 ar sig[4]; Iclas
0510: 73 20 2a 69 63 6c 61 73 73 3b 20 2f 2a 20 2e 2e s *iclass; /* ..
0520: 2e 20 2a 2f 20 7d 20 3b 5c 6e 22 0a 09 22 65 78 . */ } ;\n".."ex
0530: 74 65 72 6e 20 63 68 61 72 20 2a 69 75 70 43 6c tern char *iupCl
0540: 61 73 73 43 61 6c 6c 62 61 63 6b 47 65 74 46 6f assCallbackGetFo
0550: 72 6d 61 74 28 49 63 6c 61 73 73 20 2a 69 63 6c rmat(Iclass *icl
0560: 61 73 73 2c 20 63 6f 6e 73 74 20 63 68 61 72 20 ass, const char
0570: 2a 6e 61 6d 65 29 3b 5c 6e 22 29 0a 0a 28 64 65 *name);\n")..(de
0580: 66 69 6e 65 20 2a 69 68 61 6e 64 6c 65 2d 74 61 fine *ihandle-ta
0590: 67 2a 20 22 49 68 61 6e 64 6c 65 22 29 0a 28 64 g* "Ihandle").(d
05a0: 65 66 69 6e 65 20 69 68 61 6e 64 6c 65 3f 20 28 efine ihandle? (
05b0: 63 75 74 20 74 61 67 67 65 64 2d 70 6f 69 6e 74 cut tagged-point
05c0: 65 72 3f 20 3c 3e 20 2a 69 68 61 6e 64 6c 65 2d er? <> *ihandle-
05d0: 74 61 67 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 tag*))..(define
05e0: 28 69 68 61 6e 64 6c 65 2d 3e 70 6f 69 6e 74 65 (ihandle->pointe
05f0: 72 20 6e 6f 6e 6e 75 6c 6c 3f 29 0a 09 28 69 66 r nonnull?)..(if
0600: 20 6e 6f 6e 6e 75 6c 6c 3f 0a 09 09 28 6c 61 6d nonnull?...(lam
0610: 62 64 61 20 28 68 61 6e 64 6c 65 29 0a 09 09 09 bda (handle)....
0620: 28 65 6e 73 75 72 65 20 69 68 61 6e 64 6c 65 3f (ensure ihandle?
0630: 20 68 61 6e 64 6c 65 29 0a 09 09 09 68 61 6e 64 handle)....hand
0640: 6c 65 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 68 le)...(lambda (h
0650: 61 6e 64 6c 65 29 0a 09 09 09 28 65 6e 73 75 72 andle)....(ensur
0660: 65 20 28 64 69 73 6a 6f 69 6e 20 6e 6f 74 20 69 e (disjoin not i
0670: 68 61 6e 64 6c 65 3f 29 20 68 61 6e 64 6c 65 29 handle?) handle)
0680: 0a 09 09 09 68 61 6e 64 6c 65 29 29 29 0a 0a 28 ....handle)))..(
0690: 64 65 66 69 6e 65 20 28 70 6f 69 6e 74 65 72 2d define (pointer-
06a0: 3e 69 68 61 6e 64 6c 65 20 6e 6f 6e 6e 75 6c 6c >ihandle nonnull
06b0: 3f 29 0a 09 28 69 66 20 6e 6f 6e 6e 75 6c 6c 3f ?)..(if nonnull?
06c0: 0a 09 09 28 6c 61 6d 62 64 61 20 28 68 61 6e 64 ...(lambda (hand
06d0: 6c 65 29 0a 09 09 09 28 65 6e 73 75 72 65 20 70 le)....(ensure p
06e0: 6f 69 6e 74 65 72 3f 20 68 61 6e 64 6c 65 29 0a ointer? handle).
06f0: 09 09 09 28 74 61 67 2d 70 6f 69 6e 74 65 72 20 ...(tag-pointer
0700: 68 61 6e 64 6c 65 20 2a 69 68 61 6e 64 6c 65 2d handle *ihandle-
0710: 74 61 67 2a 29 29 0a 09 09 28 6c 61 6d 62 64 61 tag*))...(lambda
0720: 20 28 68 61 6e 64 6c 65 29 0a 09 09 09 28 61 6e (handle)....(an
0730: 64 20 68 61 6e 64 6c 65 20 28 74 61 67 2d 70 6f d handle (tag-po
0740: 69 6e 74 65 72 20 68 61 6e 64 6c 65 20 2a 69 68 inter handle *ih
0750: 61 6e 64 6c 65 2d 74 61 67 2a 29 29 29 29 29 0a andle-tag*))))).
0760: 0a 28 64 65 66 69 6e 65 20 28 69 68 61 6e 64 6c .(define (ihandl
0770: 65 2d 6c 69 73 74 2d 3e 70 6f 69 6e 74 65 72 2d e-list->pointer-
0780: 76 65 63 74 6f 72 20 6c 73 74 29 0a 09 28 6c 65 vector lst)..(le
0790: 74 20 28 5b 70 74 72 73 20 28 6d 61 6b 65 2d 70 t ([ptrs (make-p
07a0: 6f 69 6e 74 65 72 2d 76 65 63 74 6f 72 20 28 61 ointer-vector (a
07b0: 64 64 31 20 28 6c 65 6e 67 74 68 20 6c 73 74 29 dd1 (length lst)
07c0: 29 20 23 66 29 5d 29 0a 09 09 28 64 6f 2d 65 63 ) #f)])...(do-ec
07d0: 20 28 3a 6c 69 73 74 20 68 61 6e 64 6c 65 20 28 (:list handle (
07e0: 69 6e 64 65 78 20 69 29 20 6c 73 74 29 0a 09 09 index i) lst)...
07f0: 09 28 62 65 67 69 6e 0a 09 09 09 09 28 65 6e 73 .(begin.....(ens
0800: 75 72 65 20 69 68 61 6e 64 6c 65 3f 20 68 61 6e ure ihandle? han
0810: 64 6c 65 29 0a 09 09 09 09 28 70 6f 69 6e 74 65 dle).....(pointe
0820: 72 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 70 74 r-vector-set! pt
0830: 72 73 20 69 20 68 61 6e 64 6c 65 29 29 29 0a 09 rs i handle)))..
0840: 09 70 74 72 73 29 29 0a 0a 28 64 65 66 69 6e 65 .ptrs))..(define
0850: 20 28 69 73 74 61 74 75 73 2d 3e 69 6e 74 65 67 (istatus->integ
0860: 65 72 20 73 74 61 74 75 73 29 0a 09 28 63 61 73 er status)..(cas
0870: 65 20 73 74 61 74 75 73 0a 09 09 5b 28 65 72 72 e status...[(err
0880: 6f 72 29 20 20 20 20 20 20 20 20 20 20 20 20 20 or)
0890: 20 20 20 20 2b 31 5d 0a 09 09 5b 28 6f 70 65 6e +1]...[(open
08a0: 65 64 20 69 6e 76 61 6c 69 64 20 69 67 6e 6f 72 ed invalid ignor
08b0: 65 29 20 2d 31 5d 0a 09 09 5b 28 64 65 66 61 75 e) -1]...[(defau
08c0: 6c 74 29 20 20 20 20 20 20 20 20 20 20 20 20 20 lt)
08d0: 20 20 2d 32 5d 0a 09 09 5b 28 63 6c 6f 73 65 20 -2]...[(close
08e0: 23 66 29 20 20 20 20 20 20 20 20 20 20 20 20 20 #f)
08f0: 20 2d 33 5d 0a 09 09 5b 28 63 6f 6e 74 69 6e 75 -3]...[(continu
0900: 65 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e)
0910: 2d 34 5d 0a 09 09 5b 65 6c 73 65 20 20 20 20 20 -4]...[else
0920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0930: 69 66 20 28 69 6e 74 65 67 65 72 3f 20 73 74 61 if (integer? sta
0940: 74 75 73 29 20 73 74 61 74 75 73 20 30 29 5d 29 tus) status 0)])
0950: 29 0a 0a 28 64 65 66 69 6e 65 20 28 69 6e 74 65 )..(define (inte
0960: 67 65 72 2d 3e 69 73 74 61 74 75 73 20 73 74 61 ger->istatus sta
0970: 74 75 73 29 0a 09 28 63 61 73 65 20 73 74 61 74 tus)..(case stat
0980: 75 73 0a 09 09 5b 28 2b 31 29 20 27 65 72 72 6f us...[(+1) 'erro
0990: 72 5d 0a 09 09 5b 28 20 30 29 20 23 74 5d 0a 09 r]...[( 0) #t]..
09a0: 09 5b 28 2d 31 29 20 27 69 67 6e 6f 72 65 5d 0a .[(-1) 'ignore].
09b0: 09 09 5b 28 2d 32 29 20 27 64 65 66 61 75 6c 74 ..[(-2) 'default
09c0: 5d 0a 09 09 5b 28 2d 33 29 20 23 66 5d 0a 09 09 ]...[(-3) #f]...
09d0: 5b 28 2d 34 29 20 27 63 6f 6e 74 69 6e 75 65 5d [(-4) 'continue]
09e0: 0a 09 09 5b 65 6c 73 65 20 73 74 61 74 75 73 5d ...[else status]
09f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 69 6e 61 ))..(define (ina
0a00: 6d 65 2d 3e 73 74 72 69 6e 67 20 64 65 66 61 75 me->string defau
0a10: 6c 74 2d 63 61 73 65 29 0a 09 28 6c 65 74 20 28 lt-case)..(let (
0a20: 5b 63 68 61 6e 67 65 2d 63 61 73 65 0a 09 20 20 [change-case..
0a30: 20 20 20 20 20 28 63 61 73 65 20 64 65 66 61 75 (case defau
0a40: 6c 74 2d 63 61 73 65 0a 09 20 20 20 20 20 20 20 lt-case..
0a50: 09 20 5b 28 75 70 63 61 73 65 29 20 20 20 73 74 . [(upcase) st
0a60: 72 69 6e 67 2d 75 70 63 61 73 65 5d 0a 09 20 20 ring-upcase]..
0a70: 20 20 20 20 20 09 20 5b 28 64 6f 77 6e 63 61 73 . [(downcas
0a80: 65 29 20 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 e) string-downca
0a90: 73 65 5d 0a 09 20 20 20 20 20 20 20 09 20 5b 65 se].. . [e
0aa0: 6c 73 65 20 20 20 20 20 20 20 28 65 72 72 6f 72 lse (error
0ab0: 20 27 69 6e 61 6d 65 2d 3e 73 74 72 69 6e 67 20 'iname->string
0ac0: 22 75 6e 73 75 70 70 6f 72 74 65 64 20 64 65 66 "unsupported def
0ad0: 61 75 6c 74 20 63 61 73 65 22 20 64 65 66 61 75 ault case" defau
0ae0: 6c 74 2d 63 61 73 65 29 5d 29 5d 29 0a 09 09 28 lt-case)])])...(
0af0: 6c 61 6d 62 64 61 20 28 6e 61 6d 65 29 0a 09 09 lambda (name)...
0b00: 09 28 63 6f 6e 64 0a 09 09 09 09 5b 28 6f 72 20 .(cond.....[(or
0b10: 28 6e 6f 74 20 6e 61 6d 65 29 20 28 73 74 72 69 (not name) (stri
0b20: 6e 67 3f 20 6e 61 6d 65 29 29 0a 09 09 09 09 20 ng? name)).....
0b30: 6e 61 6d 65 5d 0a 09 09 09 09 5b 28 73 79 6d 62 name].....[(symb
0b40: 6f 6c 3f 20 6e 61 6d 65 29 0a 09 09 09 09 20 28 ol? name)..... (
0b50: 63 68 61 6e 67 65 2d 63 61 73 65 20 28 73 74 72 change-case (str
0b60: 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 28 73 ing-translate (s
0b70: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e 61 ymbol->string na
0b80: 6d 65 29 20 23 5c 2d 20 23 5c 5f 29 29 5d 0a 09 me) #\- #\_))]..
0b90: 09 09 09 5b 65 6c 73 65 0a 09 09 09 09 20 28 65 ...[else..... (e
0ba0: 72 72 6f 72 20 27 69 6e 61 6d 65 2d 3e 73 74 72 rror 'iname->str
0bb0: 69 6e 67 20 22 62 61 64 20 6e 61 6d 65 22 20 6e ing "bad name" n
0bc0: 61 6d 65 29 5d 29 29 29 29 0a 0a 28 64 65 66 69 ame)]))))..(defi
0bd0: 6e 65 20 28 73 74 72 69 6e 67 2d 3e 69 6e 61 6d ne (string->inam
0be0: 65 20 64 65 66 61 75 6c 74 2d 63 61 73 65 29 0a e default-case).
0bf0: 09 28 6c 65 74 20 28 5b 73 70 65 63 69 61 6c 73 .(let ([specials
0c00: 0a 09 20 20 20 20 20 20 20 28 69 72 72 65 67 65 .. (irrege
0c10: 78 0a 09 20 20 20 20 20 20 20 09 20 28 63 61 73 x.. . (cas
0c20: 65 20 64 65 66 61 75 6c 74 2d 63 61 73 65 0a 09 e default-case..
0c30: 20 20 20 20 20 20 20 09 20 09 20 5b 28 75 70 63 . . [(upc
0c40: 61 73 65 29 20 20 20 22 5b 2d 61 2d 7a 5d 22 5d ase) "[-a-z]"]
0c50: 0a 09 20 20 20 20 20 20 20 09 20 09 20 5b 28 64 .. . . [(d
0c60: 6f 77 6e 63 61 73 65 29 20 22 5b 2d 41 2d 5a 5d owncase) "[-A-Z]
0c70: 22 5d 0a 09 20 20 20 20 20 20 20 09 20 09 20 5b "].. . . [
0c80: 65 6c 73 65 20 20 20 20 20 20 20 28 65 72 72 6f else (erro
0c90: 72 20 27 73 74 72 69 6e 67 2d 3e 69 6e 61 6d 65 r 'string->iname
0ca0: 20 22 75 6e 73 75 70 70 6f 72 74 65 64 20 64 65 "unsupported de
0cb0: 66 61 75 6c 74 20 63 61 73 65 22 20 64 65 66 61 fault case" defa
0cc0: 75 6c 74 2d 63 61 73 65 29 5d 29 29 5d 29 0a 09 ult-case)]))])..
0cd0: 09 28 6c 61 6d 62 64 61 20 28 6e 61 6d 65 29 0a .(lambda (name).
0ce0: 09 09 09 28 63 6f 6e 64 0a 09 09 09 09 5b 28 6f ...(cond.....[(o
0cf0: 72 20 28 6e 6f 74 20 6e 61 6d 65 29 20 28 69 72 r (not name) (ir
0d00: 72 65 67 65 78 2d 73 65 61 72 63 68 20 73 70 65 regex-search spe
0d10: 63 69 61 6c 73 20 6e 61 6d 65 29 29 0a 09 09 09 cials name))....
0d20: 09 20 6e 61 6d 65 5d 0a 09 09 09 09 5b 65 6c 73 . name].....[els
0d30: 65 0a 09 09 09 09 20 28 73 74 72 69 6e 67 2d 3e e..... (string->
0d40: 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 symbol (string-d
0d50: 6f 77 6e 63 61 73 65 20 28 73 74 72 69 6e 67 2d owncase (string-
0d60: 74 72 61 6e 73 6c 61 74 65 20 6e 61 6d 65 20 23 translate name #
0d70: 5c 5f 20 23 5c 2d 29 29 29 5d 29 29 29 29 0a 0a \_ #\-)))]))))..
0d80: 28 69 6e 63 6c 75 64 65 20 22 69 75 70 2d 74 79 (include "iup-ty
0d90: 70 65 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 7d 7d pes.scm")..;; }}
0da0: 7d 0a 0a 3b 3b 20 7b 7b 7b 20 53 75 70 70 6f 72 }..;; {{{ Suppor
0db0: 74 20 6d 61 63 72 6f 73 20 61 6e 64 20 66 75 6e t macros and fun
0dc0: 63 74 69 6f 6e 73 0a 0a 28 64 65 66 69 6e 65 2d ctions..(define-
0dd0: 73 79 6e 74 61 78 20 3a 63 68 69 6c 64 72 65 6e syntax :children
0de0: 0a 09 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 ..(syntax-rules
0df0: 28 29 0a 09 09 5b 28 3a 63 68 69 6c 64 72 65 6e ()...[(:children
0e00: 20 63 63 20 63 68 69 6c 64 20 68 61 6e 64 6c 65 cc child handle
0e10: 29 0a 09 09 20 28 3a 64 6f 20 63 63 20 28 5b 63 )... (:do cc ([c
0e20: 68 69 6c 64 20 28 63 68 69 6c 64 2d 72 65 66 20 hild (child-ref
0e30: 68 61 6e 64 6c 65 20 30 29 5d 29 20 63 68 69 6c handle 0)]) chil
0e40: 64 20 28 28 73 69 62 6c 69 6e 67 20 63 68 69 6c d ((sibling chil
0e50: 64 29 29 29 5d 29 29 0a 0a 28 64 65 66 69 6e 65 d)))]))..(define
0e60: 2d 73 79 6e 74 61 78 20 6f 70 74 69 6f 6e 61 6c -syntax optional
0e70: 2d 61 72 67 73 0a 09 28 73 79 6e 74 61 78 2d 72 -args..(syntax-r
0e80: 75 6c 65 73 20 28 29 0a 09 09 5b 28 6f 70 74 69 ules ()...[(opti
0e90: 6f 6e 61 6c 2d 61 72 67 73 20 5b 6e 61 6d 65 20 onal-args [name
0ea0: 64 65 66 61 75 6c 74 5d 20 2e 2e 2e 29 0a 09 09 default] ...)...
0eb0: 20 28 6c 61 6d 62 64 61 20 28 61 72 67 73 29 20 (lambda (args)
0ec0: 28 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 20 61 (let-optionals a
0ed0: 72 67 73 20 28 5b 6e 61 6d 65 20 64 65 66 61 75 rgs ([name defau
0ee0: 6c 74 5d 20 2e 2e 2e 29 20 28 6c 69 73 74 20 6e lt] ...) (list n
0ef0: 61 6d 65 20 2e 2e 2e 29 29 29 5d 29 29 0a 0a 28 ame ...)))]))..(
0f00: 64 65 66 69 6e 65 20 28 28 6d 61 6b 65 2d 63 6f define ((make-co
0f10: 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 nstructor-proced
0f20: 75 72 65 20 70 72 6f 63 20 23 21 6b 65 79 20 5b ure proc #!key [
0f30: 61 70 70 6c 79 2d 61 72 67 73 20 76 61 6c 75 65 apply-args value
0f40: 73 5d 29 20 2e 20 61 72 67 73 29 0a 09 28 6c 65 s]) . args)..(le
0f50: 74 20 6d 6f 72 65 20 28 5b 6b 65 79 73 20 27 28 t more ([keys '(
0f60: 29 5d 20 5b 6b 65 79 2d 61 72 67 73 20 27 28 29 )] [key-args '()
0f70: 5d 20 5b 70 6f 73 2d 61 72 67 73 20 27 28 29 5d ] [pos-args '()]
0f80: 20 5b 72 65 73 74 20 61 72 67 73 5d 29 0a 09 09 [rest args])...
0f90: 28 63 6f 6e 64 0a 09 09 09 5b 28 6e 75 6c 6c 3f (cond....[(null?
0fa0: 20 72 65 73 74 29 0a 09 09 09 20 28 6c 65 74 20 rest).... (let
0fb0: 28 5b 68 61 6e 64 6c 65 20 28 61 70 70 6c 79 20 ([handle (apply
0fc0: 70 72 6f 63 20 28 61 70 70 6c 79 2d 61 72 67 73 proc (apply-args
0fd0: 20 28 72 65 76 65 72 73 65 21 20 70 6f 73 2d 61 (reverse! pos-a
0fe0: 72 67 73 29 29 29 5d 29 0a 09 09 09 20 09 20 28 rgs)))]).... . (
0ff0: 64 6f 2d 65 63 20 28 3a 70 61 72 61 6c 6c 65 6c do-ec (:parallel
1000: 20 28 3a 6c 69 73 74 20 6b 65 79 20 6b 65 79 73 (:list key keys
1010: 29 20 28 3a 6c 69 73 74 20 61 72 67 20 6b 65 79 ) (:list arg key
1020: 2d 61 72 67 73 29 29 0a 09 09 09 20 09 20 09 20 -args)).... . .
1030: 28 28 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f ((if (procedure?
1040: 20 61 72 67 29 20 63 61 6c 6c 62 61 63 6b 2d 73 arg) callback-s
1050: 65 74 21 20 61 74 74 72 69 62 75 74 65 2d 73 65 et! attribute-se
1060: 74 21 29 20 68 61 6e 64 6c 65 20 6b 65 79 20 61 t!) handle key a
1070: 72 67 29 29 0a 09 09 09 20 09 20 68 61 6e 64 6c rg)).... . handl
1080: 65 29 5d 0a 09 09 09 5b 28 6b 65 79 77 6f 72 64 e)]....[(keyword
1090: 3f 20 28 63 61 72 20 72 65 73 74 29 29 0a 09 09 ? (car rest))...
10a0: 09 20 28 6d 6f 72 65 0a 09 09 09 20 09 20 28 63 . (more.... . (c
10b0: 6f 6e 73 20 28 63 61 72 20 72 65 73 74 29 20 6b ons (car rest) k
10c0: 65 79 73 29 20 28 63 6f 6e 73 20 28 63 61 64 72 eys) (cons (cadr
10d0: 20 72 65 73 74 29 20 6b 65 79 2d 61 72 67 73 29 rest) key-args)
10e0: 20 70 6f 73 2d 61 72 67 73 0a 09 09 09 20 09 20 pos-args.... .
10f0: 28 63 64 64 72 20 72 65 73 74 29 29 5d 0a 09 09 (cddr rest))]...
1100: 09 5b 65 6c 73 65 0a 09 09 09 20 28 6d 6f 72 65 .[else.... (more
1110: 0a 09 09 09 20 09 20 6b 65 79 73 20 6b 65 79 2d .... . keys key-
1120: 61 72 67 73 20 28 63 6f 6e 73 20 28 63 61 72 20 args (cons (car
1130: 72 65 73 74 29 20 70 6f 73 2d 61 72 67 73 29 0a rest) pos-args).
1140: 09 09 09 20 09 20 28 63 64 72 20 72 65 73 74 29 ... . (cdr rest)
1150: 29 5d 29 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b )])))..;; }}}..;
1160: 3b 20 7b 7b 7b 20 53 79 73 74 65 6d 20 66 75 6e ; {{{ System fun
1170: 63 74 69 6f 6e 73 0a 0a 28 64 65 66 69 6e 65 20 ctions..(define
1180: 69 75 70 2d 76 65 72 73 69 6f 6e 0a 09 28 66 6f iup-version..(fo
1190: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 63 2d 73 reign-lambda c-s
11a0: 74 72 69 6e 67 20 22 49 75 70 56 65 72 73 69 6f tring "IupVersio
11b0: 6e 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 6c 6f n"))..(define lo
11c0: 61 64 2f 6c 65 64 0a 09 28 6c 65 74 72 65 63 20 ad/led..(letrec
11d0: 28 5b 6c 6f 61 64 2f 72 61 77 20 28 66 6f 72 65 ([load/raw (fore
11e0: 69 67 6e 2d 6c 61 6d 62 64 61 20 63 2d 73 74 72 ign-lambda c-str
11f0: 69 6e 67 20 22 49 75 70 4c 6f 61 64 22 20 63 2d ing "IupLoad" c-
1200: 73 74 72 69 6e 67 29 5d 29 0a 09 09 28 6c 61 6d string)])...(lam
1210: 62 64 61 20 28 66 69 6c 65 29 0a 09 09 09 28 61 bda (file)....(a
1220: 6e 64 2d 6c 65 74 2a 20 28 5b 73 74 61 74 75 73 nd-let* ([status
1230: 20 28 6c 6f 61 64 2f 72 61 77 20 66 69 6c 65 29 (load/raw file)
1240: 5d 29 0a 09 09 09 09 28 65 72 72 6f 72 20 27 6c ]).....(error 'l
1250: 6f 61 64 2f 6c 65 64 20 73 74 61 74 75 73 29 29 oad/led status))
1260: 0a 09 09 09 28 76 6f 69 64 29 29 29 29 0a 0a 3b ....(void))))..;
1270: 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 41 74 ; }}}..;; {{{ At
1280: 74 72 69 62 75 74 65 20 66 75 6e 63 74 69 6f 6e tribute function
1290: 73 0a 0a 28 64 65 66 69 6e 65 20 61 74 74 72 69 s..(define attri
12a0: 62 75 74 65 2d 73 65 74 21 0a 20 20 28 6c 65 74 bute-set!. (let
12b0: 72 65 63 20 28 5b 73 65 74 2f 73 74 72 69 6e 67 rec ([set/string
12c0: 21 20 28 66 6f 72 65 69 67 6e 2d 73 61 66 65 2d ! (foreign-safe-
12d0: 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 49 75 70 lambda void "Iup
12e0: 53 74 6f 72 65 41 74 74 72 69 62 75 74 65 22 20 StoreAttribute"
12f0: 69 68 61 6e 64 6c 65 20 69 6e 61 6d 65 2f 75 70 ihandle iname/up
1300: 63 61 73 65 20 63 2d 73 74 72 69 6e 67 29 5d 0a case c-string)].
1310: 20 20 20 20 20 20 20 20 20 20 20 5b 73 65 74 2f [set/
1320: 68 61 6e 64 6c 65 21 20 28 66 6f 72 65 69 67 6e handle! (foreign
1330: 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 76 6f 69 -safe-lambda voi
1340: 64 20 22 49 75 70 53 65 74 41 74 74 72 69 62 75 d "IupSetAttribu
1350: 74 65 48 61 6e 64 6c 65 22 20 69 68 61 6e 64 6c teHandle" ihandl
1360: 65 20 69 6e 61 6d 65 2f 75 70 63 61 73 65 20 69 e iname/upcase i
1370: 68 61 6e 64 6c 65 29 5d 29 0a 20 20 20 20 28 6c handle)]). (l
1380: 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 20 6e 61 ambda (handle na
1390: 6d 65 20 76 61 6c 75 65 29 0a 20 20 20 20 09 28 me value). .(
13a0: 63 6f 6e 64 0a 20 20 20 20 09 09 5b 28 6f 72 20 cond. ..[(or
13b0: 28 6e 6f 74 20 76 61 6c 75 65 29 20 28 73 74 72 (not value) (str
13c0: 69 6e 67 3f 20 76 61 6c 75 65 29 29 0a 20 20 20 ing? value)).
13d0: 20 20 20 20 20 20 28 73 65 74 2f 73 74 72 69 6e (set/strin
13e0: 67 21 20 68 61 6e 64 6c 65 20 6e 61 6d 65 20 76 g! handle name v
13f0: 61 6c 75 65 29 5d 0a 20 20 20 20 20 20 20 20 5b alue)]. [
1400: 28 69 68 61 6e 64 6c 65 3f 20 76 61 6c 75 65 29 (ihandle? value)
1410: 0a 20 20 20 20 20 20 20 20 20 28 73 65 74 2f 68 . (set/h
1420: 61 6e 64 6c 65 21 20 68 61 6e 64 6c 65 20 6e 61 andle! handle na
1430: 6d 65 20 76 61 6c 75 65 29 5d 0a 20 20 20 20 20 me value)].
1440: 20 20 20 5b 28 62 6f 6f 6c 65 61 6e 3f 20 76 61 [(boolean? va
1450: 6c 75 65 29 0a 20 20 20 20 20 20 20 20 20 28 73 lue). (s
1460: 65 74 2f 73 74 72 69 6e 67 21 20 68 61 6e 64 6c et/string! handl
1470: 65 20 6e 61 6d 65 20 28 69 66 20 76 61 6c 75 65 e name (if value
1480: 20 22 59 45 53 22 20 22 4e 4f 22 29 29 5d 0a 20 "YES" "NO"))].
1490: 20 20 20 20 20 20 20 5b 65 6c 73 65 0a 20 20 20 [else.
14a0: 20 20 20 20 20 20 28 73 65 74 2f 73 74 72 69 6e (set/strin
14b0: 67 21 20 68 61 6e 64 6c 65 20 6e 61 6d 65 20 28 g! handle name (
14c0: 2d 3e 73 74 72 69 6e 67 20 76 61 6c 75 65 29 29 ->string value))
14d0: 5d 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 61 ]))))..(define a
14e0: 74 74 72 69 62 75 74 65 2d 72 65 73 65 74 21 0a ttribute-reset!.
14f0: 09 28 66 6f 72 65 69 67 6e 2d 73 61 66 65 2d 6c .(foreign-safe-l
1500: 61 6d 62 64 61 20 76 6f 69 64 20 22 49 75 70 52 ambda void "IupR
1510: 65 73 65 74 41 74 74 72 69 62 75 74 65 22 20 69 esetAttribute" i
1520: 68 61 6e 64 6c 65 20 69 6e 61 6d 65 2f 75 70 63 handle iname/upc
1530: 61 73 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 61 ase))..(define a
1540: 74 74 72 69 62 75 74 65 0a 20 20 28 67 65 74 74 ttribute. (gett
1550: 65 72 2d 77 69 74 68 2d 73 65 74 74 65 72 0a 20 er-with-setter.
1560: 20 09 28 66 6f 72 65 69 67 6e 2d 73 61 66 65 2d .(foreign-safe-
1570: 6c 61 6d 62 64 61 20 63 2d 73 74 72 69 6e 67 20 lambda c-string
1580: 22 49 75 70 47 65 74 41 74 74 72 69 62 75 74 65 "IupGetAttribute
1590: 22 20 69 68 61 6e 64 6c 65 20 69 6e 61 6d 65 2f " ihandle iname/
15a0: 75 70 63 61 73 65 29 0a 20 20 09 61 74 74 72 69 upcase). .attri
15b0: 62 75 74 65 2d 73 65 74 21 29 29 0a 0a 28 64 65 bute-set!))..(de
15c0: 66 69 6e 65 20 68 61 6e 64 6c 65 2d 6e 61 6d 65 fine handle-name
15d0: 2d 73 65 74 21 0a 09 28 6c 65 74 72 65 63 20 28 -set!..(letrec (
15e0: 5b 68 61 6e 64 6c 65 2d 73 65 74 21 20 28 66 6f [handle-set! (fo
15f0: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 61 reign-lambda iha
1600: 6e 64 6c 65 20 22 49 75 70 53 65 74 48 61 6e 64 ndle "IupSetHand
1610: 6c 65 22 20 69 6e 61 6d 65 2f 64 6f 77 6e 63 61 le" iname/downca
1620: 73 65 20 69 68 61 6e 64 6c 65 29 5d 29 0a 09 09 se ihandle)])...
1630: 28 6c 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 20 (lambda (handle
1640: 6e 61 6d 65 29 0a 09 09 09 28 68 61 6e 64 6c 65 name)....(handle
1650: 2d 73 65 74 21 20 28 6f 72 20 6e 61 6d 65 20 28 -set! (or name (
1660: 68 61 6e 64 6c 65 2d 6e 61 6d 65 20 68 61 6e 64 handle-name hand
1670: 6c 65 29 29 20 28 61 6e 64 20 6e 61 6d 65 20 68 le)) (and name h
1680: 61 6e 64 6c 65 29 29 29 29 29 0a 0a 28 64 65 66 andle)))))..(def
1690: 69 6e 65 20 68 61 6e 64 6c 65 2d 6e 61 6d 65 0a ine handle-name.
16a0: 20 20 28 67 65 74 74 65 72 2d 77 69 74 68 2d 73 (getter-with-s
16b0: 65 74 74 65 72 0a 20 20 09 28 66 6f 72 65 69 67 etter. .(foreig
16c0: 6e 2d 6c 61 6d 62 64 61 20 69 6e 61 6d 65 2f 64 n-lambda iname/d
16d0: 6f 77 6e 63 61 73 65 20 22 49 75 70 47 65 74 4e owncase "IupGetN
16e0: 61 6d 65 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 ame" nonnull-iha
16f0: 6e 64 6c 65 29 0a 20 20 09 68 61 6e 64 6c 65 2d ndle). .handle-
1700: 6e 61 6d 65 2d 73 65 74 21 29 29 0a 0a 28 64 65 name-set!))..(de
1710: 66 69 6e 65 20 68 61 6e 64 6c 65 2d 72 65 66 0a fine handle-ref.
1720: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
1730: 20 69 68 61 6e 64 6c 65 20 22 49 75 70 47 65 74 ihandle "IupGet
1740: 48 61 6e 64 6c 65 22 20 69 6e 61 6d 65 2f 64 6f Handle" iname/do
1750: 77 6e 63 61 73 65 29 29 0a 0a 3b 3b 20 7d 7d 7d wncase))..;; }}}
1760: 0a 0a 3b 3b 20 7b 7b 7b 20 45 76 65 6e 74 20 66 ..;; {{{ Event f
1770: 75 6e 63 74 69 6f 6e 73 0a 0a 28 64 65 66 69 6e unctions..(defin
1780: 65 20 6d 61 69 6e 2d 6c 6f 6f 70 0a 09 28 6c 65 e main-loop..(le
1790: 74 72 65 63 20 28 5b 6c 6f 6f 70 20 28 66 6f 72 trec ([loop (for
17a0: 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 eign-safe-lambda
17b0: 20 69 73 74 61 74 75 73 20 22 49 75 70 4d 61 69 istatus "IupMai
17c0: 6e 4c 6f 6f 70 22 29 5d 29 0a 09 09 28 6c 61 6d nLoop")])...(lam
17d0: 62 64 61 20 28 29 0a 09 09 09 28 6c 65 74 20 28 bda ()....(let (
17e0: 5b 73 74 61 74 75 73 20 28 6c 6f 6f 70 29 5d 29 [status (loop)])
17f0: 0a 09 09 09 09 28 63 61 73 65 20 73 74 61 74 75 .....(case statu
1800: 73 0a 09 09 09 09 09 5b 28 23 74 29 20 28 76 6f s......[(#t) (vo
1810: 69 64 29 5d 0a 09 09 09 09 09 5b 65 6c 73 65 20 id)]......[else
1820: 28 65 72 72 6f 72 20 27 6d 61 69 6e 2d 6c 6f 6f (error 'main-loo
1830: 70 20 28 66 6f 72 6d 61 74 20 22 65 72 72 6f 72 p (format "error
1840: 20 69 6e 20 49 55 50 20 6d 61 69 6e 20 6c 6f 6f in IUP main loo
1850: 70 20 28 7e 73 29 22 20 73 74 61 74 75 73 29 29 p (~s)" status))
1860: 5d 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ])))))..(define
1870: 6d 61 69 6e 2d 6c 6f 6f 70 2d 73 74 65 70 0a 20 main-loop-step.
1880: 20 28 6c 65 74 72 65 63 20 28 5b 6c 6f 6f 70 2d (letrec ([loop-
1890: 73 74 65 70 20 28 66 6f 72 65 69 67 6e 2d 73 61 step (foreign-sa
18a0: 66 65 2d 6c 61 6d 62 64 61 20 69 73 74 61 74 75 fe-lambda istatu
18b0: 73 20 22 49 75 70 4c 6f 6f 70 53 74 65 70 22 29 s "IupLoopStep")
18c0: 5d 0a 20 20 20 20 20 20 20 20 20 20 20 5b 6c 6f ]. [lo
18d0: 6f 70 2d 73 74 65 70 2f 77 61 69 74 20 28 66 6f op-step/wait (fo
18e0: 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 reign-safe-lambd
18f0: 61 20 69 73 74 61 74 75 73 20 22 49 75 70 4c 6f a istatus "IupLo
1900: 6f 70 53 74 65 70 57 61 69 74 22 29 5d 29 0a 20 opStepWait")]).
1910: 20 20 20 28 6c 61 6d 62 64 61 20 28 70 6f 6c 6c (lambda (poll
1920: 3f 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 5b ?). (let ([
1930: 73 74 61 74 75 73 20 28 28 69 66 20 70 6f 6c 6c status ((if poll
1940: 3f 20 6c 6f 6f 70 2d 73 74 65 70 20 6c 6f 6f 70 ? loop-step loop
1950: 2d 73 74 65 70 2f 77 61 69 74 29 29 5d 29 0a 20 -step/wait))]).
1960: 20 20 20 20 20 20 20 28 63 61 73 65 20 73 74 61 (case sta
1970: 74 75 73 0a 20 20 20 20 20 20 20 20 20 20 5b 28 tus. [(
1980: 65 72 72 6f 72 29 20 28 65 72 72 6f 72 20 27 6d error) (error 'm
1990: 61 69 6e 2d 6c 6f 6f 70 2d 73 74 65 70 20 22 65 ain-loop-step "e
19a0: 72 72 6f 72 20 69 6e 20 49 55 50 20 6d 61 69 6e rror in IUP main
19b0: 20 6c 6f 6f 70 22 29 5d 0a 20 20 20 20 20 20 20 loop")].
19c0: 20 20 20 5b 65 6c 73 65 20 20 20 20 73 74 61 74 [else stat
19d0: 75 73 5d 29 29 29 29 29 0a 0a 28 64 65 66 69 6e us])))))..(defin
19e0: 65 20 6d 61 69 6e 2d 6c 6f 6f 70 2d 6c 65 76 65 e main-loop-leve
19f0: 6c 0a 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 l..(foreign-lamb
1a00: 64 61 20 69 6e 74 20 22 49 75 70 4d 61 69 6e 4c da int "IupMainL
1a10: 6f 6f 70 4c 65 76 65 6c 22 29 29 0a 0a 28 64 65 oopLevel"))..(de
1a20: 66 69 6e 65 20 6d 61 69 6e 2d 6c 6f 6f 70 2d 65 fine main-loop-e
1a30: 78 69 74 0a 09 28 66 6f 72 65 69 67 6e 2d 6c 61 xit..(foreign-la
1a40: 6d 62 64 61 20 76 6f 69 64 20 22 49 75 70 45 78 mbda void "IupEx
1a50: 69 74 4c 6f 6f 70 22 29 29 0a 0a 28 64 65 66 69 itLoop"))..(defi
1a60: 6e 65 20 6d 61 69 6e 2d 6c 6f 6f 70 2d 66 6c 75 ne main-loop-flu
1a70: 73 68 0a 09 28 66 6f 72 65 69 67 6e 2d 73 61 66 sh..(foreign-saf
1a80: 65 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 49 e-lambda void "I
1a90: 75 70 46 6c 75 73 68 22 29 29 0a 0a 28 64 65 66 upFlush"))..(def
1aa0: 69 6e 65 2d 76 61 6c 75 65 73 20 28 72 65 67 69 ine-values (regi
1ab0: 73 74 72 79 2d 73 65 74 21 20 72 65 67 69 73 74 stry-set! regist
1ac0: 72 79 20 72 65 67 69 73 74 72 79 2d 64 65 73 74 ry registry-dest
1ad0: 72 6f 79 21 29 0a 20 20 28 6c 65 74 72 65 63 20 roy!). (letrec
1ae0: 28 5b 72 65 67 69 73 74 72 79 2d 63 65 6c 6c 2d ([registry-cell-
1af0: 73 65 74 21 0a 20 20 09 09 09 09 09 28 66 6f 72 set!. .....(for
1b00: 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 eign-lambda* voi
1b10: 64 20 28 5b 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e d ([nonnull-ihan
1b20: 64 6c 65 20 68 61 6e 64 6c 65 5d 20 5b 63 2d 70 dle handle] [c-p
1b30: 6f 69 6e 74 65 72 20 63 65 6c 6c 5d 29 0a 20 20 ointer cell]).
1b40: 09 09 09 09 09 09 22 49 75 70 53 65 74 41 74 74 ......"IupSetAtt
1b50: 72 69 62 75 74 65 28 68 61 6e 64 6c 65 2c 20 5c ribute(handle, \
1b60: 22 43 48 49 43 4b 45 4e 5f 52 45 47 49 53 54 52 "CHICKEN_REGISTR
1b70: 59 5c 22 2c 20 63 65 6c 6c 29 3b 22 29 5d 0a 20 Y\", cell);")].
1b80: 20 09 09 09 09 20 5b 72 65 67 69 73 74 72 79 2d .... [registry-
1b90: 63 65 6c 6c 0a 20 20 09 09 09 09 20 20 28 66 6f cell. .... (fo
1ba0: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 63 2d reign-lambda* c-
1bb0: 70 6f 69 6e 74 65 72 20 28 5b 6e 6f 6e 6e 75 6c pointer ([nonnul
1bc0: 6c 2d 69 68 61 6e 64 6c 65 20 68 61 6e 64 6c 65 l-ihandle handle
1bd0: 5d 29 0a 20 20 09 09 09 09 20 20 09 22 43 5f 72 ]). .... ."C_r
1be0: 65 74 75 72 6e 28 49 75 70 47 65 74 41 74 74 72 eturn(IupGetAttr
1bf0: 69 62 75 74 65 28 68 61 6e 64 6c 65 2c 20 5c 22 ibute(handle, \"
1c00: 43 48 49 43 4b 45 4e 5f 52 45 47 49 53 54 52 59 CHICKEN_REGISTRY
1c10: 5c 22 29 29 3b 22 29 5d 0a 20 20 09 09 09 09 20 \"));")]. ....
1c20: 5b 6d 61 6b 65 2d 69 6d 6d 6f 62 69 6c 65 2d 63 [make-immobile-c
1c30: 65 6c 6c 0a 20 20 09 09 09 09 20 20 28 66 6f 72 ell. .... (for
1c40: 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 6e 6f 6e eign-lambda* non
1c50: 6e 75 6c 6c 2d 63 2d 70 6f 69 6e 74 65 72 20 28 null-c-pointer (
1c60: 5b 73 63 68 65 6d 65 2d 6f 62 6a 65 63 74 20 76 [scheme-object v
1c70: 5d 29 0a 20 20 09 09 09 09 20 20 09 22 76 6f 69 ]). .... ."voi
1c80: 64 20 2a 63 65 6c 6c 20 3d 20 43 48 49 43 4b 45 d *cell = CHICKE
1c90: 4e 5f 6e 65 77 5f 67 63 5f 72 6f 6f 74 28 29 3b N_new_gc_root();
1ca0: 5c 6e 22 0a 20 20 09 09 09 09 20 20 09 22 43 48 \n". .... ."CH
1cb0: 49 43 4b 45 4e 5f 67 63 5f 72 6f 6f 74 5f 73 65 ICKEN_gc_root_se
1cc0: 74 28 63 65 6c 6c 2c 20 76 29 3b 5c 6e 22 0a 20 t(cell, v);\n".
1cd0: 20 09 09 09 09 20 20 09 22 43 5f 72 65 74 75 72 .... ."C_retur
1ce0: 6e 28 63 65 6c 6c 29 3b 5c 6e 22 29 5d 0a 20 20 n(cell);\n")].
1cf0: 09 09 09 09 20 5b 63 65 6c 6c 2d 64 65 73 74 72 .... [cell-destr
1d00: 6f 79 21 0a 20 20 09 09 09 09 20 20 28 66 6f 72 oy!. .... (for
1d10: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 eign-lambda void
1d20: 20 22 43 48 49 43 4b 45 4e 5f 64 65 6c 65 74 65 "CHICKEN_delete
1d30: 5f 67 63 5f 72 6f 6f 74 22 20 6e 6f 6e 6e 75 6c _gc_root" nonnul
1d40: 6c 2d 63 2d 70 6f 69 6e 74 65 72 29 5d 0a 20 20 l-c-pointer)].
1d50: 09 09 09 09 20 5b 63 65 6c 6c 2d 73 65 74 21 0a .... [cell-set!.
1d60: 20 20 09 09 09 09 20 20 28 66 6f 72 65 69 67 6e .... (foreign
1d70: 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 43 48 -lambda void "CH
1d80: 49 43 4b 45 4e 5f 67 63 5f 72 6f 6f 74 5f 73 65 ICKEN_gc_root_se
1d90: 74 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 2d 70 6f 69 t" nonnull-c-poi
1da0: 6e 74 65 72 20 73 63 68 65 6d 65 2d 6f 62 6a 65 nter scheme-obje
1db0: 63 74 29 5d 0a 20 20 09 09 09 09 20 5b 63 65 6c ct)]. .... [cel
1dc0: 6c 2d 72 65 66 0a 20 20 09 09 09 09 20 20 28 66 l-ref. .... (f
1dd0: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 73 63 oreign-lambda sc
1de0: 68 65 6d 65 2d 6f 62 6a 65 63 74 20 22 43 48 49 heme-object "CHI
1df0: 43 4b 45 4e 5f 67 63 5f 72 6f 6f 74 5f 72 65 66 CKEN_gc_root_ref
1e00: 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 2d 70 6f 69 6e " nonnull-c-poin
1e10: 74 65 72 29 5d 29 0a 20 20 20 20 28 76 61 6c 75 ter)]). (valu
1e20: 65 73 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 es. (lambda
1e30: 28 68 61 6e 64 6c 65 20 76 61 6c 75 65 29 0a 20 (handle value).
1e40: 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 (cond.
1e50: 20 20 20 20 20 5b 28 72 65 67 69 73 74 72 79 2d [(registry-
1e60: 63 65 6c 6c 20 68 61 6e 64 6c 65 29 20 3d 3e 20 cell handle) =>
1e70: 28 63 75 74 20 63 65 6c 6c 2d 73 65 74 21 20 3c (cut cell-set! <
1e80: 3e 20 76 61 6c 75 65 29 5d 0a 20 20 20 20 20 20 > value)].
1e90: 20 20 20 5b 65 6c 73 65 20 28 72 65 67 69 73 74 [else (regist
1ea0: 72 79 2d 63 65 6c 6c 2d 73 65 74 21 20 68 61 6e ry-cell-set! han
1eb0: 64 6c 65 20 28 6d 61 6b 65 2d 69 6d 6d 6f 62 69 dle (make-immobi
1ec0: 6c 65 2d 63 65 6c 6c 20 76 61 6c 75 65 29 29 5d le-cell value))]
1ed0: 29 29 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 )). (lambda
1ee0: 28 68 61 6e 64 6c 65 29 0a 20 20 20 20 20 20 20 (handle).
1ef0: 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 5b (cond. [
1f00: 28 72 65 67 69 73 74 72 79 2d 63 65 6c 6c 20 68 (registry-cell h
1f10: 61 6e 64 6c 65 29 20 3d 3e 20 63 65 6c 6c 2d 72 andle) => cell-r
1f20: 65 66 5d 0a 20 20 20 20 20 20 20 20 20 5b 65 6c ef]. [el
1f30: 73 65 20 27 28 29 5d 29 29 0a 20 20 20 20 20 28 se '()])). (
1f40: 6c 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 29 0a lambda (handle).
1f50: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 (cond.
1f60: 20 20 20 20 20 20 5b 28 72 65 67 69 73 74 72 79 [(registry
1f70: 2d 63 65 6c 6c 20 68 61 6e 64 6c 65 29 0a 20 20 -cell handle).
1f80: 20 20 20 20 20 20 20 20 3d 3e 20 28 6c 61 6d 62 => (lamb
1f90: 64 61 20 28 63 65 6c 6c 29 0a 20 20 20 20 20 20 da (cell).
1fa0: 20 20 20 20 20 20 20 20 20 28 72 65 67 69 73 74 (regist
1fb0: 72 79 2d 63 65 6c 6c 2d 73 65 74 21 20 68 61 6e ry-cell-set! han
1fc0: 64 6c 65 20 23 66 29 0a 20 20 20 20 20 20 20 20 dle #f).
1fd0: 20 20 20 20 20 20 20 28 63 65 6c 6c 2d 64 65 73 (cell-des
1fe0: 74 72 6f 79 21 20 63 65 6c 6c 29 29 5d 29 29 29 troy! cell))])))
1ff0: 29 29 0a 0a 28 64 65 66 69 6e 65 2d 65 78 74 65 ))..(define-exte
2000: 72 6e 61 6c 20 28 63 61 6c 6c 62 61 63 6b 5f 65 rnal (callback_e
2010: 6e 74 72 79 20 5b 63 2d 70 6f 69 6e 74 65 72 20 ntry [c-pointer
2020: 63 65 6c 6c 5d 20 5b 63 2d 70 6f 69 6e 74 65 72 cell] [c-pointer
2030: 20 66 72 61 6d 65 5d 29 20 76 6f 69 64 0a 09 28 frame]) void..(
2040: 64 65 66 69 6e 65 20 63 65 6c 6c 2d 72 65 66 0a define cell-ref.
2050: 09 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 ..(foreign-lambd
2060: 61 20 73 63 68 65 6d 65 2d 6f 62 6a 65 63 74 20 a scheme-object
2070: 22 43 48 49 43 4b 45 4e 5f 67 63 5f 72 6f 6f 74 "CHICKEN_gc_root
2080: 5f 72 65 66 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 2d _ref" nonnull-c-
2090: 70 6f 69 6e 74 65 72 29 29 0a 09 0a 09 28 64 65 pointer))....(de
20a0: 66 69 6e 65 20 66 72 61 6d 65 2d 73 74 61 72 74 fine frame-start
20b0: 2f 75 62 79 74 65 21 0a 09 09 28 66 6f 72 65 69 /ubyte!...(forei
20c0: 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 gn-lambda* void
20d0: 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d ([c-pointer fram
20e0: 65 5d 29 20 22 76 61 5f 73 74 61 72 74 5f 75 63 e]) "va_start_uc
20f0: 68 61 72 28 28 76 61 5f 61 6c 69 73 74 29 66 72 har((va_alist)fr
2100: 61 6d 65 29 3b 22 29 29 0a 09 28 64 65 66 69 6e ame);"))..(defin
2110: 65 20 66 72 61 6d 65 2d 73 74 61 72 74 2f 69 6e e frame-start/in
2120: 74 21 0a 09 09 28 66 6f 72 65 69 67 6e 2d 6c 61 t!...(foreign-la
2130: 6d 62 64 61 2a 20 76 6f 69 64 20 28 5b 63 2d 70 mbda* void ([c-p
2140: 6f 69 6e 74 65 72 20 66 72 61 6d 65 5d 29 20 22 ointer frame]) "
2150: 76 61 5f 73 74 61 72 74 5f 69 6e 74 28 28 76 61 va_start_int((va
2160: 5f 61 6c 69 73 74 29 66 72 61 6d 65 29 3b 22 29 _alist)frame);")
2170: 29 0a 09 28 64 65 66 69 6e 65 20 66 72 61 6d 65 )..(define frame
2180: 2d 73 74 61 72 74 2f 66 6c 6f 61 74 21 0a 09 09 -start/float!...
2190: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a (foreign-lambda*
21a0: 20 76 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 void ([c-pointe
21b0: 72 20 66 72 61 6d 65 5d 29 20 22 76 61 5f 73 74 r frame]) "va_st
21c0: 61 72 74 5f 66 6c 6f 61 74 28 28 76 61 5f 61 6c art_float((va_al
21d0: 69 73 74 29 66 72 61 6d 65 29 3b 22 29 29 0a 09 ist)frame);"))..
21e0: 28 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 73 74 (define frame-st
21f0: 61 72 74 2f 64 6f 75 62 6c 65 21 0a 09 09 28 66 art/double!...(f
2200: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 oreign-lambda* v
2210: 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 oid ([c-pointer
2220: 66 72 61 6d 65 5d 29 20 22 76 61 5f 73 74 61 72 frame]) "va_star
2230: 74 5f 64 6f 75 62 6c 65 28 28 76 61 5f 61 6c 69 t_double((va_ali
2240: 73 74 29 66 72 61 6d 65 29 3b 22 29 29 0a 09 28 st)frame);"))..(
2250: 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 73 74 61 define frame-sta
2260: 72 74 2f 70 6f 69 6e 74 65 72 21 0a 09 09 28 66 rt/pointer!...(f
2270: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 oreign-lambda* v
2280: 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 oid ([c-pointer
2290: 66 72 61 6d 65 5d 29 20 22 76 61 5f 73 74 61 72 frame]) "va_star
22a0: 74 5f 70 74 72 28 28 76 61 5f 61 6c 69 73 74 29 t_ptr((va_alist)
22b0: 66 72 61 6d 65 2c 20 76 6f 69 64 20 2a 29 3b 22 frame, void *);"
22c0: 29 29 0a 09 0a 09 28 64 65 66 69 6e 65 20 66 72 ))....(define fr
22d0: 61 6d 65 2d 61 72 67 2f 75 62 79 74 65 21 0a 09 ame-arg/ubyte!..
22e0: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
22f0: 2a 20 75 6e 73 69 67 6e 65 64 2d 62 79 74 65 20 * unsigned-byte
2300: 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d ([c-pointer fram
2310: 65 5d 29 20 22 43 5f 72 65 74 75 72 6e 28 76 61 e]) "C_return(va
2320: 5f 61 72 67 5f 75 63 68 61 72 28 28 76 61 5f 61 _arg_uchar((va_a
2330: 6c 69 73 74 29 66 72 61 6d 65 29 29 3b 22 29 29 list)frame));"))
2340: 0a 09 28 64 65 66 69 6e 65 20 66 72 61 6d 65 2d ..(define frame-
2350: 61 72 67 2f 69 6e 74 21 0a 09 09 28 66 6f 72 65 arg/int!...(fore
2360: 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 69 6e 74 20 ign-lambda* int
2370: 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d ([c-pointer fram
2380: 65 5d 29 20 22 43 5f 72 65 74 75 72 6e 28 76 61 e]) "C_return(va
2390: 5f 61 72 67 5f 69 6e 74 28 28 76 61 5f 61 6c 69 _arg_int((va_ali
23a0: 73 74 29 66 72 61 6d 65 29 29 3b 22 29 29 0a 09 st)frame));"))..
23b0: 28 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 61 72 (define frame-ar
23c0: 67 2f 66 6c 6f 61 74 21 0a 09 09 28 66 6f 72 65 g/float!...(fore
23d0: 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 66 6c 6f 61 ign-lambda* floa
23e0: 74 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 t ([c-pointer fr
23f0: 61 6d 65 5d 29 20 22 43 5f 72 65 74 75 72 6e 28 ame]) "C_return(
2400: 76 61 5f 61 72 67 5f 66 6c 6f 61 74 28 28 76 61 va_arg_float((va
2410: 5f 61 6c 69 73 74 29 66 72 61 6d 65 29 29 3b 22 _alist)frame));"
2420: 29 29 0a 09 28 64 65 66 69 6e 65 20 66 72 61 6d ))..(define fram
2430: 65 2d 61 72 67 2f 64 6f 75 62 6c 65 21 0a 09 09 e-arg/double!...
2440: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a (foreign-lambda*
2450: 20 64 6f 75 62 6c 65 20 28 5b 63 2d 70 6f 69 6e double ([c-poin
2460: 74 65 72 20 66 72 61 6d 65 5d 29 20 22 43 5f 72 ter frame]) "C_r
2470: 65 74 75 72 6e 28 76 61 5f 61 72 67 5f 64 6f 75 eturn(va_arg_dou
2480: 62 6c 65 28 28 76 61 5f 61 6c 69 73 74 29 66 72 ble((va_alist)fr
2490: 61 6d 65 29 29 3b 22 29 29 0a 09 28 64 65 66 69 ame));"))..(defi
24a0: 6e 65 20 66 72 61 6d 65 2d 61 72 67 2f 73 74 72 ne frame-arg/str
24b0: 69 6e 67 21 0a 09 09 28 66 6f 72 65 69 67 6e 2d ing!...(foreign-
24c0: 6c 61 6d 62 64 61 2a 20 63 2d 73 74 72 69 6e 67 lambda* c-string
24d0: 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 ([c-pointer fra
24e0: 6d 65 5d 29 20 22 43 5f 72 65 74 75 72 6e 28 76 me]) "C_return(v
24f0: 61 5f 61 72 67 5f 70 74 72 28 28 76 61 5f 61 6c a_arg_ptr((va_al
2500: 69 73 74 29 66 72 61 6d 65 2c 20 63 68 61 72 20 ist)frame, char
2510: 2a 29 29 3b 22 29 29 0a 09 28 64 65 66 69 6e 65 *));"))..(define
2520: 20 66 72 61 6d 65 2d 61 72 67 2f 70 6f 69 6e 74 frame-arg/point
2530: 65 72 21 0a 09 09 28 66 6f 72 65 69 67 6e 2d 6c er!...(foreign-l
2540: 61 6d 62 64 61 2a 20 63 2d 70 6f 69 6e 74 65 72 ambda* c-pointer
2550: 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 ([c-pointer fra
2560: 6d 65 5d 29 20 22 43 5f 72 65 74 75 72 6e 28 76 me]) "C_return(v
2570: 61 5f 61 72 67 5f 70 74 72 28 28 76 61 5f 61 6c a_arg_ptr((va_al
2580: 69 73 74 29 66 72 61 6d 65 2c 20 76 6f 69 64 20 ist)frame, void
2590: 2a 29 29 3b 22 29 29 0a 09 28 64 65 66 69 6e 65 *));"))..(define
25a0: 20 66 72 61 6d 65 2d 61 72 67 2f 68 61 6e 64 6c frame-arg/handl
25b0: 65 21 0a 09 09 28 66 6f 72 65 69 67 6e 2d 6c 61 e!...(foreign-la
25c0: 6d 62 64 61 2a 20 69 68 61 6e 64 6c 65 20 28 5b mbda* ihandle ([
25d0: 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 5d c-pointer frame]
25e0: 29 20 22 43 5f 72 65 74 75 72 6e 28 76 61 5f 61 ) "C_return(va_a
25f0: 72 67 5f 70 74 72 28 28 76 61 5f 61 6c 69 73 74 rg_ptr((va_alist
2600: 29 66 72 61 6d 65 2c 20 49 68 61 6e 64 6c 65 20 )frame, Ihandle
2610: 2a 29 29 3b 22 29 29 0a 09 0a 09 28 64 65 66 69 *));"))....(defi
2620: 6e 65 20 66 72 61 6d 65 2d 72 65 74 75 72 6e 2f ne frame-return/
2630: 75 62 79 74 65 21 0a 09 09 28 66 6f 72 65 69 67 ubyte!...(foreig
2640: 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 28 n-lambda* void (
2650: 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 [c-pointer frame
2660: 5d 20 5b 75 6e 73 69 67 6e 65 64 2d 62 79 74 65 ] [unsigned-byte
2670: 20 72 65 74 5d 29 20 22 76 61 5f 72 65 74 75 72 ret]) "va_retur
2680: 6e 5f 75 63 68 61 72 28 28 76 61 5f 61 6c 69 73 n_uchar((va_alis
2690: 74 29 66 72 61 6d 65 2c 20 72 65 74 29 3b 22 29 t)frame, ret);")
26a0: 29 0a 09 3b 28 64 65 66 69 6e 65 20 66 72 61 6d )..;(define fram
26b0: 65 2d 72 65 74 75 72 6e 2f 69 6e 74 21 0a 09 3b e-return/int!..;
26c0: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
26d0: 2a 20 76 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 * void ([c-point
26e0: 65 72 20 66 72 61 6d 65 5d 20 5b 69 6e 74 20 72 er frame] [int r
26f0: 65 74 5d 29 20 22 76 61 5f 72 65 74 75 72 6e 5f et]) "va_return_
2700: 69 6e 74 28 28 76 61 5f 61 6c 69 73 74 29 66 72 int((va_alist)fr
2710: 61 6d 65 2c 20 72 65 74 29 3b 22 29 29 0a 09 28 ame, ret);"))..(
2720: 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 72 65 74 define frame-ret
2730: 75 72 6e 2f 73 74 61 74 75 73 21 0a 09 09 28 66 urn/status!...(f
2740: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 oreign-lambda* v
2750: 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 oid ([c-pointer
2760: 66 72 61 6d 65 5d 20 5b 69 73 74 61 74 75 73 20 frame] [istatus
2770: 72 65 74 5d 29 20 22 76 61 5f 72 65 74 75 72 6e ret]) "va_return
2780: 5f 69 6e 74 28 28 76 61 5f 61 6c 69 73 74 29 66 _int((va_alist)f
2790: 72 61 6d 65 2c 20 72 65 74 29 3b 22 29 29 0a 09 rame, ret);"))..
27a0: 28 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 72 65 (define frame-re
27b0: 74 75 72 6e 2f 66 6c 6f 61 74 21 0a 09 09 28 66 turn/float!...(f
27c0: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 oreign-lambda* v
27d0: 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 oid ([c-pointer
27e0: 66 72 61 6d 65 5d 20 5b 66 6c 6f 61 74 20 72 65 frame] [float re
27f0: 74 5d 29 20 22 76 61 5f 72 65 74 75 72 6e 5f 66 t]) "va_return_f
2800: 6c 6f 61 74 28 28 76 61 5f 61 6c 69 73 74 29 66 loat((va_alist)f
2810: 72 61 6d 65 2c 20 72 65 74 29 3b 22 29 29 0a 09 rame, ret);"))..
2820: 28 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 72 65 (define frame-re
2830: 74 75 72 6e 2f 64 6f 75 62 6c 65 21 0a 09 09 28 turn/double!...(
2840: 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 foreign-lambda*
2850: 76 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 72 void ([c-pointer
2860: 20 66 72 61 6d 65 5d 20 5b 64 6f 75 62 6c 65 20 frame] [double
2870: 72 65 74 5d 29 20 22 76 61 5f 72 65 74 75 72 6e ret]) "va_return
2880: 5f 64 6f 75 62 6c 65 28 28 76 61 5f 61 6c 69 73 _double((va_alis
2890: 74 29 66 72 61 6d 65 2c 20 72 65 74 29 3b 22 29 t)frame, ret);")
28a0: 29 0a 09 28 64 65 66 69 6e 65 20 66 72 61 6d 65 )..(define frame
28b0: 2d 72 65 74 75 72 6e 2f 70 6f 69 6e 74 65 72 21 -return/pointer!
28c0: 0a 09 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 ...(foreign-lamb
28d0: 64 61 2a 20 76 6f 69 64 20 28 5b 63 2d 70 6f 69 da* void ([c-poi
28e0: 6e 74 65 72 20 66 72 61 6d 65 5d 20 5b 63 2d 70 nter frame] [c-p
28f0: 6f 69 6e 74 65 72 20 72 65 74 5d 29 20 22 76 61 ointer ret]) "va
2900: 5f 72 65 74 75 72 6e 5f 70 74 72 28 28 76 61 5f _return_ptr((va_
2910: 61 6c 69 73 74 29 66 72 61 6d 65 2c 20 76 6f 69 alist)frame, voi
2920: 64 20 2a 2c 20 72 65 74 29 3b 22 29 29 0a 09 28 d *, ret);"))..(
2930: 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 72 65 74 define frame-ret
2940: 75 72 6e 2f 68 61 6e 64 6c 65 21 0a 09 09 28 66 urn/handle!...(f
2950: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 oreign-lambda* v
2960: 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 oid ([c-pointer
2970: 66 72 61 6d 65 5d 20 5b 69 68 61 6e 64 6c 65 20 frame] [ihandle
2980: 72 65 74 5d 29 20 22 76 61 5f 72 65 74 75 72 6e ret]) "va_return
2990: 5f 70 74 72 28 28 76 61 5f 61 6c 69 73 74 29 66 _ptr((va_alist)f
29a0: 72 61 6d 65 2c 20 49 68 61 6e 64 6c 65 20 2a 2c rame, Ihandle *,
29b0: 20 72 65 74 29 3b 22 29 29 0a 09 0a 09 28 6c 65 ret);"))....(le
29c0: 74 2a 20 28 5b 64 61 74 61 20 28 63 65 6c 6c 2d t* ([data (cell-
29d0: 72 65 66 20 63 65 6c 6c 29 5d 0a 09 09 09 09 20 ref cell)].....
29e0: 5b 73 69 67 20 28 63 61 72 20 64 61 74 61 29 5d [sig (car data)]
29f0: 0a 09 09 09 09 20 5b 70 72 6f 63 20 28 63 64 72 ..... [proc (cdr
2a00: 20 64 61 74 61 29 5d 29 0a 09 09 28 63 61 73 65 data)])...(case
2a10: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 69 67 (string-ref sig
2a20: 20 30 29 0a 09 09 09 5b 28 23 5c 62 29 20 20 20 0)....[(#\b)
2a30: 20 20 28 66 72 61 6d 65 2d 73 74 61 72 74 2f 75 (frame-start/u
2a40: 62 79 74 65 21 20 66 72 61 6d 65 29 5d 0a 09 09 byte! frame)]...
2a50: 09 5b 28 23 5c 69 29 20 20 20 20 20 28 66 72 61 .[(#\i) (fra
2a60: 6d 65 2d 73 74 61 72 74 2f 69 6e 74 21 20 66 72 me-start/int! fr
2a70: 61 6d 65 29 5d 0a 09 09 09 5b 28 23 5c 66 29 20 ame)]....[(#\f)
2a80: 20 20 20 20 28 66 72 61 6d 65 2d 73 74 61 72 74 (frame-start
2a90: 2f 66 6c 6f 61 74 21 20 66 72 61 6d 65 29 5d 0a /float! frame)].
2aa0: 09 09 09 5b 28 23 5c 64 29 20 20 20 20 20 28 66 ...[(#\d) (f
2ab0: 72 61 6d 65 2d 73 74 61 72 74 2f 64 6f 75 62 6c rame-start/doubl
2ac0: 65 21 20 66 72 61 6d 65 29 5d 0a 09 09 09 5b 28 e! frame)]....[(
2ad0: 23 5c 76 20 23 5c 68 29 20 28 66 72 61 6d 65 2d #\v #\h) (frame-
2ae0: 73 74 61 72 74 2f 70 6f 69 6e 74 65 72 21 20 66 start/pointer! f
2af0: 72 61 6d 65 29 5d 29 0a 09 09 28 6c 65 74 2a 20 rame)])...(let*
2b00: 28 5b 61 72 67 73 20 28 6c 69 73 74 2d 65 63 20 ([args (list-ec
2b10: 28 3a 73 74 72 69 6e 67 20 63 68 72 20 22 68 22 (:string chr "h"
2b20: 20 28 73 74 72 69 6e 67 2d 64 72 6f 70 20 73 69 (string-drop si
2b30: 67 20 31 29 29 0a 09 09 09 09 09 20 20 20 20 20 g 1))......
2b40: 20 20 20 20 28 63 61 73 65 20 63 68 72 0a 09 09 (case chr...
2b50: 09 09 09 20 20 20 20 20 20 20 20 20 09 20 5b 28 ... . [(
2b60: 23 5c 62 29 20 28 66 72 61 6d 65 2d 61 72 67 2f #\b) (frame-arg/
2b70: 75 62 79 74 65 21 20 66 72 61 6d 65 29 5d 0a 09 ubyte! frame)]..
2b80: 09 09 09 09 20 20 20 20 20 20 20 20 20 09 20 5b .... . [
2b90: 28 23 5c 69 29 20 28 66 72 61 6d 65 2d 61 72 67 (#\i) (frame-arg
2ba0: 2f 69 6e 74 21 20 66 72 61 6d 65 29 5d 0a 09 09 /int! frame)]...
2bb0: 09 09 09 20 20 20 20 20 20 20 20 20 09 20 5b 28 ... . [(
2bc0: 23 5c 66 29 20 28 66 72 61 6d 65 2d 61 72 67 2f #\f) (frame-arg/
2bd0: 66 6c 6f 61 74 21 20 66 72 61 6d 65 29 5d 0a 09 float! frame)]..
2be0: 09 09 09 09 20 20 20 20 20 20 20 20 20 09 20 5b .... . [
2bf0: 28 23 5c 64 29 20 28 66 72 61 6d 65 2d 61 72 67 (#\d) (frame-arg
2c00: 2f 64 6f 75 62 6c 65 21 20 66 72 61 6d 65 29 5d /double! frame)]
2c10: 0a 09 09 09 09 09 20 20 20 20 20 20 20 20 20 09 ...... .
2c20: 20 5b 28 23 5c 73 29 20 28 66 72 61 6d 65 2d 61 [(#\s) (frame-a
2c30: 72 67 2f 73 74 72 69 6e 67 21 20 66 72 61 6d 65 rg/string! frame
2c40: 29 5d 0a 09 09 09 09 09 20 20 20 20 20 20 20 20 )]......
2c50: 20 09 20 5b 28 23 5c 76 29 20 28 66 72 61 6d 65 . [(#\v) (frame
2c60: 2d 61 72 67 2f 70 6f 69 6e 74 65 72 21 20 66 72 -arg/pointer! fr
2c70: 61 6d 65 29 5d 0a 09 09 09 09 09 20 20 20 20 20 ame)]......
2c80: 20 20 20 20 09 20 5b 28 23 5c 68 29 20 28 66 72 . [(#\h) (fr
2c90: 61 6d 65 2d 61 72 67 2f 68 61 6e 64 6c 65 21 20 ame-arg/handle!
2ca0: 66 72 61 6d 65 29 5d 29 29 5d 0a 09 09 09 09 20 frame)]))].....
2cb0: 20 20 5b 72 65 74 20 28 61 70 70 6c 79 20 70 72 [ret (apply pr
2cc0: 6f 63 20 61 72 67 73 29 5d 29 0a 09 09 09 28 63 oc args)])....(c
2cd0: 61 73 65 20 28 73 74 72 69 6e 67 2d 72 65 66 20 ase (string-ref
2ce0: 73 69 67 20 30 29 0a 09 09 09 09 5b 28 23 5c 62 sig 0).....[(#\b
2cf0: 29 20 28 66 72 61 6d 65 2d 72 65 74 75 72 6e 2f ) (frame-return/
2d00: 75 62 79 74 65 21 20 66 72 61 6d 65 20 72 65 74 ubyte! frame ret
2d10: 29 5d 0a 09 09 09 09 5b 28 23 5c 69 29 20 28 66 )].....[(#\i) (f
2d20: 72 61 6d 65 2d 72 65 74 75 72 6e 2f 73 74 61 74 rame-return/stat
2d30: 75 73 21 20 66 72 61 6d 65 20 72 65 74 29 5d 0a us! frame ret)].
2d40: 09 09 09 09 5b 28 23 5c 66 29 20 28 66 72 61 6d ....[(#\f) (fram
2d50: 65 2d 72 65 74 75 72 6e 2f 66 6c 6f 61 74 21 20 e-return/float!
2d60: 66 72 61 6d 65 20 72 65 74 29 5d 0a 09 09 09 09 frame ret)].....
2d70: 5b 28 23 5c 64 29 20 28 66 72 61 6d 65 2d 72 65 [(#\d) (frame-re
2d80: 74 75 72 6e 2f 64 6f 75 62 6c 65 21 20 66 72 61 turn/double! fra
2d90: 6d 65 20 72 65 74 29 5d 0a 09 09 09 09 5b 28 23 me ret)].....[(#
2da0: 5c 76 29 20 28 66 72 61 6d 65 2d 72 65 74 75 72 \v) (frame-retur
2db0: 6e 2f 70 6f 69 6e 74 65 72 21 20 66 72 61 6d 65 n/pointer! frame
2dc0: 20 72 65 74 29 5d 0a 09 09 09 09 5b 28 23 5c 68 ret)].....[(#\h
2dd0: 29 20 28 66 72 61 6d 65 2d 72 65 74 75 72 6e 2f ) (frame-return/
2de0: 68 61 6e 64 6c 65 21 20 66 72 61 6d 65 20 72 65 handle! frame re
2df0: 74 29 5d 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 t)]))))..(define
2e00: 2d 76 61 6c 75 65 73 20 28 63 61 6c 6c 62 61 63 -values (callbac
2e10: 6b 2d 73 65 74 21 20 63 61 6c 6c 62 61 63 6b 29 k-set! callback)
2e20: 0a 09 28 6c 65 74 72 65 63 20 28 5b 73 69 67 6e ..(letrec ([sign
2e30: 61 74 75 72 65 2f 72 61 77 0a 09 09 09 09 09 09 ature/raw.......
2e40: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a (foreign-lambda*
2e50: 20 63 2d 73 74 72 69 6e 67 20 28 5b 6e 6f 6e 6e c-string ([nonn
2e60: 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 68 61 6e 64 ull-ihandle hand
2e70: 6c 65 5d 20 5b 69 6e 61 6d 65 2f 75 70 63 61 73 le] [iname/upcas
2e80: 65 20 6e 61 6d 65 5d 29 0a 09 09 09 09 09 09 09 e name])........
2e90: 22 43 5f 72 65 74 75 72 6e 28 69 75 70 43 6c 61 "C_return(iupCla
2ea0: 73 73 43 61 6c 6c 62 61 63 6b 47 65 74 46 6f 72 ssCallbackGetFor
2eb0: 6d 61 74 28 68 61 6e 64 6c 65 2d 3e 69 63 6c 61 mat(handle->icla
2ec0: 73 73 2c 20 6e 61 6d 65 29 29 3b 22 29 5d 0a 09 ss, name));")]..
2ed0: 09 09 09 09 20 5b 6d 61 6b 65 2d 77 72 61 70 70 .... [make-wrapp
2ee0: 65 72 0a 09 09 09 09 09 20 20 28 66 6f 72 65 69 er...... (forei
2ef0: 67 6e 2d 6c 61 6d 62 64 61 2a 20 63 2d 70 6f 69 gn-lambda* c-poi
2f00: 6e 74 65 72 20 28 5b 73 63 68 65 6d 65 2d 6f 62 nter ([scheme-ob
2f10: 6a 65 63 74 20 76 5d 29 0a 09 09 09 09 09 20 20 ject v])......
2f20: 09 22 76 6f 69 64 20 2a 63 65 6c 6c 20 3d 20 43 ."void *cell = C
2f30: 48 49 43 4b 45 4e 5f 6e 65 77 5f 67 63 5f 72 6f HICKEN_new_gc_ro
2f40: 6f 74 28 29 3b 5c 6e 22 0a 09 09 09 09 09 20 20 ot();\n"......
2f50: 09 22 43 48 49 43 4b 45 4e 5f 67 63 5f 72 6f 6f ."CHICKEN_gc_roo
2f60: 74 5f 73 65 74 28 63 65 6c 6c 2c 20 76 29 3b 5c t_set(cell, v);\
2f70: 6e 22 0a 09 09 09 09 09 20 20 09 22 43 5f 72 65 n"...... ."C_re
2f80: 74 75 72 6e 28 61 6c 6c 6f 63 5f 63 61 6c 6c 62 turn(alloc_callb
2f90: 61 63 6b 28 26 63 61 6c 6c 62 61 63 6b 5f 65 6e ack(&callback_en
2fa0: 74 72 79 2c 20 63 65 6c 6c 29 29 3b 5c 6e 22 29 try, cell));\n")
2fb0: 5d 0a 09 09 09 09 09 20 5b 77 72 61 70 70 65 72 ]...... [wrapper
2fc0: 2d 64 61 74 61 0a 09 20 20 20 20 20 20 20 20 20 -data..
2fd0: 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 (foreign-lambda
2fe0: 2a 20 73 63 68 65 6d 65 2d 6f 62 6a 65 63 74 20 * scheme-object
2ff0: 28 5b 63 2d 70 6f 69 6e 74 65 72 20 70 72 6f 63 ([c-pointer proc
3000: 5d 29 0a 09 20 20 20 20 20 20 20 20 20 20 09 22 ]).. ."
3010: 43 5f 72 65 74 75 72 6e 28 28 70 72 6f 63 20 26 C_return((proc &
3020: 26 20 69 73 5f 63 61 6c 6c 62 61 63 6b 28 70 72 & is_callback(pr
3030: 6f 63 29 20 3f 20 43 48 49 43 4b 45 4e 5f 67 63 oc) ? CHICKEN_gc
3040: 5f 72 6f 6f 74 5f 72 65 66 28 63 61 6c 6c 62 61 _root_ref(callba
3050: 63 6b 5f 64 61 74 61 28 70 72 6f 63 29 29 20 3a ck_data(proc)) :
3060: 20 43 5f 53 43 48 45 4d 45 5f 46 41 4c 53 45 29 C_SCHEME_FALSE)
3070: 29 3b 22 29 5d 0a 09 20 20 20 20 20 20 20 20 20 );")]..
3080: 5b 77 72 61 70 70 65 72 2d 64 65 73 74 72 6f 79 [wrapper-destroy
3090: 21 0a 09 20 20 20 20 20 20 20 20 20 20 28 66 6f !.. (fo
30a0: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f reign-lambda* vo
30b0: 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 70 id ([c-pointer p
30c0: 72 6f 63 5d 29 0a 09 20 20 20 20 20 20 20 20 20 roc])..
30d0: 20 09 22 69 66 20 28 70 72 6f 63 20 26 26 20 69 ."if (proc && i
30e0: 73 5f 63 61 6c 6c 62 61 63 6b 28 70 72 6f 63 29 s_callback(proc)
30f0: 29 20 7b 5c 6e 22 0a 09 20 20 20 20 20 20 20 20 ) {\n"..
3100: 20 20 09 22 20 20 43 48 49 43 4b 45 4e 5f 64 65 ." CHICKEN_de
3110: 6c 65 74 65 5f 67 63 5f 72 6f 6f 74 28 63 61 6c lete_gc_root(cal
3120: 6c 62 61 63 6b 5f 64 61 74 61 28 70 72 6f 63 29 lback_data(proc)
3130: 29 3b 5c 6e 22 0a 09 20 20 20 20 20 20 20 20 20 );\n"..
3140: 20 09 22 20 20 66 72 65 65 5f 63 61 6c 6c 62 61 ." free_callba
3150: 63 6b 28 70 72 6f 63 29 3b 5c 6e 22 0a 09 20 20 ck(proc);\n"..
3160: 20 20 20 20 20 20 20 20 09 22 7d 5c 6e 22 29 5d ."}\n")]
3170: 0a 09 20 20 20 20 20 20 20 20 20 5b 77 72 61 70 .. [wrap
3180: 70 65 72 2d 3e 70 72 6f 63 0a 09 20 20 20 20 20 per->proc..
3190: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 73 69 (lambda (si
31a0: 67 6e 61 74 75 72 65 20 70 72 6f 63 29 0a 09 20 gnature proc)..
31b0: 20 20 20 20 20 20 20 20 20 09 28 63 6f 6e 64 0a .(cond.
31c0: 09 20 20 20 20 20 20 20 20 20 20 09 09 5b 28 77 . ..[(w
31d0: 72 61 70 70 65 72 2d 64 61 74 61 20 70 72 6f 63 rapper-data proc
31e0: 29 20 3d 3e 20 63 64 72 5d 0a 09 20 20 20 20 20 ) => cdr]..
31f0: 20 20 20 20 20 09 09 5b 65 6c 73 65 20 70 72 6f ..[else pro
3200: 63 5d 29 29 5d 0a 09 09 09 09 09 20 5b 73 65 74 c]))]...... [set
3210: 2f 70 6f 69 6e 74 65 72 21 0a 09 09 09 09 09 20 /pointer!......
3220: 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 (foreign-lambda
3230: 20 63 2d 70 6f 69 6e 74 65 72 20 22 49 75 70 53 c-pointer "IupS
3240: 65 74 43 61 6c 6c 62 61 63 6b 22 20 6e 6f 6e 6e etCallback" nonn
3250: 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 69 6e 61 6d ull-ihandle inam
3260: 65 2f 75 70 63 61 73 65 20 63 2d 70 6f 69 6e 74 e/upcase c-point
3270: 65 72 29 5d 0a 09 09 09 09 09 20 5b 67 65 74 2f er)]...... [get/
3280: 70 6f 69 6e 74 65 72 0a 09 09 09 09 09 20 20 28 pointer...... (
3290: 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 63 foreign-lambda c
32a0: 2d 70 6f 69 6e 74 65 72 20 22 49 75 70 47 65 74 -pointer "IupGet
32b0: 43 61 6c 6c 62 61 63 6b 22 20 6e 6f 6e 6e 75 6c Callback" nonnul
32c0: 6c 2d 69 68 61 6e 64 6c 65 20 69 6e 61 6d 65 2f l-ihandle iname/
32d0: 75 70 63 61 73 65 29 5d 0a 09 09 09 09 09 20 5b upcase)]...... [
32e0: 73 69 67 69 6c 73 0a 09 09 09 09 09 20 20 28 69 sigils...... (i
32f0: 72 72 65 67 65 78 20 22 28 5b 62 69 66 64 73 76 rregex "([bifdsv
3300: 68 5d 2a 29 28 3f 3a 3d 28 5b 62 69 66 64 76 68 h]*)(?:=([bifdvh
3310: 5d 29 29 3f 22 29 5d 0a 09 09 09 09 09 20 5b 63 ]))?")]...... [c
3320: 61 6c 6c 62 61 63 6b 2d 73 65 74 21 0a 09 09 09 allback-set!....
3330: 09 09 20 20 28 6c 61 6d 62 64 61 20 28 68 61 6e .. (lambda (han
3340: 64 6c 65 20 6e 61 6d 65 20 70 72 6f 63 29 0a 09 dle name proc)..
3350: 09 09 09 09 20 20 09 28 6c 65 74 2a 20 28 5b 73 .... .(let* ([s
3360: 69 67 0a 09 09 09 09 09 20 20 09 20 20 20 20 20 ig...... .
3370: 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 09 (cond........
3380: 09 09 09 09 09 5b 28 69 72 72 65 67 65 78 2d 6d .....[(irregex-m
3390: 61 74 63 68 20 73 69 67 69 6c 73 20 28 6f 72 20 atch sigils (or
33a0: 28 73 69 67 6e 61 74 75 72 65 2f 72 61 77 20 68 (signature/raw h
33b0: 61 6e 64 6c 65 20 6e 61 6d 65 29 20 22 22 29 29 andle name) ""))
33c0: 0a 09 09 09 09 09 09 09 09 09 09 09 09 20 3d 3e ............. =>
33d0: 20 28 6c 61 6d 62 64 61 20 28 67 72 6f 75 70 73 (lambda (groups
33e0: 29 0a 09 09 09 09 09 09 09 09 09 09 09 09 09 09 )...............
33f0: 09 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 0a .(string-append.
3400: 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 09 ................
3410: 28 6f 72 20 28 69 72 72 65 67 65 78 2d 6d 61 74 (or (irregex-mat
3420: 63 68 2d 73 75 62 73 74 72 69 6e 67 20 67 72 6f ch-substring gro
3430: 75 70 73 20 32 29 20 22 69 22 29 0a 09 09 09 09 ups 2) "i").....
3440: 09 09 09 09 09 09 09 09 09 09 09 09 28 69 72 72 ............(irr
3450: 65 67 65 78 2d 6d 61 74 63 68 2d 73 75 62 73 74 egex-match-subst
3460: 72 69 6e 67 20 67 72 6f 75 70 73 20 31 29 29 29 ring groups 1)))
3470: 5d 0a 09 09 09 09 09 09 09 09 09 09 09 09 5b 65 ].............[e
3480: 6c 73 65 0a 09 09 09 09 09 09 09 09 09 09 09 09 lse.............
3490: 20 28 65 72 72 6f 72 20 27 63 61 6c 6c 62 61 63 (error 'callbac
34a0: 6b 2d 73 65 74 21 20 22 63 61 6c 6c 62 61 63 6b k-set! "callback
34b0: 20 68 61 73 20 62 61 64 20 73 69 67 6e 61 74 75 has bad signatu
34c0: 72 65 22 20 68 61 6e 64 6c 65 20 6e 61 6d 65 29 re" handle name)
34d0: 5d 29 5d 0a 09 09 09 09 09 20 20 09 09 09 20 20 ])]...... ...
34e0: 20 5b 6e 65 77 0a 09 09 09 09 09 20 20 09 20 20 [new...... .
34f0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 (cond.....
3500: 09 20 20 09 20 20 20 20 20 20 20 20 09 5b 28 6f . . .[(o
3510: 72 20 28 6e 6f 74 20 70 72 6f 63 29 20 28 70 6f r (not proc) (po
3520: 69 6e 74 65 72 3f 20 70 72 6f 63 29 29 20 70 72 inter? proc)) pr
3530: 6f 63 5d 0a 09 09 09 09 09 20 20 09 20 20 20 20 oc]...... .
3540: 20 20 20 20 09 5b 65 6c 73 65 20 28 73 65 74 2d .[else (set-
3550: 66 69 6e 61 6c 69 7a 65 72 21 20 28 6d 61 6b 65 finalizer! (make
3560: 2d 77 72 61 70 70 65 72 20 28 63 6f 6e 73 20 73 -wrapper (cons s
3570: 69 67 20 70 72 6f 63 29 29 20 77 72 61 70 70 65 ig proc)) wrappe
3580: 72 2d 64 65 73 74 72 6f 79 21 29 5d 29 5d 0a 09 r-destroy!)])]..
3590: 09 09 09 09 20 20 09 20 20 20 20 20 20 20 5b 6f .... . [o
35a0: 6c 64 0a 09 09 09 09 09 20 20 09 20 20 20 20 20 ld...... .
35b0: 20 20 20 28 73 65 74 2f 70 6f 69 6e 74 65 72 21 (set/pointer!
35c0: 20 68 61 6e 64 6c 65 20 6e 61 6d 65 20 6e 65 77 handle name new
35d0: 29 5d 29 0a 09 09 09 09 09 09 09 09 28 72 65 67 )]).........(reg
35e0: 69 73 74 72 79 2d 73 65 74 21 20 68 61 6e 64 6c istry-set! handl
35f0: 65 20 28 63 6f 6e 73 20 6e 65 77 20 28 72 65 6d e (cons new (rem
3600: 6f 76 65 21 20 28 63 75 74 20 70 6f 69 6e 74 65 ove! (cut pointe
3610: 72 3d 3f 20 3c 3e 20 6f 6c 64 29 20 28 72 65 67 r=? <> old) (reg
3620: 69 73 74 72 79 20 68 61 6e 64 6c 65 29 29 29 29 istry handle))))
3630: 29 29 5d 0a 09 09 09 09 09 20 5b 63 61 6c 6c 62 ))]...... [callb
3640: 61 63 6b 0a 09 09 09 09 09 20 20 28 6c 61 6d 62 ack...... (lamb
3650: 64 61 20 28 68 61 6e 64 6c 65 20 6e 61 6d 65 29 da (handle name)
3660: 0a 09 09 09 09 09 20 20 09 28 6c 65 74 20 28 5b ...... .(let ([
3670: 70 72 6f 63 20 28 67 65 74 2f 70 6f 69 6e 74 65 proc (get/pointe
3680: 72 20 68 61 6e 64 6c 65 20 6e 61 6d 65 29 5d 29 r handle name)])
3690: 0a 09 09 09 09 09 20 20 09 09 28 63 6f 6e 64 0a ...... ..(cond.
36a0: 09 09 09 09 09 20 20 09 09 09 5b 28 77 72 61 70 ..... ...[(wrap
36b0: 70 65 72 2d 64 61 74 61 20 70 72 6f 63 29 20 3d per-data proc) =
36c0: 3e 20 63 64 72 5d 0a 09 09 09 09 09 20 20 09 09 > cdr]...... ..
36d0: 09 5b 65 6c 73 65 20 70 72 6f 63 5d 29 29 29 5d .[else proc])))]
36e0: 29 0a 09 09 28 76 61 6c 75 65 73 0a 09 09 09 63 )...(values....c
36f0: 61 6c 6c 62 61 63 6b 2d 73 65 74 21 0a 09 09 09 allback-set!....
3700: 28 67 65 74 74 65 72 2d 77 69 74 68 2d 73 65 74 (getter-with-set
3710: 74 65 72 20 63 61 6c 6c 62 61 63 6b 20 63 61 6c ter callback cal
3720: 6c 62 61 63 6b 2d 73 65 74 21 29 29 29 29 0a 0a lback-set!))))..
3730: 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 4c ;; }}}..;; {{{ L
3740: 61 79 6f 75 74 20 66 75 6e 63 74 69 6f 6e 73 0a ayout functions.
3750: 0a 28 64 65 66 69 6e 65 20 63 72 65 61 74 65 0a .(define create.
3760: 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 63 (make-construc
3770: 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a 20 20 tor-procedure.
3780: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
3790: 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 nonnull-ihandle
37a0: 20 22 49 75 70 43 72 65 61 74 65 22 20 69 6e 61 "IupCreate" ina
37b0: 6d 65 2f 64 6f 77 6e 63 61 73 65 29 29 29 0a 0a me/downcase)))..
37c0: 28 64 65 66 69 6e 65 20 64 65 73 74 72 6f 79 21 (define destroy!
37d0: 0a 20 20 28 6c 65 74 72 65 63 20 28 5b 72 65 67 . (letrec ([reg
37e0: 69 73 74 72 79 2d 64 65 73 74 72 6f 79 2f 72 65 istry-destroy/re
37f0: 63 75 72 73 69 76 65 21 0a 20 20 20 20 20 20 20 cursive!.
3800: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 61 (lambda (ha
3810: 6e 64 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 ndle).
3820: 20 20 20 20 28 72 65 67 69 73 74 72 79 2d 64 65 (registry-de
3830: 73 74 72 6f 79 21 20 68 61 6e 64 6c 65 29 0a 20 stroy! handle).
3840: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 6f (do
3850: 2d 65 63 20 28 3a 63 68 69 6c 64 72 65 6e 20 63 -ec (:children c
3860: 68 69 6c 64 20 68 61 6e 64 6c 65 29 0a 20 20 20 hild handle).
3870: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 (re
3880: 67 69 73 74 72 79 2d 64 65 73 74 72 6f 79 2f 72 gistry-destroy/r
3890: 65 63 75 72 73 69 76 65 21 20 63 68 69 6c 64 29 ecursive! child)
38a0: 29 29 5d 0a 20 20 20 20 20 20 20 20 20 20 20 5b ))]. [
38b0: 68 61 6e 64 6c 65 2d 64 65 73 74 72 6f 79 21 0a handle-destroy!.
38c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 (for
38d0: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 eign-lambda void
38e0: 20 22 49 75 70 44 65 73 74 72 6f 79 22 20 6e 6f "IupDestroy" no
38f0: 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 5d 29 nnull-ihandle)])
3900: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 61 . (lambda (ha
3910: 6e 64 6c 65 29 0a 20 20 20 20 20 20 28 72 65 67 ndle). (reg
3920: 69 73 74 72 79 2d 64 65 73 74 72 6f 79 2f 72 65 istry-destroy/re
3930: 63 75 72 73 69 76 65 21 20 68 61 6e 64 6c 65 29 cursive! handle)
3940: 0a 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 64 . (handle-d
3950: 65 73 74 72 6f 79 21 20 68 61 6e 64 6c 65 29 29 estroy! handle))
3960: 29 29 0a 0a 28 64 65 66 69 6e 65 20 6d 61 70 2d ))..(define map-
3970: 70 65 65 72 21 0a 09 28 6c 65 74 72 65 63 20 28 peer!..(letrec (
3980: 5b 6d 61 70 2d 70 65 65 72 2f 72 61 77 21 20 28 [map-peer/raw! (
3990: 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 foreign-lambda i
39a0: 73 74 61 74 75 73 20 22 49 75 70 4d 61 70 22 20 status "IupMap"
39b0: 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 nonnull-ihandle)
39c0: 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 68 61 ])...(lambda (ha
39d0: 6e 64 6c 65 29 0a 09 09 09 28 6c 65 74 20 28 5b ndle)....(let ([
39e0: 73 74 61 74 75 73 20 28 6d 61 70 2d 70 65 65 72 status (map-peer
39f0: 2f 72 61 77 21 20 68 61 6e 64 6c 65 29 5d 29 0a /raw! handle)]).
3a00: 09 09 09 09 28 63 61 73 65 20 73 74 61 74 75 73 ....(case status
3a10: 0a 09 09 09 09 09 5b 28 23 74 29 20 28 76 6f 69 ......[(#t) (voi
3a20: 64 29 5d 0a 09 09 09 09 09 5b 65 6c 73 65 20 28 d)]......[else (
3a30: 65 72 72 6f 72 20 27 6d 61 70 2d 70 65 65 72 21 error 'map-peer!
3a40: 20 28 66 6f 72 6d 61 74 20 22 66 61 69 6c 65 64 (format "failed
3a50: 20 74 6f 20 6d 61 70 20 70 65 65 72 20 28 7e 73 to map peer (~s
3a60: 29 22 20 73 74 61 74 75 73 29 20 68 61 6e 64 6c )" status) handl
3a70: 65 29 5d 29 29 29 29 29 0a 0a 28 64 65 66 69 6e e)])))))..(defin
3a80: 65 20 75 6e 6d 61 70 2d 70 65 65 72 21 0a 09 28 e unmap-peer!..(
3a90: 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 foreign-lambda v
3aa0: 6f 69 64 20 22 49 75 70 55 6e 6d 61 70 22 20 6e oid "IupUnmap" n
3ab0: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 29 onnull-ihandle))
3ac0: 0a 0a 28 64 65 66 69 6e 65 20 63 6c 61 73 73 2d ..(define class-
3ad0: 6e 61 6d 65 0a 09 28 66 6f 72 65 69 67 6e 2d 6c name..(foreign-l
3ae0: 61 6d 62 64 61 20 69 6e 61 6d 65 2f 64 6f 77 6e ambda iname/down
3af0: 63 61 73 65 20 22 49 75 70 47 65 74 43 6c 61 73 case "IupGetClas
3b00: 73 4e 61 6d 65 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 sName" nonnull-i
3b10: 68 61 6e 64 6c 65 29 29 0a 0a 28 64 65 66 69 6e handle))..(defin
3b20: 65 20 63 6c 61 73 73 2d 74 79 70 65 0a 09 28 66 e class-type..(f
3b30: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 6e oreign-lambda in
3b40: 61 6d 65 2f 64 6f 77 6e 63 61 73 65 20 22 49 75 ame/downcase "Iu
3b50: 70 47 65 74 43 6c 61 73 73 54 79 70 65 22 20 6e pGetClassType" n
3b60: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 29 onnull-ihandle))
3b70: 0a 0a 28 64 65 66 69 6e 65 20 73 61 76 65 2d 61 ..(define save-a
3b80: 74 74 72 69 62 75 74 65 73 21 0a 09 28 66 6f 72 ttributes!..(for
3b90: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 eign-lambda void
3ba0: 20 22 49 75 70 53 61 76 65 43 6c 61 73 73 41 74 "IupSaveClassAt
3bb0: 74 72 69 62 75 74 65 73 22 20 6e 6f 6e 6e 75 6c tributes" nonnul
3bc0: 6c 2d 69 68 61 6e 64 6c 65 29 29 0a 0a 28 64 65 l-ihandle))..(de
3bd0: 66 69 6e 65 20 70 61 72 65 6e 74 0a 09 28 66 6f fine parent..(fo
3be0: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 61 reign-lambda iha
3bf0: 6e 64 6c 65 20 22 49 75 70 47 65 74 50 61 72 65 ndle "IupGetPare
3c00: 6e 74 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e nt" nonnull-ihan
3c10: 64 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 70 dle))..(define p
3c20: 61 72 65 6e 74 2d 64 69 61 6c 6f 67 0a 09 28 66 arent-dialog..(f
3c30: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 oreign-lambda ih
3c40: 61 6e 64 6c 65 20 22 49 75 70 47 65 74 44 69 61 andle "IupGetDia
3c50: 6c 6f 67 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 log" nonnull-iha
3c60: 6e 64 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 ndle))..(define
3c70: 73 69 62 6c 69 6e 67 0a 09 28 66 6f 72 65 69 67 sibling..(foreig
3c80: 6e 2d 6c 61 6d 62 64 61 20 69 68 61 6e 64 6c 65 n-lambda ihandle
3c90: 20 22 49 75 70 47 65 74 42 72 6f 74 68 65 72 22 "IupGetBrother"
3ca0: 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 nonnull-ihandle
3cb0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 69 6c ))..(define chil
3cc0: 64 2d 61 64 64 21 0a 20 20 28 6c 65 74 72 65 63 d-add!. (letrec
3cd0: 20 28 5b 61 70 70 65 6e 64 21 20 28 66 6f 72 65 ([append! (fore
3ce0: 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 61 6e 64 ign-lambda ihand
3cf0: 6c 65 20 22 49 75 70 41 70 70 65 6e 64 22 20 6e le "IupAppend" n
3d00: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 6e onnull-ihandle n
3d10: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 5d onnull-ihandle)]
3d20: 0a 20 20 20 20 20 20 20 20 20 20 20 5b 69 6e 73 . [ins
3d30: 65 72 74 21 20 28 66 6f 72 65 69 67 6e 2d 6c 61 ert! (foreign-la
3d40: 6d 62 64 61 20 69 68 61 6e 64 6c 65 20 22 49 75 mbda ihandle "Iu
3d50: 70 49 6e 73 65 72 74 22 20 6e 6f 6e 6e 75 6c 6c pInsert" nonnull
3d60: 2d 69 68 61 6e 64 6c 65 20 6e 6f 6e 6e 75 6c 6c -ihandle nonnull
3d70: 2d 69 68 61 6e 64 6c 65 20 6e 6f 6e 6e 75 6c 6c -ihandle nonnull
3d80: 2d 69 68 61 6e 64 6c 65 29 5d 29 0a 20 20 20 20 -ihandle)]).
3d90: 28 6c 61 6d 62 64 61 20 28 63 68 69 6c 64 20 63 (lambda (child c
3da0: 6f 6e 74 61 69 6e 65 72 20 23 21 6f 70 74 69 6f ontainer #!optio
3db0: 6e 61 6c 20 5b 61 6e 63 68 6f 72 20 23 66 5d 29 nal [anchor #f])
3dc0: 0a 20 20 20 20 20 20 28 6f 72 20 28 69 66 20 61 . (or (if a
3dd0: 6e 63 68 6f 72 0a 20 20 20 20 20 20 20 20 20 20 nchor.
3de0: 20 20 20 20 28 69 6e 73 65 72 74 21 20 63 6f 6e (insert! con
3df0: 74 61 69 6e 65 72 20 61 6e 63 68 6f 72 20 63 68 tainer anchor ch
3e00: 69 6c 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 ild).
3e10: 20 20 20 28 61 70 70 65 6e 64 21 20 63 6f 6e 74 (append! cont
3e20: 61 69 6e 65 72 20 63 68 69 6c 64 29 29 0a 09 09 ainer child))...
3e30: 09 09 09 28 65 72 72 6f 72 20 27 63 68 69 6c 64 ...(error 'child
3e40: 2d 61 64 64 21 20 22 66 61 69 6c 65 64 20 74 6f -add! "failed to
3e50: 20 61 64 64 20 63 68 69 6c 64 22 20 63 68 69 6c add child" chil
3e60: 64 20 63 6f 6e 74 61 69 6e 65 72 20 61 6e 63 68 d container anch
3e70: 6f 72 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 or)))))..(define
3e80: 20 63 68 69 6c 64 2d 72 65 6d 6f 76 65 21 0a 09 child-remove!..
3e90: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 (foreign-lambda
3ea0: 76 6f 69 64 20 22 49 75 70 44 65 74 61 63 68 22 void "IupDetach"
3eb0: 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 nonnull-ihandle
3ec0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 69 6c ))..(define chil
3ed0: 64 2d 6d 6f 76 65 21 0a 09 28 6c 65 74 72 65 63 d-move!..(letrec
3ee0: 20 28 5b 6d 6f 76 65 21 20 28 66 6f 72 65 69 67 ([move! (foreig
3ef0: 6e 2d 6c 61 6d 62 64 61 20 69 73 74 61 74 75 73 n-lambda istatus
3f00: 20 22 49 75 70 52 65 70 61 72 65 6e 74 22 20 6e "IupReparent" n
3f10: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 6e onnull-ihandle n
3f20: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 69 onnull-ihandle i
3f30: 68 61 6e 64 6c 65 29 5d 29 0a 09 09 28 6c 61 6d handle)])...(lam
3f40: 62 64 61 20 28 63 68 69 6c 64 20 70 61 72 65 6e bda (child paren
3f50: 74 20 23 21 6f 70 74 69 6f 6e 61 6c 20 72 65 66 t #!optional ref
3f60: 2d 63 68 69 6c 64 29 0a 09 09 09 28 6c 65 74 20 -child)....(let
3f70: 28 5b 73 74 61 74 75 73 20 28 6d 6f 76 65 21 20 ([status (move!
3f80: 63 68 69 6c 64 20 70 61 72 65 6e 74 20 72 65 66 child parent ref
3f90: 2d 63 68 69 6c 64 29 5d 29 0a 09 09 09 09 28 63 -child)]).....(c
3fa0: 61 73 65 20 73 74 61 74 75 73 0a 09 09 09 09 09 ase status......
3fb0: 5b 28 23 74 29 20 28 76 6f 69 64 29 5d 0a 09 09 [(#t) (void)]...
3fc0: 09 09 09 5b 65 6c 73 65 20 28 65 72 72 6f 72 20 ...[else (error
3fd0: 27 63 68 69 6c 64 2d 6d 6f 76 65 21 20 28 66 6f 'child-move! (fo
3fe0: 72 6d 61 74 20 22 66 61 69 6c 65 64 20 74 6f 20 rmat "failed to
3ff0: 6d 6f 76 65 20 63 68 69 6c 64 20 28 7e 73 29 22 move child (~s)"
4000: 20 73 74 61 74 75 73 29 20 63 68 69 6c 64 20 70 status) child p
4010: 61 72 65 6e 74 29 5d 29 29 29 29 29 0a 0a 28 64 arent)])))))..(d
4020: 65 66 69 6e 65 20 63 68 69 6c 64 2d 72 65 66 0a efine child-ref.
4030: 20 20 28 6c 65 74 72 65 63 20 28 5b 72 65 66 2f (letrec ([ref/
4040: 70 6f 73 69 74 69 6f 6e 20 28 66 6f 72 65 69 67 position (foreig
4050: 6e 2d 6c 61 6d 62 64 61 20 69 68 61 6e 64 6c 65 n-lambda ihandle
4060: 20 22 49 75 70 47 65 74 43 68 69 6c 64 22 20 6e "IupGetChild" n
4070: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 69 onnull-ihandle i
4080: 6e 74 29 5d 0a 20 20 20 20 20 20 20 20 20 20 20 nt)].
4090: 5b 72 65 66 2f 6e 61 6d 65 20 28 66 6f 72 65 69 [ref/name (forei
40a0: 67 6e 2d 6c 61 6d 62 64 61 20 69 68 61 6e 64 6c gn-lambda ihandl
40b0: 65 20 22 49 75 70 47 65 74 44 69 61 6c 6f 67 43 e "IupGetDialogC
40c0: 68 69 6c 64 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 hild" nonnull-ih
40d0: 61 6e 64 6c 65 20 69 6e 61 6d 65 2f 75 70 63 61 andle iname/upca
40e0: 73 65 29 5d 29 0a 20 20 20 20 28 6c 61 6d 62 64 se)]). (lambd
40f0: 61 20 28 63 6f 6e 74 61 69 6e 65 72 20 69 64 29 a (container id)
4100: 0a 20 20 20 20 20 20 28 28 69 66 20 28 69 6e 74 . ((if (int
4110: 65 67 65 72 3f 20 69 64 29 20 72 65 66 2f 70 6f eger? id) ref/po
4120: 73 69 74 69 6f 6e 20 72 65 66 2f 6e 61 6d 65 29 sition ref/name)
4130: 20 63 6f 6e 74 61 69 6e 65 72 20 69 64 29 29 29 container id)))
4140: 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 69 6c 64 )..(define child
4150: 2d 70 6f 73 0a 09 28 6c 65 74 72 65 63 20 28 5b -pos..(letrec ([
4160: 70 6f 73 2f 72 61 77 20 28 66 6f 72 65 69 67 6e pos/raw (foreign
4170: 2d 6c 61 6d 62 64 61 20 69 6e 74 20 22 49 75 70 -lambda int "Iup
4180: 47 65 74 43 68 69 6c 64 50 6f 73 22 20 6e 6f 6e GetChildPos" non
4190: 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 6e 6f 6e null-ihandle non
41a0: 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 5d 29 0a null-ihandle)]).
41b0: 09 09 28 6c 61 6d 62 64 61 20 28 70 61 72 65 6e ..(lambda (paren
41c0: 74 20 63 68 69 6c 64 29 0a 09 09 09 28 6c 65 74 t child)....(let
41d0: 20 28 5b 70 6f 73 20 28 70 6f 73 2f 72 61 77 20 ([pos (pos/raw
41e0: 70 61 72 65 6e 74 20 63 68 69 6c 64 29 5d 29 0a parent child)]).
41f0: 09 09 09 09 28 61 6e 64 20 28 6e 6f 74 20 28 6e ....(and (not (n
4200: 65 67 61 74 69 76 65 3f 20 70 6f 73 29 29 20 70 egative? pos)) p
4210: 6f 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 os)))))..(define
4220: 20 63 68 69 6c 64 2d 63 6f 75 6e 74 0a 09 28 66 child-count..(f
4230: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 6e oreign-lambda in
4240: 74 20 22 49 75 70 47 65 74 43 68 69 6c 64 43 6f t "IupGetChildCo
4250: 75 6e 74 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 unt" nonnull-iha
4260: 6e 64 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 ndle))..(define
4270: 28 63 68 69 6c 64 72 65 6e 20 68 61 6e 64 6c 65 (children handle
4280: 29 0a 09 28 6c 69 73 74 2d 65 63 20 28 3a 63 68 )..(list-ec (:ch
4290: 69 6c 64 72 65 6e 20 63 68 69 6c 64 20 68 61 6e ildren child han
42a0: 64 6c 65 29 20 63 68 69 6c 64 29 29 0a 0a 28 64 dle) child))..(d
42b0: 65 66 69 6e 65 20 72 65 66 72 65 73 68 0a 09 28 efine refresh..(
42c0: 66 6f 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d foreign-safe-lam
42d0: 62 64 61 20 76 6f 69 64 20 22 49 75 70 52 65 66 bda void "IupRef
42e0: 72 65 73 68 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 resh" nonnull-ih
42f0: 61 6e 64 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 andle))..(define
4300: 20 72 65 64 72 61 77 0a 09 28 6c 65 74 72 65 63 redraw..(letrec
4310: 20 28 5b 75 70 64 61 74 65 0a 09 20 20 20 20 20 ([update..
4320: 20 20 20 20 20 28 66 6f 72 65 69 67 6e 2d 73 61 (foreign-sa
4330: 66 65 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 fe-lambda* void
4340: 28 5b 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c ([nonnull-ihandl
4350: 65 20 68 61 6e 64 6c 65 5d 20 5b 62 6f 6f 6c 20 e handle] [bool
4360: 63 68 69 6c 64 72 65 6e 5d 29 0a 09 20 20 20 20 children])..
4370: 20 20 20 20 20 20 09 22 49 75 70 55 70 64 61 74 ."IupUpdat
4380: 65 28 68 61 6e 64 6c 65 29 3b 20 69 66 20 28 63 e(handle); if (c
4390: 68 69 6c 64 72 65 6e 29 20 49 75 70 55 70 64 61 hildren) IupUpda
43a0: 74 65 43 68 69 6c 64 72 65 6e 28 68 61 6e 64 6c teChildren(handl
43b0: 65 29 3b 22 29 5d 0a 09 20 20 20 20 20 20 20 20 e);")]..
43c0: 20 5b 75 70 64 61 74 65 2f 73 79 6e 63 0a 09 20 [update/sync..
43d0: 20 20 20 20 20 20 20 20 20 28 66 6f 72 65 69 67 (foreig
43e0: 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 76 6f n-safe-lambda vo
43f0: 69 64 20 22 49 75 70 52 65 64 72 61 77 22 20 6e id "IupRedraw" n
4400: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 62 onnull-ihandle b
4410: 6f 6f 6c 29 5d 29 0a 09 20 20 28 6c 61 6d 62 64 ool)]).. (lambd
4420: 61 20 28 68 61 6e 64 6c 65 20 23 21 6b 65 79 20 a (handle #!key
4430: 5b 63 68 69 6c 64 72 65 6e 3f 20 23 66 5d 20 5b [children? #f] [
4440: 73 79 6e 63 3f 20 23 66 5d 29 0a 09 20 20 09 28 sync? #f]).. .(
4450: 28 69 66 20 73 79 6e 63 3f 20 75 70 64 61 74 65 (if sync? update
4460: 2f 73 79 6e 63 20 75 70 64 61 74 65 29 20 68 61 /sync update) ha
4470: 6e 64 6c 65 20 63 68 69 6c 64 72 65 6e 3f 29 29 ndle children?))
4480: 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 69 6c ))..(define chil
4490: 64 2d 78 2f 79 2d 3e 70 6f 73 0a 09 28 6c 65 74 d-x/y->pos..(let
44a0: 72 65 63 20 28 5b 78 2f 79 2d 3e 70 6f 73 2f 72 rec ([x/y->pos/r
44b0: 61 77 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 aw (foreign-lamb
44c0: 64 61 20 69 6e 74 20 22 49 75 70 43 6f 6e 76 65 da int "IupConve
44d0: 72 74 58 59 54 6f 50 6f 73 22 20 6e 6f 6e 6e 75 rtXYToPos" nonnu
44e0: 6c 6c 2d 69 68 61 6e 64 6c 65 20 69 6e 74 20 69 ll-ihandle int i
44f0: 6e 74 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 nt)])...(lambda
4500: 28 70 61 72 65 6e 74 20 78 20 79 29 0a 09 09 09 (parent x y)....
4510: 28 6c 65 74 20 28 5b 70 6f 73 20 28 78 2f 79 2d (let ([pos (x/y-
4520: 3e 70 6f 73 2f 72 61 77 20 70 61 72 65 6e 74 20 >pos/raw parent
4530: 78 20 79 29 5d 29 0a 09 09 09 09 28 61 6e 64 20 x y)]).....(and
4540: 28 6e 6f 74 20 28 6e 65 67 61 74 69 76 65 3f 20 (not (negative?
4550: 70 6f 73 29 29 20 70 6f 73 29 29 29 29 29 0a 0a pos)) pos)))))..
4560: 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 44 ;; }}}..;; {{{ D
4570: 69 61 6c 6f 67 20 66 75 6e 63 74 69 6f 6e 73 0a ialog functions.
4580: 0a 28 64 65 66 69 6e 65 20 73 68 6f 77 0a 20 20 .(define show.
4590: 28 6c 65 74 72 65 63 20 28 5b 70 6f 73 69 74 69 (letrec ([positi
45a0: 6f 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 on. (
45b0: 6c 61 6d 62 64 61 20 28 76 29 0a 20 20 20 20 20 lambda (v).
45c0: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 76 (case v
45d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
45e0: 20 5b 28 63 65 6e 74 65 72 29 20 20 20 20 20 20 [(center)
45f0: 20 20 20 20 20 23 78 66 66 66 66 5d 0a 20 20 20 #xffff].
4600: 20 20 20 20 20 20 20 20 20 20 20 20 20 5b 28 73 [(s
4610: 74 61 72 74 20 74 6f 70 20 6c 65 66 74 29 20 20 tart top left)
4620: 20 23 78 66 66 66 65 5d 0a 20 20 20 20 20 20 20 #xfffe].
4630: 20 20 20 20 20 20 20 20 20 5b 28 65 6e 64 20 62 [(end b
4640: 6f 74 74 6f 6d 20 72 69 67 68 74 29 20 23 78 66 ottom right) #xf
4650: 66 66 64 5d 0a 20 20 20 20 20 20 20 20 20 20 20 ffd].
4660: 20 20 20 20 20 5b 28 6d 6f 75 73 65 29 20 20 20 [(mouse)
4670: 20 20 20 20 20 20 20 20 20 23 78 66 66 66 63 5d #xfffc]
4680: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4690: 20 5b 28 70 61 72 65 6e 74 2d 63 65 6e 74 65 72 [(parent-center
46a0: 29 20 20 20 20 23 78 66 66 66 61 5d 0a 20 20 20 ) #xfffa].
46b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 5b 28 63 [(c
46c0: 75 72 72 65 6e 74 29 20 20 20 20 20 20 20 20 20 urrent)
46d0: 20 23 78 66 66 66 62 5d 0a 20 20 20 20 20 20 20 #xfffb].
46e0: 20 20 20 20 20 20 20 20 20 5b 65 6c 73 65 20 20 [else
46f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 76 5d 29 v])
4700: 29 5d 0a 20 20 20 20 20 20 20 20 20 20 20 5b 70 )]. [p
4710: 6f 70 75 70 20 28 66 6f 72 65 69 67 6e 2d 73 61 opup (foreign-sa
4720: 66 65 2d 6c 61 6d 62 64 61 20 69 73 74 61 74 75 fe-lambda istatu
4730: 73 20 22 49 75 70 50 6f 70 75 70 22 20 6e 6f 6e s "IupPopup" non
4740: 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 69 6e 74 null-ihandle int
4750: 20 69 6e 74 29 5d 0a 20 20 20 20 20 20 20 20 20 int)].
4760: 20 20 5b 73 68 6f 77 2f 78 2f 79 20 28 66 6f 72 [show/x/y (for
4770: 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 eign-safe-lambda
4780: 20 69 73 74 61 74 75 73 20 22 49 75 70 53 68 6f istatus "IupSho
4790: 77 58 59 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 wXY" nonnull-iha
47a0: 6e 64 6c 65 20 69 6e 74 20 69 6e 74 29 5d 29 0a ndle int int)]).
47b0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 61 6e (lambda (han
47c0: 64 6c 65 20 23 21 6b 65 79 20 5b 78 20 27 63 75 dle #!key [x 'cu
47d0: 72 72 65 6e 74 5d 20 5b 79 20 27 63 75 72 72 65 rrent] [y 'curre
47e0: 6e 74 5d 20 5b 6d 6f 64 61 6c 3f 20 23 66 5d 29 nt] [modal? #f])
47f0: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 5b 73 74 . (let ([st
4800: 61 74 75 73 20 28 28 69 66 20 6d 6f 64 61 6c 3f atus ((if modal?
4810: 20 70 6f 70 75 70 20 73 68 6f 77 2f 78 2f 79 29 popup show/x/y)
4820: 20 68 61 6e 64 6c 65 20 28 70 6f 73 69 74 69 6f handle (positio
4830: 6e 20 78 29 20 28 70 6f 73 69 74 69 6f 6e 20 79 n x) (position y
4840: 29 29 5d 29 0a 20 20 20 20 20 20 20 20 28 63 61 ))]). (ca
4850: 73 65 20 73 74 61 74 75 73 0a 20 20 20 20 20 20 se status.
4860: 20 20 20 20 5b 28 65 72 72 6f 72 29 20 28 65 72 [(error) (er
4870: 72 6f 72 20 27 73 68 6f 77 20 22 66 61 69 6c 65 ror 'show "faile
4880: 64 20 74 6f 20 73 68 6f 77 22 20 68 61 6e 64 6c d to show" handl
4890: 65 29 5d 0a 20 20 20 20 20 20 20 20 20 20 5b 65 e)]. [e
48a0: 6c 73 65 20 20 20 20 73 74 61 74 75 73 5d 29 29 lse status]))
48b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 69 64 )))..(define hid
48c0: 65 0a 09 28 6c 65 74 72 65 63 20 28 5b 68 69 64 e..(letrec ([hid
48d0: 65 2f 72 61 77 20 28 66 6f 72 65 69 67 6e 2d 73 e/raw (foreign-s
48e0: 61 66 65 2d 6c 61 6d 62 64 61 20 69 73 74 61 74 afe-lambda istat
48f0: 75 73 20 22 49 75 70 48 69 64 65 22 20 6e 6f 6e us "IupHide" non
4900: 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 5d 29 0a null-ihandle)]).
4910: 09 09 28 6c 61 6d 62 64 61 20 28 68 61 6e 64 6c ..(lambda (handl
4920: 65 29 0a 09 09 09 28 6c 65 74 20 28 5b 73 74 61 e)....(let ([sta
4930: 74 75 73 20 28 68 69 64 65 2f 72 61 77 20 68 61 tus (hide/raw ha
4940: 6e 64 6c 65 29 5d 29 0a 09 09 09 09 28 63 61 73 ndle)]).....(cas
4950: 65 20 73 74 61 74 75 73 0a 09 09 09 09 09 5b 28 e status......[(
4960: 23 74 29 20 28 76 6f 69 64 29 5d 0a 09 09 09 09 #t) (void)].....
4970: 09 5b 65 6c 73 65 20 28 65 72 72 6f 72 20 27 68 .[else (error 'h
4980: 69 64 65 20 28 66 6f 72 6d 61 74 20 22 66 61 69 ide (format "fai
4990: 6c 65 64 20 74 6f 20 68 69 64 65 20 28 7e 73 29 led to hide (~s)
49a0: 22 20 73 74 61 74 75 73 29 20 68 61 6e 64 6c 65 " status) handle
49b0: 29 5d 29 29 29 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a )])))))..;; }}}.
49c0: 0a 3b 3b 20 7b 7b 7b 20 43 6f 6d 70 6f 73 69 74 .;; {{{ Composit
49d0: 69 6f 6e 20 66 75 6e 63 74 69 6f 6e 73 0a 0a 28 ion functions..(
49e0: 64 65 66 69 6e 65 20 64 69 61 6c 6f 67 0a 20 20 define dialog.
49f0: 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 63 74 6f (make-constructo
4a00: 72 2d 70 72 6f 63 65 64 75 72 65 0a 20 20 09 28 r-procedure. .(
4a10: 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 6e foreign-lambda n
4a20: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 22 onnull-ihandle "
4a30: 49 75 70 44 69 61 6c 6f 67 22 20 69 68 61 6e 64 IupDialog" ihand
4a40: 6c 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 66 le)))..(define f
4a50: 69 6c 6c 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 ill. (make-cons
4a60: 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 tructor-procedur
4a70: 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 e. .(foreign-la
4a80: 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 mbda nonnull-iha
4a90: 6e 64 6c 65 20 22 49 75 70 46 69 6c 6c 22 29 29 ndle "IupFill"))
4aa0: 29 0a 0a 28 64 65 66 69 6e 65 20 68 62 6f 78 0a )..(define hbox.
4ab0: 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 63 (make-construc
4ac0: 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a 20 20 tor-procedure.
4ad0: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
4ae0: 2a 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c * nonnull-ihandl
4af0: 65 20 28 5b 69 68 61 6e 64 6c 65 2d 6c 69 73 74 e ([ihandle-list
4b00: 20 68 61 6e 64 6c 65 73 5d 29 20 22 43 5f 72 65 handles]) "C_re
4b10: 74 75 72 6e 28 49 75 70 48 62 6f 78 76 28 28 49 turn(IupHboxv((I
4b20: 68 61 6e 64 6c 65 20 2a 2a 29 68 61 6e 64 6c 65 handle **)handle
4b30: 73 29 29 3b 22 29 0a 20 20 09 23 3a 61 70 70 6c s));"). .#:appl
4b40: 79 2d 61 72 67 73 20 6c 69 73 74 29 29 0a 0a 28 y-args list))..(
4b50: 64 65 66 69 6e 65 20 76 62 6f 78 0a 20 20 28 6d define vbox. (m
4b60: 61 6b 65 2d 63 6f 6e 73 74 72 75 63 74 6f 72 2d ake-constructor-
4b70: 70 72 6f 63 65 64 75 72 65 0a 20 20 09 28 66 6f procedure. .(fo
4b80: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 6e 6f reign-lambda* no
4b90: 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 28 5b nnull-ihandle ([
4ba0: 69 68 61 6e 64 6c 65 2d 6c 69 73 74 20 68 61 6e ihandle-list han
4bb0: 64 6c 65 73 5d 29 20 22 43 5f 72 65 74 75 72 6e dles]) "C_return
4bc0: 28 49 75 70 56 62 6f 78 76 28 28 49 68 61 6e 64 (IupVboxv((Ihand
4bd0: 6c 65 20 2a 2a 29 68 61 6e 64 6c 65 73 29 29 3b le **)handles));
4be0: 22 29 0a 20 20 09 23 3a 61 70 70 6c 79 2d 61 72 "). .#:apply-ar
4bf0: 67 73 20 6c 69 73 74 29 29 0a 0a 28 64 65 66 69 gs list))..(defi
4c00: 6e 65 20 7a 62 6f 78 0a 20 20 28 6d 61 6b 65 2d ne zbox. (make-
4c10: 63 6f 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 constructor-proc
4c20: 65 64 75 72 65 0a 20 20 09 28 66 6f 72 65 69 67 edure. .(foreig
4c30: 6e 2d 6c 61 6d 62 64 61 2a 20 6e 6f 6e 6e 75 6c n-lambda* nonnul
4c40: 6c 2d 69 68 61 6e 64 6c 65 20 28 5b 69 68 61 6e l-ihandle ([ihan
4c50: 64 6c 65 2d 6c 69 73 74 20 68 61 6e 64 6c 65 73 dle-list handles
4c60: 5d 29 20 22 43 5f 72 65 74 75 72 6e 28 49 75 70 ]) "C_return(Iup
4c70: 5a 62 6f 78 76 28 28 49 68 61 6e 64 6c 65 20 2a Zboxv((Ihandle *
4c80: 2a 29 68 61 6e 64 6c 65 73 29 29 3b 22 29 0a 20 *)handles));").
4c90: 20 09 23 3a 61 70 70 6c 79 2d 61 72 67 73 20 6c .#:apply-args l
4ca0: 69 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 ist))..(define c
4cb0: 62 6f 78 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 box. (make-cons
4cc0: 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 tructor-procedur
4cd0: 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 e. .(foreign-la
4ce0: 6d 62 64 61 2a 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 mbda* nonnull-ih
4cf0: 61 6e 64 6c 65 20 28 5b 69 68 61 6e 64 6c 65 2d andle ([ihandle-
4d00: 6c 69 73 74 20 68 61 6e 64 6c 65 73 5d 29 20 22 list handles]) "
4d10: 43 5f 72 65 74 75 72 6e 28 49 75 70 43 62 6f 78 C_return(IupCbox
4d20: 76 28 28 49 68 61 6e 64 6c 65 20 2a 2a 29 68 61 v((Ihandle **)ha
4d30: 6e 64 6c 65 73 29 29 3b 22 29 0a 20 20 09 23 3a ndles));"). .#:
4d40: 61 70 70 6c 79 2d 61 72 67 73 20 6c 69 73 74 29 apply-args list)
4d50: 29 0a 0a 28 64 65 66 69 6e 65 20 73 62 6f 78 0a )..(define sbox.
4d60: 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 63 (make-construc
4d70: 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a 20 20 tor-procedure.
4d80: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
4d90: 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 nonnull-ihandle
4da0: 20 22 49 75 70 53 62 6f 78 22 20 69 68 61 6e 64 "IupSbox" ihand
4db0: 6c 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 72 le)))..(define r
4dc0: 61 64 69 6f 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e adio. (make-con
4dd0: 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 structor-procedu
4de0: 72 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c re. .(foreign-l
4df0: 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 ambda nonnull-ih
4e00: 61 6e 64 6c 65 20 22 49 75 70 52 61 64 69 6f 22 andle "IupRadio"
4e10: 20 69 68 61 6e 64 6c 65 29 29 29 0a 0a 28 64 65 ihandle)))..(de
4e20: 66 69 6e 65 20 6e 6f 72 6d 61 6c 69 7a 65 72 0a fine normalizer.
4e30: 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 63 (make-construc
4e40: 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a 20 20 tor-procedure.
4e50: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
4e60: 2a 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c * nonnull-ihandl
4e70: 65 20 28 5b 69 68 61 6e 64 6c 65 2d 6c 69 73 74 e ([ihandle-list
4e80: 20 68 61 6e 64 6c 65 73 5d 29 20 22 43 5f 72 65 handles]) "C_re
4e90: 74 75 72 6e 28 49 75 70 4e 6f 72 6d 61 6c 69 7a turn(IupNormaliz
4ea0: 65 72 76 28 28 49 68 61 6e 64 6c 65 20 2a 2a 29 erv((Ihandle **)
4eb0: 68 61 6e 64 6c 65 73 29 29 3b 22 29 0a 20 20 09 handles));"). .
4ec0: 23 3a 61 70 70 6c 79 2d 61 72 67 73 20 6c 69 73 #:apply-args lis
4ed0: 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 70 6c t))..(define spl
4ee0: 69 74 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 it. (make-const
4ef0: 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 ructor-procedure
4f00: 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d . .(foreign-lam
4f10: 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e bda nonnull-ihan
4f20: 64 6c 65 20 22 49 75 70 53 70 6c 69 74 22 20 69 dle "IupSplit" i
4f30: 68 61 6e 64 6c 65 20 69 68 61 6e 64 6c 65 29 29 handle ihandle))
4f40: 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b )..;; }}}..;; {{
4f50: 7b 20 49 6d 61 67 65 20 72 65 73 6f 75 72 63 65 { Image resource
4f60: 20 66 75 6e 63 74 69 6f 6e 73 0a 0a 28 64 65 66 functions..(def
4f70: 69 6e 65 20 69 6d 61 67 65 2f 70 61 6c 65 74 74 ine image/palett
4f80: 65 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 e. (make-constr
4f90: 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a uctor-procedure.
4fa0: 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 .(foreign-lamb
4fb0: 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 da nonnull-ihand
4fc0: 6c 65 20 22 49 75 70 49 6d 61 67 65 22 20 69 6e le "IupImage" in
4fd0: 74 20 69 6e 74 20 62 6c 6f 62 29 29 29 0a 0a 28 t int blob)))..(
4fe0: 64 65 66 69 6e 65 20 69 6d 61 67 65 2f 72 67 62 define image/rgb
4ff0: 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 . (make-constru
5000: 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a 20 ctor-procedure.
5010: 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 .(foreign-lambd
5020: 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c a nonnull-ihandl
5030: 65 20 22 49 75 70 49 6d 61 67 65 52 47 42 22 20 e "IupImageRGB"
5040: 69 6e 74 20 69 6e 74 20 62 6c 6f 62 29 29 29 0a int int blob))).
5050: 0a 28 64 65 66 69 6e 65 20 69 6d 61 67 65 2f 72 .(define image/r
5060: 67 62 61 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 gba. (make-cons
5070: 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 tructor-procedur
5080: 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 e. .(foreign-la
5090: 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 mbda nonnull-iha
50a0: 6e 64 6c 65 20 22 49 75 70 49 6d 61 67 65 52 47 ndle "IupImageRG
50b0: 42 41 22 20 69 6e 74 20 69 6e 74 20 62 6c 6f 62 BA" int int blob
50c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 69 6d 61 )))..(define ima
50d0: 67 65 2f 66 69 6c 65 0a 09 28 6c 65 74 72 65 63 ge/file..(letrec
50e0: 20 28 5b 6c 6f 61 64 2d 69 6d 61 67 65 20 28 66 ([load-image (f
50f0: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 oreign-lambda ih
5100: 61 6e 64 6c 65 20 22 49 75 70 4c 6f 61 64 49 6d andle "IupLoadIm
5110: 61 67 65 22 20 63 2d 73 74 72 69 6e 67 29 5d 29 age" c-string)])
5120: 0a 09 09 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 ...(make-constru
5130: 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a 09 ctor-procedure..
5140: 09 09 28 6c 61 6d 62 64 61 20 28 66 69 6c 65 29 ..(lambda (file)
5150: 0a 09 09 09 09 28 6f 72 20 28 6c 6f 61 64 2d 69 .....(or (load-i
5160: 6d 61 67 65 20 66 69 6c 65 29 20 28 65 72 72 6f mage file) (erro
5170: 72 20 27 69 6d 61 67 65 2f 66 69 6c 65 20 28 61 r 'image/file (a
5180: 74 74 72 69 62 75 74 65 20 23 66 20 27 69 75 70 ttribute #f 'iup
5190: 69 6d 2d 6c 61 73 74 65 72 72 6f 72 29 29 29 29 im-lasterror))))
51a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 69 6d 61 )))..(define ima
51b0: 67 65 2d 73 61 76 65 0a 09 28 6c 65 74 72 65 63 ge-save..(letrec
51c0: 20 28 5b 73 61 76 65 2d 69 6d 61 67 65 20 28 66 ([save-image (f
51d0: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 62 6f oreign-lambda bo
51e0: 6f 6c 20 22 49 75 70 53 61 76 65 49 6d 61 67 65 ol "IupSaveImage
51f0: 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c " nonnull-ihandl
5200: 65 20 63 2d 73 74 72 69 6e 67 20 69 6e 61 6d 65 e c-string iname
5210: 2f 75 70 63 61 73 65 29 5d 29 0a 09 09 28 6c 61 /upcase)])...(la
5220: 6d 62 64 61 20 28 68 61 6e 64 6c 65 20 66 69 6c mbda (handle fil
5230: 65 20 66 6f 72 6d 61 74 29 0a 09 09 09 28 75 6e e format)....(un
5240: 6c 65 73 73 20 28 73 61 76 65 2d 69 6d 61 67 65 less (save-image
5250: 20 68 61 6e 64 6c 65 20 66 69 6c 65 20 66 6f 72 handle file for
5260: 6d 61 74 29 0a 09 09 09 09 28 65 72 72 6f 72 20 mat).....(error
5270: 27 69 6d 61 67 65 2d 73 61 76 65 20 28 61 74 74 'image-save (att
5280: 72 69 62 75 74 65 20 23 66 20 27 69 75 70 69 6d ribute #f 'iupim
5290: 2d 6c 61 73 74 65 72 72 6f 72 29 29 29 29 29 29 -lasterror))))))
52a0: 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b ..;; }}}..;; {{{
52b0: 20 46 6f 63 75 73 20 66 75 6e 63 74 69 6f 6e 73 Focus functions
52c0: 0a 0a 28 64 65 66 69 6e 65 20 63 75 72 72 65 6e ..(define curren
52d0: 74 2d 66 6f 63 75 73 0a 20 20 28 6c 65 74 72 65 t-focus. (letre
52e0: 63 20 28 5b 66 6f 63 75 73 20 28 66 6f 72 65 69 c ([focus (forei
52f0: 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 69 gn-safe-lambda i
5300: 68 61 6e 64 6c 65 20 22 49 75 70 47 65 74 46 6f handle "IupGetFo
5310: 63 75 73 22 29 5d 0a 20 20 20 20 20 20 20 20 20 cus")].
5320: 20 20 5b 66 6f 63 75 73 2d 73 65 74 21 20 28 66 [focus-set! (f
5330: 6f 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 oreign-safe-lamb
5340: 64 61 20 69 68 61 6e 64 6c 65 20 22 49 75 70 53 da ihandle "IupS
5350: 65 74 46 6f 63 75 73 22 20 69 68 61 6e 64 6c 65 etFocus" ihandle
5360: 29 5d 0a 20 20 20 20 20 20 20 20 20 20 20 5b 63 )]. [c
5370: 75 72 72 65 6e 74 2d 66 6f 63 75 73 0a 20 20 20 urrent-focus.
5380: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 2d 6c (case-l
5390: 61 6d 62 64 61 0a 20 20 20 20 20 20 20 20 20 20 ambda.
53a0: 20 20 20 20 5b 28 29 20 20 20 20 20 20 20 28 66 [() (f
53b0: 6f 63 75 73 29 5d 0a 20 20 20 20 20 20 20 20 20 ocus)].
53c0: 20 20 20 20 20 5b 28 68 61 6e 64 6c 65 29 20 28 [(handle) (
53d0: 66 6f 63 75 73 2d 73 65 74 21 20 68 61 6e 64 6c focus-set! handl
53e0: 65 29 5d 29 5d 29 0a 20 20 20 20 28 67 65 74 74 e)])]). (gett
53f0: 65 72 2d 77 69 74 68 2d 73 65 74 74 65 72 20 63 er-with-setter c
5400: 75 72 72 65 6e 74 2d 66 6f 63 75 73 20 63 75 72 urrent-focus cur
5410: 72 65 6e 74 2d 66 6f 63 75 73 29 29 29 0a 0a 28 rent-focus)))..(
5420: 64 65 66 69 6e 65 20 66 6f 63 75 73 2d 6e 65 78 define focus-nex
5430: 74 0a 09 28 6c 65 74 72 65 63 20 28 5b 66 6f 63 t..(letrec ([foc
5440: 75 73 2d 6e 65 78 74 2f 72 61 77 20 28 66 6f 72 us-next/raw (for
5450: 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 eign-safe-lambda
5460: 20 69 68 61 6e 64 6c 65 20 22 49 75 70 4e 65 78 ihandle "IupNex
5470: 74 46 69 65 6c 64 22 20 69 68 61 6e 64 6c 65 29 tField" ihandle)
5480: 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 23 21 ])...(lambda (#!
5490: 6f 70 74 69 6f 6e 61 6c 20 5b 68 61 6e 64 6c 65 optional [handle
54a0: 20 28 63 75 72 72 65 6e 74 2d 66 6f 63 75 73 29 (current-focus)
54b0: 5d 29 0a 09 09 09 28 66 6f 63 75 73 2d 6e 65 78 ])....(focus-nex
54c0: 74 2f 72 61 77 20 68 61 6e 64 6c 65 29 29 29 29 t/raw handle))))
54d0: 0a 0a 28 64 65 66 69 6e 65 20 66 6f 63 75 73 2d ..(define focus-
54e0: 70 72 65 76 69 6f 75 73 0a 09 28 6c 65 74 72 65 previous..(letre
54f0: 63 20 28 5b 66 6f 63 75 73 2d 70 72 65 76 69 6f c ([focus-previo
5500: 75 73 2f 72 61 77 20 28 66 6f 72 65 69 67 6e 2d us/raw (foreign-
5510: 73 61 66 65 2d 6c 61 6d 62 64 61 20 69 68 61 6e safe-lambda ihan
5520: 64 6c 65 20 22 49 75 70 50 72 65 76 69 6f 75 73 dle "IupPrevious
5530: 46 69 65 6c 64 22 20 69 68 61 6e 64 6c 65 29 5d Field" ihandle)]
5540: 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 23 21 6f )...(lambda (#!o
5550: 70 74 69 6f 6e 61 6c 20 5b 68 61 6e 64 6c 65 20 ptional [handle
5560: 28 63 75 72 72 65 6e 74 2d 66 6f 63 75 73 29 5d (current-focus)]
5570: 29 0a 09 09 09 28 66 6f 63 75 73 2d 70 72 65 76 )....(focus-prev
5580: 69 6f 75 73 2f 72 61 77 20 68 61 6e 64 6c 65 29 ious/raw handle)
5590: 29 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 )))..;; }}}..;;
55a0: 7b 7b 7b 20 4d 65 6e 75 20 66 75 6e 63 74 69 6f {{{ Menu functio
55b0: 6e 73 0a 0a 28 64 65 66 69 6e 65 20 6d 65 6e 75 ns..(define menu
55c0: 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 . (make-constru
55d0: 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a 20 ctor-procedure.
55e0: 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 .(foreign-lambd
55f0: 61 2a 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 a* nonnull-ihand
5600: 6c 65 20 28 5b 69 68 61 6e 64 6c 65 2d 6c 69 73 le ([ihandle-lis
5610: 74 20 68 61 6e 64 6c 65 73 5d 29 20 22 43 5f 72 t handles]) "C_r
5620: 65 74 75 72 6e 28 49 75 70 4d 65 6e 75 76 28 28 eturn(IupMenuv((
5630: 49 68 61 6e 64 6c 65 20 2a 2a 29 68 61 6e 64 6c Ihandle **)handl
5640: 65 73 29 29 3b 22 29 0a 20 20 09 23 3a 61 70 70 es));"). .#:app
5650: 6c 79 2d 61 72 67 73 20 6c 69 73 74 29 29 0a 0a ly-args list))..
5660: 28 64 65 66 69 6e 65 20 6d 65 6e 75 2d 69 74 65 (define menu-ite
5670: 6d 0a 20 20 28 6c 65 74 72 65 63 20 28 5b 61 63 m. (letrec ([ac
5680: 74 69 6f 6e 2d 69 74 65 6d 20 28 66 6f 72 65 69 tion-item (forei
5690: 67 6e 2d 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c gn-lambda nonnul
56a0: 6c 2d 69 68 61 6e 64 6c 65 20 22 49 75 70 49 74 l-ihandle "IupIt
56b0: 65 6d 22 20 63 2d 73 74 72 69 6e 67 20 69 6e 61 em" c-string ina
56c0: 6d 65 2f 75 70 63 61 73 65 29 5d 0a 20 20 20 20 me/upcase)].
56d0: 20 20 20 20 20 20 20 5b 73 75 62 6d 65 6e 75 2d [submenu-
56e0: 69 74 65 6d 20 28 66 6f 72 65 69 67 6e 2d 6c 61 item (foreign-la
56f0: 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 mbda nonnull-iha
5700: 6e 64 6c 65 20 22 49 75 70 53 75 62 6d 65 6e 75 ndle "IupSubmenu
5710: 22 20 63 2d 73 74 72 69 6e 67 20 69 68 61 6e 64 " c-string ihand
5720: 6c 65 29 5d 29 0a 20 20 20 20 28 6d 61 6b 65 2d le)]). (make-
5730: 63 6f 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 constructor-proc
5740: 65 64 75 72 65 0a 20 20 20 20 20 28 6c 61 6d 62 edure. (lamb
5750: 64 61 20 28 23 21 6f 70 74 69 6f 6e 61 6c 20 5b da (#!optional [
5760: 74 69 74 6c 65 20 23 66 5d 20 5b 61 63 74 69 6f title #f] [actio
5770: 6e 2f 6d 65 6e 75 20 23 66 5d 29 0a 20 20 20 20 n/menu #f]).
5780: 20 20 20 28 28 69 66 20 28 69 68 61 6e 64 6c 65 ((if (ihandle
5790: 3f 20 61 63 74 69 6f 6e 2f 6d 65 6e 75 29 20 73 ? action/menu) s
57a0: 75 62 6d 65 6e 75 2d 69 74 65 6d 20 61 63 74 69 ubmenu-item acti
57b0: 6f 6e 2d 69 74 65 6d 29 20 74 69 74 6c 65 20 61 on-item) title a
57c0: 63 74 69 6f 6e 2f 6d 65 6e 75 29 29 29 29 29 0a ction/menu))))).
57d0: 0a 28 64 65 66 69 6e 65 20 6d 65 6e 75 2d 73 65 .(define menu-se
57e0: 70 61 72 61 74 6f 72 0a 20 20 28 6d 61 6b 65 2d parator. (make-
57f0: 63 6f 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 constructor-proc
5800: 65 64 75 72 65 0a 20 20 09 28 66 6f 72 65 69 67 edure. .(foreig
5810: 6e 2d 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c n-lambda nonnull
5820: 2d 69 68 61 6e 64 6c 65 20 22 49 75 70 53 65 70 -ihandle "IupSep
5830: 61 72 61 74 6f 72 22 29 29 29 0a 0a 3b 3b 20 7d arator")))..;; }
5840: 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 4d 69 73 63 65 }}..;; {{{ Misce
5850: 6c 6c 61 6e 65 6f 75 73 20 72 65 73 6f 75 72 63 llaneous resourc
5860: 65 20 66 75 6e 63 74 69 6f 6e 73 0a 0a 28 64 65 e functions..(de
5870: 66 69 6e 65 20 63 6c 69 70 62 6f 61 72 64 0a 09 fine clipboard..
5880: 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 63 74 6f (make-constructo
5890: 72 2d 70 72 6f 63 65 64 75 72 65 0a 09 09 28 66 r-procedure...(f
58a0: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 6e 6f oreign-lambda no
58b0: 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 22 49 nnull-ihandle "I
58c0: 75 70 43 6c 69 70 62 6f 61 72 64 22 29 29 29 0a upClipboard"))).
58d0: 0a 28 64 65 66 69 6e 65 20 74 69 6d 65 72 0a 20 .(define timer.
58e0: 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 63 74 (make-construct
58f0: 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a 20 20 09 or-procedure. .
5900: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 (foreign-lambda
5910: 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 nonnull-ihandle
5920: 22 49 75 70 54 69 6d 65 72 22 29 29 29 0a 0a 28 "IupTimer")))..(
5930: 64 65 66 69 6e 65 20 73 65 6e 64 2d 75 72 6c 0a define send-url.
5940: 09 28 6c 65 74 72 65 63 20 28 5b 73 65 6e 64 2d .(letrec ([send-
5950: 75 72 6c 2f 72 61 77 20 28 66 6f 72 65 69 67 6e url/raw (foreign
5960: 2d 6c 61 6d 62 64 61 20 69 6e 74 20 22 49 75 70 -lambda int "Iup
5970: 48 65 6c 70 22 20 63 2d 73 74 72 69 6e 67 29 5d Help" c-string)]
5980: 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 75 72 6c )...(lambda (url
5990: 29 0a 09 09 09 28 61 6e 64 2d 6c 65 74 2a 20 28 )....(and-let* (
59a0: 5b 73 74 61 74 75 73 20 28 73 65 6e 64 2d 75 72 [status (send-ur
59b0: 6c 2f 72 61 77 20 75 72 6c 29 5d 0a 09 09 09 20 l/raw url)]....
59c0: 20 20 20 20 20 20 20 20 20 20 5b 28 6e 6f 74 20 [(not
59d0: 28 3d 20 73 74 61 74 75 73 20 31 29 29 5d 29 0a (= status 1))]).
59e0: 09 09 09 20 20 28 65 72 72 6f 72 20 27 73 65 6e ... (error 'sen
59f0: 64 2d 75 72 6c 20 28 66 6f 72 6d 61 74 20 22 66 d-url (format "f
5a00: 61 69 6c 65 64 20 74 6f 20 6f 70 65 6e 20 55 52 ailed to open UR
5a10: 4c 20 28 7e 73 29 22 20 73 74 61 74 75 73 29 20 L (~s)" status)
5a20: 75 72 6c 29 29 0a 09 09 09 28 76 6f 69 64 29 29 url))....(void))
5a30: 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b ))..;; }}}..;; {
5a40: 7b 7b 20 54 68 65 20 6c 69 62 72 61 72 79 20 77 {{ The library w
5a50: 61 74 63 68 64 6f 67 0a 0a 28 64 65 66 69 6e 65 atchdog..(define
5a60: 20 74 68 72 65 61 64 2d 77 61 74 63 68 64 6f 67 thread-watchdog
5a70: 0a 20 20 28 6c 65 74 72 65 63 20 28 5b 6f 70 65 . (letrec ([ope
5a80: 6e 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 n (foreign-lambd
5a90: 61 2a 20 69 73 74 61 74 75 73 20 28 29 20 22 43 a* istatus () "C
5aa0: 5f 72 65 74 75 72 6e 28 49 75 70 4f 70 65 6e 28 _return(IupOpen(
5ab0: 4e 55 4c 4c 2c 20 4e 55 4c 4c 29 29 3b 22 29 5d NULL, NULL));")]
5ac0: 0a 20 20 20 20 20 20 20 20 20 20 20 5b 6f 70 65 . [ope
5ad0: 6e 2d 69 6d 67 6c 69 62 20 28 66 6f 72 65 69 67 n-imglib (foreig
5ae0: 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 49 n-lambda void "I
5af0: 75 70 49 6d 61 67 65 4c 69 62 4f 70 65 6e 22 29 upImageLibOpen")
5b00: 5d 0a 20 20 20 20 20 20 20 20 20 20 20 5b 63 6c ]. [cl
5b10: 6f 73 65 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d ose (foreign-lam
5b20: 62 64 61 20 76 6f 69 64 20 22 49 75 70 43 6c 6f bda void "IupClo
5b30: 73 65 22 29 5d 0a 20 20 20 20 20 20 20 20 20 20 se")].
5b40: 20 5b 63 68 69 63 6b 65 6e 2d 79 69 65 6c 64 20 [chicken-yield
5b50: 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 (foreign-value "
5b60: 26 43 48 49 43 4b 45 4e 5f 79 69 65 6c 64 22 20 &CHICKEN_yield"
5b70: 63 2d 70 6f 69 6e 74 65 72 29 5d 29 0a 09 09 28 c-pointer)])...(
5b80: 61 6e 64 2d 6c 65 74 2a 20 28 5b 6c 61 6e 67 20 and-let* ([lang
5b90: 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4c 41 4e (or (getenv "LAN
5ba0: 47 22 29 20 22 22 29 5d 0a 20 20 20 20 20 20 20 G") "")].
5bb0: 20 20 20 20 20 20 20 20 5b 28 6c 65 74 20 28 5b [(let ([
5bc0: 73 74 61 74 75 73 20 28 64 79 6e 61 6d 69 63 2d status (dynamic-
5bd0: 77 69 6e 64 20 28 63 75 74 20 73 65 74 65 6e 76 wind (cut setenv
5be0: 20 22 4c 41 4e 47 22 20 22 43 22 29 20 6f 70 65 "LANG" "C") ope
5bf0: 6e 20 28 63 75 74 20 73 65 74 65 6e 76 20 22 4c n (cut setenv "L
5c00: 41 4e 47 22 20 6c 61 6e 67 29 29 5d 29 0a 20 20 ANG" lang))]).
5c10: 20 20 09 09 09 20 20 20 20 20 20 20 20 28 63 61 ... (ca
5c20: 73 65 20 73 74 61 74 75 73 0a 09 09 09 09 09 09 se status.......
5c30: 09 09 09 09 5b 28 23 74 29 20 20 20 20 20 23 74 ....[(#t) #t
5c40: 5d 0a 09 09 09 09 09 09 09 09 09 09 5b 28 69 67 ]...........[(ig
5c50: 6e 6f 72 65 29 20 23 66 5d 0a 09 09 09 09 09 09 nore) #f].......
5c60: 09 09 09 09 5b 65 6c 73 65 20 20 20 20 20 28 65 ....[else (e
5c70: 72 72 6f 72 20 27 69 75 70 20 28 66 6f 72 6d 61 rror 'iup (forma
5c80: 74 20 22 66 61 69 6c 65 64 20 74 6f 20 69 6e 69 t "failed to ini
5c90: 74 69 61 6c 69 7a 65 20 6c 69 62 72 61 72 79 20 tialize library
5ca0: 28 7e 73 29 22 20 73 74 61 74 75 73 29 29 5d 29 (~s)" status))])
5cb0: 29 5d 0a 20 20 20 20 20 20 09 20 20 20 20 20 20 )]. .
5cc0: 20 5b 28 6f 70 65 6e 2d 69 6d 67 6c 69 62 29 5d [(open-imglib)]
5cd0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5ce0: 5b 77 61 74 63 68 64 6f 67 20 28 74 69 6d 65 72 [watchdog (timer
5cf0: 29 5d 29 0a 20 20 20 20 20 20 28 73 65 74 2d 66 )]). (set-f
5d00: 69 6e 61 6c 69 7a 65 72 21 0a 20 20 20 20 20 20 inalizer!.
5d10: 20 77 61 74 63 68 64 6f 67 0a 20 20 20 20 20 20 watchdog.
5d20: 20 28 6c 61 6d 62 64 61 20 28 77 61 74 63 68 64 (lambda (watchd
5d30: 6f 67 29 0a 20 20 20 20 20 20 20 20 20 28 64 65 og). (de
5d40: 73 74 72 6f 79 21 20 77 61 74 63 68 64 6f 67 29 stroy! watchdog)
5d50: 0a 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 . (close
5d60: 29 29 29 0a 20 20 20 20 20 20 28 63 61 6c 6c 62 ))). (callb
5d70: 61 63 6b 2d 73 65 74 21 20 77 61 74 63 68 64 6f ack-set! watchdo
5d80: 67 20 27 61 63 74 69 6f 6e 2d 63 62 20 63 68 69 g 'action-cb chi
5d90: 63 6b 65 6e 2d 79 69 65 6c 64 29 0a 20 20 20 20 cken-yield).
5da0: 20 20 28 61 74 74 72 69 62 75 74 65 2d 73 65 74 (attribute-set
5db0: 21 20 77 61 74 63 68 64 6f 67 20 27 74 69 6d 65 ! watchdog 'time
5dc0: 20 35 30 30 29 0a 20 20 20 20 20 20 28 61 74 74 500). (att
5dd0: 72 69 62 75 74 65 2d 73 65 74 21 20 77 61 74 63 ribute-set! watc
5de0: 68 64 6f 67 20 27 72 75 6e 20 23 74 29 0a 20 20 hdog 'run #t).
5df0: 20 20 20 20 77 61 74 63 68 64 6f 67 29 29 29 0a watchdog))).
5e00: 0a 3b 3b 20 7d 7d 7d 0a 0a 29 0a .;; }}}..).