Artifact
f43d2a041d4adeae7af2e53f4c52fb990be7527b:
0000: 3b 3b 20 2d 2a 2d 20 6d 6f 64 65 3a 20 53 63 68 ;; -*- mode: Sch
0010: 65 6d 65 3b 20 74 61 62 2d 77 69 64 74 68 3a 20 eme; tab-width:
0020: 32 3b 20 2d 2a 2d 20 3b 3b 0a 0a 3b 3b 20 7b 7b 2; -*- ;;..;; {{
0030: 7b 20 44 61 74 61 20 74 79 70 65 73 0a 0a 28 66 { Data types..(f
0040: 6f 72 65 69 67 6e 2d 64 65 63 6c 61 72 65 0a 09 oreign-declare..
0050: 22 23 69 6e 63 6c 75 64 65 20 3c 63 61 6c 6c 62 "#include <callb
0060: 61 63 6b 2e 68 3e 5c 6e 22 0a 09 22 23 69 6e 63 ack.h>\n".."#inc
0070: 6c 75 64 65 20 3c 6c 6f 63 61 6c 65 2e 68 3e 5c lude <locale.h>\
0080: 6e 22 0a 09 22 23 69 6e 63 6c 75 64 65 20 3c 69 n".."#include <i
0090: 75 70 2e 68 3e 5c 6e 22 0a 09 22 23 69 6e 63 6c up.h>\n".."#incl
00a0: 75 64 65 20 3c 69 75 70 69 6d 2e 68 3e 5c 6e 22 ude <iupim.h>\n"
00b0: 0a 09 22 74 79 70 65 64 65 66 20 73 74 72 75 63 .."typedef struc
00c0: 74 20 49 63 6c 61 73 73 5f 20 49 63 6c 61 73 73 t Iclass_ Iclass
00d0: 3b 5c 6e 22 0a 09 22 73 74 72 75 63 74 20 49 68 ;\n".."struct Ih
00e0: 61 6e 64 6c 65 5f 20 7b 20 63 68 61 72 20 73 69 andle_ { char si
00f0: 67 5b 34 5d 3b 20 49 63 6c 61 73 73 20 2a 69 63 g[4]; Iclass *ic
0100: 6c 61 73 73 3b 20 2f 2a 20 2e 2e 2e 20 2a 2f 20 lass; /* ... */
0110: 7d 20 3b 5c 6e 22 0a 09 22 65 78 74 65 72 6e 20 } ;\n".."extern
0120: 63 68 61 72 20 2a 69 75 70 43 6c 61 73 73 43 61 char *iupClassCa
0130: 6c 6c 62 61 63 6b 47 65 74 46 6f 72 6d 61 74 28 llbackGetFormat(
0140: 49 63 6c 61 73 73 20 2a 69 63 6c 61 73 73 2c 20 Iclass *iclass,
0150: 63 6f 6e 73 74 20 63 68 61 72 20 2a 6e 61 6d 65 const char *name
0160: 29 3b 5c 6e 22 29 0a 0a 28 64 65 66 69 6e 65 20 );\n")..(define
0170: 2a 69 68 61 6e 64 6c 65 2d 74 61 67 2a 20 22 49 *ihandle-tag* "I
0180: 68 61 6e 64 6c 65 22 29 0a 28 64 65 66 69 6e 65 handle").(define
0190: 20 69 68 61 6e 64 6c 65 3f 20 28 63 75 74 20 74 ihandle? (cut t
01a0: 61 67 67 65 64 2d 70 6f 69 6e 74 65 72 3f 20 3c agged-pointer? <
01b0: 3e 20 2a 69 68 61 6e 64 6c 65 2d 74 61 67 2a 29 > *ihandle-tag*)
01c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 69 68 61 6e )..(define (ihan
01d0: 64 6c 65 2d 3e 70 6f 69 6e 74 65 72 20 6e 6f 6e dle->pointer non
01e0: 6e 75 6c 6c 3f 29 0a 09 28 69 66 20 6e 6f 6e 6e null?)..(if nonn
01f0: 75 6c 6c 3f 0a 09 09 28 6c 61 6d 62 64 61 20 28 ull?...(lambda (
0200: 68 61 6e 64 6c 65 29 0a 09 09 09 28 65 6e 73 75 handle)....(ensu
0210: 72 65 20 69 68 61 6e 64 6c 65 3f 20 68 61 6e 64 re ihandle? hand
0220: 6c 65 29 0a 09 09 09 68 61 6e 64 6c 65 29 0a 09 le)....handle)..
0230: 09 28 6c 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 .(lambda (handle
0240: 29 0a 09 09 09 28 65 6e 73 75 72 65 20 28 64 69 )....(ensure (di
0250: 73 6a 6f 69 6e 20 6e 6f 74 20 69 68 61 6e 64 6c sjoin not ihandl
0260: 65 3f 29 20 68 61 6e 64 6c 65 29 0a 09 09 09 68 e?) handle)....h
0270: 61 6e 64 6c 65 29 29 29 0a 0a 28 64 65 66 69 6e andle)))..(defin
0280: 65 20 28 70 6f 69 6e 74 65 72 2d 3e 69 68 61 6e e (pointer->ihan
0290: 64 6c 65 20 6e 6f 6e 6e 75 6c 6c 3f 29 0a 09 28 dle nonnull?)..(
02a0: 69 66 20 6e 6f 6e 6e 75 6c 6c 3f 0a 09 09 28 6c if nonnull?...(l
02b0: 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 29 0a 09 ambda (handle)..
02c0: 09 09 28 65 6e 73 75 72 65 20 70 6f 69 6e 74 65 ..(ensure pointe
02d0: 72 3f 20 68 61 6e 64 6c 65 29 0a 09 09 09 28 74 r? handle)....(t
02e0: 61 67 2d 70 6f 69 6e 74 65 72 20 68 61 6e 64 6c ag-pointer handl
02f0: 65 20 2a 69 68 61 6e 64 6c 65 2d 74 61 67 2a 29 e *ihandle-tag*)
0300: 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 68 61 6e )...(lambda (han
0310: 64 6c 65 29 0a 09 09 09 28 61 6e 64 20 68 61 6e dle)....(and han
0320: 64 6c 65 20 28 74 61 67 2d 70 6f 69 6e 74 65 72 dle (tag-pointer
0330: 20 68 61 6e 64 6c 65 20 2a 69 68 61 6e 64 6c 65 handle *ihandle
0340: 2d 74 61 67 2a 29 29 29 29 29 0a 0a 28 64 65 66 -tag*)))))..(def
0350: 69 6e 65 20 28 69 68 61 6e 64 6c 65 2d 6c 69 73 ine (ihandle-lis
0360: 74 2d 3e 70 6f 69 6e 74 65 72 2d 76 65 63 74 6f t->pointer-vecto
0370: 72 20 6c 73 74 29 0a 09 28 6c 65 74 20 28 5b 70 r lst)..(let ([p
0380: 74 72 73 20 28 6d 61 6b 65 2d 70 6f 69 6e 74 65 trs (make-pointe
0390: 72 2d 76 65 63 74 6f 72 20 28 61 64 64 31 20 28 r-vector (add1 (
03a0: 6c 65 6e 67 74 68 20 6c 73 74 29 29 20 23 66 29 length lst)) #f)
03b0: 5d 29 0a 09 09 28 64 6f 2d 65 63 20 28 3a 6c 69 ])...(do-ec (:li
03c0: 73 74 20 68 61 6e 64 6c 65 20 28 69 6e 64 65 78 st handle (index
03d0: 20 69 29 20 6c 73 74 29 0a 09 09 09 28 62 65 67 i) lst)....(beg
03e0: 69 6e 0a 09 09 09 09 28 65 6e 73 75 72 65 20 69 in.....(ensure i
03f0: 68 61 6e 64 6c 65 3f 20 68 61 6e 64 6c 65 29 0a handle? handle).
0400: 09 09 09 09 28 70 6f 69 6e 74 65 72 2d 76 65 63 ....(pointer-vec
0410: 74 6f 72 2d 73 65 74 21 20 70 74 72 73 20 69 20 tor-set! ptrs i
0420: 68 61 6e 64 6c 65 29 29 29 0a 09 09 70 74 72 73 handle)))...ptrs
0430: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 69 73 74 ))..(define (ist
0440: 61 74 75 73 2d 3e 69 6e 74 65 67 65 72 20 73 74 atus->integer st
0450: 61 74 75 73 29 0a 09 28 63 61 73 65 20 73 74 61 atus)..(case sta
0460: 74 75 73 0a 09 09 5b 28 65 72 72 6f 72 29 20 20 tus...[(error)
0470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2b +
0480: 31 5d 0a 09 09 5b 28 6f 70 65 6e 65 64 20 69 6e 1]...[(opened in
0490: 76 61 6c 69 64 20 69 67 6e 6f 72 65 29 20 2d 31 valid ignore) -1
04a0: 5d 0a 09 09 5b 28 64 65 66 61 75 6c 74 29 20 20 ]...[(default)
04b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 2d 32 5d -2]
04c0: 0a 09 09 5b 28 63 6c 6f 73 65 20 23 66 29 20 20 ...[(close #f)
04d0: 20 20 20 20 20 20 20 20 20 20 20 20 2d 33 5d 0a -3].
04e0: 09 09 5b 28 63 6f 6e 74 69 6e 75 65 29 20 20 20 ..[(continue)
04f0: 20 20 20 20 20 20 20 20 20 20 20 2d 34 5d 0a 09 -4]..
0500: 09 5b 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 .[else
0510: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 69 (if (i
0520: 6e 74 65 67 65 72 3f 20 73 74 61 74 75 73 29 20 nteger? status)
0530: 73 74 61 74 75 73 20 30 29 5d 29 29 0a 0a 28 64 status 0)]))..(d
0540: 65 66 69 6e 65 20 28 69 6e 74 65 67 65 72 2d 3e efine (integer->
0550: 69 73 74 61 74 75 73 20 73 74 61 74 75 73 29 0a istatus status).
0560: 09 28 63 61 73 65 20 73 74 61 74 75 73 0a 09 09 .(case status...
0570: 5b 28 2b 31 29 20 27 65 72 72 6f 72 5d 0a 09 09 [(+1) 'error]...
0580: 5b 28 20 30 29 20 23 74 5d 0a 09 09 5b 28 2d 31 [( 0) #t]...[(-1
0590: 29 20 27 69 67 6e 6f 72 65 5d 0a 09 09 5b 28 2d ) 'ignore]...[(-
05a0: 32 29 20 27 64 65 66 61 75 6c 74 5d 0a 09 09 5b 2) 'default]...[
05b0: 28 2d 33 29 20 23 66 5d 0a 09 09 5b 28 2d 34 29 (-3) #f]...[(-4)
05c0: 20 27 63 6f 6e 74 69 6e 75 65 5d 0a 09 09 5b 65 'continue]...[e
05d0: 6c 73 65 20 73 74 61 74 75 73 5d 29 29 0a 0a 28 lse status]))..(
05e0: 64 65 66 69 6e 65 20 28 69 6e 61 6d 65 2d 3e 73 define (iname->s
05f0: 74 72 69 6e 67 20 64 65 66 61 75 6c 74 2d 63 61 tring default-ca
0600: 73 65 29 0a 09 28 6c 65 74 20 28 5b 63 68 61 6e se)..(let ([chan
0610: 67 65 2d 63 61 73 65 0a 09 20 20 20 20 20 20 20 ge-case..
0620: 28 63 61 73 65 20 64 65 66 61 75 6c 74 2d 63 61 (case default-ca
0630: 73 65 0a 09 20 20 20 20 20 20 20 09 20 5b 28 75 se.. . [(u
0640: 70 63 61 73 65 29 20 20 20 73 74 72 69 6e 67 2d pcase) string-
0650: 75 70 63 61 73 65 5d 0a 09 20 20 20 20 20 20 20 upcase]..
0660: 09 20 5b 28 64 6f 77 6e 63 61 73 65 29 20 73 74 . [(downcase) st
0670: 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 5d 0a 09 ring-downcase]..
0680: 20 20 20 20 20 20 20 09 20 5b 65 6c 73 65 20 20 . [else
0690: 20 20 20 20 20 28 65 72 72 6f 72 20 27 69 6e 61 (error 'ina
06a0: 6d 65 2d 3e 73 74 72 69 6e 67 20 22 75 6e 73 75 me->string "unsu
06b0: 70 70 6f 72 74 65 64 20 64 65 66 61 75 6c 74 20 pported default
06c0: 63 61 73 65 22 20 64 65 66 61 75 6c 74 2d 63 61 case" default-ca
06d0: 73 65 29 5d 29 5d 29 0a 09 09 28 6c 61 6d 62 64 se)])])...(lambd
06e0: 61 20 28 6e 61 6d 65 29 0a 09 09 09 28 63 6f 6e a (name)....(con
06f0: 64 0a 09 09 09 09 5b 28 6f 72 20 28 6e 6f 74 20 d.....[(or (not
0700: 6e 61 6d 65 29 20 28 73 74 72 69 6e 67 3f 20 6e name) (string? n
0710: 61 6d 65 29 29 0a 09 09 09 09 20 6e 61 6d 65 5d ame))..... name]
0720: 0a 09 09 09 09 5b 28 73 79 6d 62 6f 6c 3f 20 6e .....[(symbol? n
0730: 61 6d 65 29 0a 09 09 09 09 20 28 63 68 61 6e 67 ame)..... (chang
0740: 65 2d 63 61 73 65 20 28 73 74 72 69 6e 67 2d 74 e-case (string-t
0750: 72 61 6e 73 6c 61 74 65 20 28 73 79 6d 62 6f 6c ranslate (symbol
0760: 2d 3e 73 74 72 69 6e 67 20 6e 61 6d 65 29 20 23 ->string name) #
0770: 5c 2d 20 23 5c 5f 29 29 5d 0a 09 09 09 09 5b 65 \- #\_))].....[e
0780: 6c 73 65 0a 09 09 09 09 20 28 65 72 72 6f 72 20 lse..... (error
0790: 27 69 6e 61 6d 65 2d 3e 73 74 72 69 6e 67 20 22 'iname->string "
07a0: 62 61 64 20 6e 61 6d 65 22 20 6e 61 6d 65 29 5d bad name" name)]
07b0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
07c0: 74 72 69 6e 67 2d 3e 69 6e 61 6d 65 20 64 65 66 tring->iname def
07d0: 61 75 6c 74 2d 63 61 73 65 29 0a 09 28 6c 65 74 ault-case)..(let
07e0: 20 28 5b 73 70 65 63 69 61 6c 73 0a 09 20 20 20 ([specials..
07f0: 20 20 20 20 28 69 72 72 65 67 65 78 0a 09 20 20 (irregex..
0800: 20 20 20 20 20 09 20 28 63 61 73 65 20 64 65 66 . (case def
0810: 61 75 6c 74 2d 63 61 73 65 0a 09 20 20 20 20 20 ault-case..
0820: 20 20 09 20 09 20 5b 28 75 70 63 61 73 65 29 20 . . [(upcase)
0830: 20 20 22 5b 2d 61 2d 7a 5d 22 5d 0a 09 20 20 20 "[-a-z]"]..
0840: 20 20 20 20 09 20 09 20 5b 28 64 6f 77 6e 63 61 . . [(downca
0850: 73 65 29 20 22 5b 2d 41 2d 5a 5d 22 5d 0a 09 20 se) "[-A-Z]"]..
0860: 20 20 20 20 20 20 09 20 09 20 5b 65 6c 73 65 20 . . [else
0870: 20 20 20 20 20 20 28 65 72 72 6f 72 20 27 73 74 (error 'st
0880: 72 69 6e 67 2d 3e 69 6e 61 6d 65 20 22 75 6e 73 ring->iname "uns
0890: 75 70 70 6f 72 74 65 64 20 64 65 66 61 75 6c 74 upported default
08a0: 20 63 61 73 65 22 20 64 65 66 61 75 6c 74 2d 63 case" default-c
08b0: 61 73 65 29 5d 29 29 5d 29 0a 09 09 28 6c 61 6d ase)]))])...(lam
08c0: 62 64 61 20 28 6e 61 6d 65 29 0a 09 09 09 28 63 bda (name)....(c
08d0: 6f 6e 64 0a 09 09 09 09 5b 28 6f 72 20 28 6e 6f ond.....[(or (no
08e0: 74 20 6e 61 6d 65 29 20 28 69 72 72 65 67 65 78 t name) (irregex
08f0: 2d 73 65 61 72 63 68 20 73 70 65 63 69 61 6c 73 -search specials
0900: 20 6e 61 6d 65 29 29 0a 09 09 09 09 20 6e 61 6d name))..... nam
0910: 65 5d 0a 09 09 09 09 5b 65 6c 73 65 0a 09 09 09 e].....[else....
0920: 09 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f . (string->symbo
0930: 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 l (string-downca
0940: 73 65 20 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 se (string-trans
0950: 6c 61 74 65 20 6e 61 6d 65 20 23 5c 5f 20 23 5c late name #\_ #\
0960: 2d 29 29 29 5d 29 29 29 29 0a 0a 28 69 6e 63 6c -)))]))))..(incl
0970: 75 64 65 20 22 69 75 70 2d 74 79 70 65 73 2e 73 ude "iup-types.s
0980: 63 6d 22 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b cm")..;; }}}..;;
0990: 20 7b 7b 7b 20 53 75 70 70 6f 72 74 20 6d 61 63 {{{ Support mac
09a0: 72 6f 73 20 61 6e 64 20 66 75 6e 63 74 69 6f 6e ros and function
09b0: 73 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 s..(define-synta
09c0: 78 20 3a 63 68 69 6c 64 72 65 6e 0a 09 28 73 79 x :children..(sy
09d0: 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 09 09 ntax-rules ()...
09e0: 5b 28 3a 63 68 69 6c 64 72 65 6e 20 63 63 20 63 [(:children cc c
09f0: 68 69 6c 64 20 68 61 6e 64 6c 65 29 0a 09 09 20 hild handle)...
0a00: 28 3a 64 6f 20 63 63 20 28 5b 63 68 69 6c 64 20 (:do cc ([child
0a10: 28 63 68 69 6c 64 2d 72 65 66 20 68 61 6e 64 6c (child-ref handl
0a20: 65 20 30 29 5d 29 20 63 68 69 6c 64 20 28 28 73 e 0)]) child ((s
0a30: 69 62 6c 69 6e 67 20 63 68 69 6c 64 29 29 29 5d ibling child)))]
0a40: 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 ))..(define-synt
0a50: 61 78 20 6f 70 74 69 6f 6e 61 6c 2d 61 72 67 73 ax optional-args
0a60: 0a 09 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 ..(syntax-rules
0a70: 28 29 0a 09 09 5b 28 6f 70 74 69 6f 6e 61 6c 2d ()...[(optional-
0a80: 61 72 67 73 20 5b 6e 61 6d 65 20 64 65 66 61 75 args [name defau
0a90: 6c 74 5d 20 2e 2e 2e 29 0a 09 09 20 28 6c 61 6d lt] ...)... (lam
0aa0: 62 64 61 20 28 61 72 67 73 29 20 28 6c 65 74 2d bda (args) (let-
0ab0: 6f 70 74 69 6f 6e 61 6c 73 20 61 72 67 73 20 28 optionals args (
0ac0: 5b 6e 61 6d 65 20 64 65 66 61 75 6c 74 5d 20 2e [name default] .
0ad0: 2e 2e 29 20 28 6c 69 73 74 20 6e 61 6d 65 20 2e ..) (list name .
0ae0: 2e 2e 29 29 29 5d 29 29 0a 0a 28 64 65 66 69 6e ..)))]))..(defin
0af0: 65 20 28 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 e ((make-constru
0b00: 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 20 70 ctor-procedure p
0b10: 72 6f 63 20 23 21 6b 65 79 20 5b 61 70 70 6c 79 roc #!key [apply
0b20: 2d 61 72 67 73 20 76 61 6c 75 65 73 5d 29 20 2e -args values]) .
0b30: 20 61 72 67 73 29 0a 09 28 6c 65 74 20 6d 6f 72 args)..(let mor
0b40: 65 20 28 5b 6b 65 79 73 20 27 28 29 5d 20 5b 6b e ([keys '()] [k
0b50: 65 79 2d 61 72 67 73 20 27 28 29 5d 20 5b 70 6f ey-args '()] [po
0b60: 73 2d 61 72 67 73 20 27 28 29 5d 20 5b 72 65 73 s-args '()] [res
0b70: 74 20 61 72 67 73 5d 29 0a 09 09 28 63 6f 6e 64 t args])...(cond
0b80: 0a 09 09 09 5b 28 6e 75 6c 6c 3f 20 72 65 73 74 ....[(null? rest
0b90: 29 0a 09 09 09 20 28 6c 65 74 20 28 5b 68 61 6e ).... (let ([han
0ba0: 64 6c 65 20 28 61 70 70 6c 79 20 70 72 6f 63 20 dle (apply proc
0bb0: 28 61 70 70 6c 79 2d 61 72 67 73 20 28 72 65 76 (apply-args (rev
0bc0: 65 72 73 65 21 20 70 6f 73 2d 61 72 67 73 29 29 erse! pos-args))
0bd0: 29 5d 29 0a 09 09 09 20 09 20 28 64 6f 2d 65 63 )]).... . (do-ec
0be0: 20 28 3a 70 61 72 61 6c 6c 65 6c 20 28 3a 6c 69 (:parallel (:li
0bf0: 73 74 20 6b 65 79 20 6b 65 79 73 29 20 28 3a 6c st key keys) (:l
0c00: 69 73 74 20 61 72 67 20 6b 65 79 2d 61 72 67 73 ist arg key-args
0c10: 29 29 0a 09 09 09 20 09 20 09 20 28 28 69 66 20 )).... . . ((if
0c20: 28 70 72 6f 63 65 64 75 72 65 3f 20 61 72 67 29 (procedure? arg)
0c30: 20 63 61 6c 6c 62 61 63 6b 2d 73 65 74 21 20 61 callback-set! a
0c40: 74 74 72 69 62 75 74 65 2d 73 65 74 21 29 20 68 ttribute-set!) h
0c50: 61 6e 64 6c 65 20 6b 65 79 20 61 72 67 29 29 0a andle key arg)).
0c60: 09 09 09 20 09 20 68 61 6e 64 6c 65 29 5d 0a 09 ... . handle)]..
0c70: 09 09 5b 28 6b 65 79 77 6f 72 64 3f 20 28 63 61 ..[(keyword? (ca
0c80: 72 20 72 65 73 74 29 29 0a 09 09 09 20 28 6d 6f r rest)).... (mo
0c90: 72 65 0a 09 09 09 20 09 20 28 63 6f 6e 73 20 28 re.... . (cons (
0ca0: 63 61 72 20 72 65 73 74 29 20 6b 65 79 73 29 20 car rest) keys)
0cb0: 28 63 6f 6e 73 20 28 63 61 64 72 20 72 65 73 74 (cons (cadr rest
0cc0: 29 20 6b 65 79 2d 61 72 67 73 29 20 70 6f 73 2d ) key-args) pos-
0cd0: 61 72 67 73 0a 09 09 09 20 09 20 28 63 64 64 72 args.... . (cddr
0ce0: 20 72 65 73 74 29 29 5d 0a 09 09 09 5b 65 6c 73 rest))]....[els
0cf0: 65 0a 09 09 09 20 28 6d 6f 72 65 0a 09 09 09 20 e.... (more....
0d00: 09 20 6b 65 79 73 20 6b 65 79 2d 61 72 67 73 20 . keys key-args
0d10: 28 63 6f 6e 73 20 28 63 61 72 20 72 65 73 74 29 (cons (car rest)
0d20: 20 70 6f 73 2d 61 72 67 73 29 0a 09 09 09 20 09 pos-args).... .
0d30: 20 28 63 64 72 20 72 65 73 74 29 29 5d 29 29 29 (cdr rest))])))
0d40: 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b ..;; }}}..;; {{{
0d50: 20 53 79 73 74 65 6d 20 66 75 6e 63 74 69 6f 6e System function
0d60: 73 0a 0a 28 64 65 66 69 6e 65 20 69 75 70 2d 76 s..(define iup-v
0d70: 65 72 73 69 6f 6e 0a 09 28 66 6f 72 65 69 67 6e ersion..(foreign
0d80: 2d 6c 61 6d 62 64 61 20 63 2d 73 74 72 69 6e 67 -lambda c-string
0d90: 20 22 49 75 70 56 65 72 73 69 6f 6e 22 29 29 0a "IupVersion")).
0da0: 0a 28 64 65 66 69 6e 65 20 6c 6f 61 64 2f 6c 65 .(define load/le
0db0: 64 0a 09 28 6c 65 74 72 65 63 20 28 5b 6c 6f 61 d..(letrec ([loa
0dc0: 64 2f 72 61 77 20 28 66 6f 72 65 69 67 6e 2d 6c d/raw (foreign-l
0dd0: 61 6d 62 64 61 20 63 2d 73 74 72 69 6e 67 20 22 ambda c-string "
0de0: 49 75 70 4c 6f 61 64 22 20 63 2d 73 74 72 69 6e IupLoad" c-strin
0df0: 67 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 g)])...(lambda (
0e00: 66 69 6c 65 29 0a 09 09 09 28 61 6e 64 2d 6c 65 file)....(and-le
0e10: 74 2a 20 28 5b 73 74 61 74 75 73 20 28 6c 6f 61 t* ([status (loa
0e20: 64 2f 72 61 77 20 66 69 6c 65 29 5d 29 0a 09 09 d/raw file)])...
0e30: 09 09 28 65 72 72 6f 72 20 27 6c 6f 61 64 2f 6c ..(error 'load/l
0e40: 65 64 20 73 74 61 74 75 73 29 29 0a 09 09 09 28 ed status))....(
0e50: 76 6f 69 64 29 29 29 29 0a 0a 3b 3b 20 7d 7d 7d void))))..;; }}}
0e60: 0a 0a 3b 3b 20 7b 7b 7b 20 41 74 74 72 69 62 75 ..;; {{{ Attribu
0e70: 74 65 20 66 75 6e 63 74 69 6f 6e 73 0a 0a 28 64 te functions..(d
0e80: 65 66 69 6e 65 20 61 74 74 72 69 62 75 74 65 2d efine attribute-
0e90: 73 65 74 21 0a 20 20 28 6c 65 74 72 65 63 20 28 set!. (letrec (
0ea0: 5b 73 65 74 2f 73 74 72 69 6e 67 21 20 28 66 6f [set/string! (fo
0eb0: 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 reign-safe-lambd
0ec0: 61 20 76 6f 69 64 20 22 49 75 70 53 74 6f 72 65 a void "IupStore
0ed0: 41 74 74 72 69 62 75 74 65 22 20 69 68 61 6e 64 Attribute" ihand
0ee0: 6c 65 20 69 6e 61 6d 65 2f 75 70 63 61 73 65 20 le iname/upcase
0ef0: 63 2d 73 74 72 69 6e 67 29 5d 0a 20 20 20 20 20 c-string)].
0f00: 20 20 20 20 20 20 5b 73 65 74 2f 68 61 6e 64 6c [set/handl
0f10: 65 21 20 28 66 6f 72 65 69 67 6e 2d 73 61 66 65 e! (foreign-safe
0f20: 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 49 75 -lambda void "Iu
0f30: 70 53 65 74 41 74 74 72 69 62 75 74 65 48 61 6e pSetAttributeHan
0f40: 64 6c 65 22 20 69 68 61 6e 64 6c 65 20 69 6e 61 dle" ihandle ina
0f50: 6d 65 2f 75 70 63 61 73 65 20 69 68 61 6e 64 6c me/upcase ihandl
0f60: 65 29 5d 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 e)]). (lambda
0f70: 20 28 68 61 6e 64 6c 65 20 6e 61 6d 65 20 76 61 (handle name va
0f80: 6c 75 65 29 0a 20 20 20 20 09 28 63 6f 6e 64 0a lue). .(cond.
0f90: 20 20 20 20 09 09 5b 28 6f 72 20 28 6e 6f 74 20 ..[(or (not
0fa0: 76 61 6c 75 65 29 20 28 73 74 72 69 6e 67 3f 20 value) (string?
0fb0: 76 61 6c 75 65 29 29 0a 20 20 20 20 20 20 20 20 value)).
0fc0: 20 28 73 65 74 2f 73 74 72 69 6e 67 21 20 68 61 (set/string! ha
0fd0: 6e 64 6c 65 20 6e 61 6d 65 20 76 61 6c 75 65 29 ndle name value)
0fe0: 5d 0a 20 20 20 20 20 20 20 20 5b 28 69 68 61 6e ]. [(ihan
0ff0: 64 6c 65 3f 20 76 61 6c 75 65 29 0a 20 20 20 20 dle? value).
1000: 20 20 20 20 20 28 73 65 74 2f 68 61 6e 64 6c 65 (set/handle
1010: 21 20 68 61 6e 64 6c 65 20 6e 61 6d 65 20 76 61 ! handle name va
1020: 6c 75 65 29 5d 0a 20 20 20 20 20 20 20 20 5b 28 lue)]. [(
1030: 62 6f 6f 6c 65 61 6e 3f 20 76 61 6c 75 65 29 0a boolean? value).
1040: 20 20 20 20 20 20 20 20 20 28 73 65 74 2f 73 74 (set/st
1050: 72 69 6e 67 21 20 68 61 6e 64 6c 65 20 6e 61 6d ring! handle nam
1060: 65 20 28 69 66 20 76 61 6c 75 65 20 22 59 45 53 e (if value "YES
1070: 22 20 22 4e 4f 22 29 29 5d 0a 20 20 20 20 20 20 " "NO"))].
1080: 20 20 5b 65 6c 73 65 0a 20 20 20 20 20 20 20 20 [else.
1090: 20 28 73 65 74 2f 73 74 72 69 6e 67 21 20 68 61 (set/string! ha
10a0: 6e 64 6c 65 20 6e 61 6d 65 20 28 2d 3e 73 74 72 ndle name (->str
10b0: 69 6e 67 20 76 61 6c 75 65 29 29 5d 29 29 29 29 ing value))]))))
10c0: 0a 0a 28 64 65 66 69 6e 65 20 61 74 74 72 69 62 ..(define attrib
10d0: 75 74 65 2d 72 65 73 65 74 21 0a 09 28 66 6f 72 ute-reset!..(for
10e0: 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 eign-safe-lambda
10f0: 20 76 6f 69 64 20 22 49 75 70 52 65 73 65 74 41 void "IupResetA
1100: 74 74 72 69 62 75 74 65 22 20 69 68 61 6e 64 6c ttribute" ihandl
1110: 65 20 69 6e 61 6d 65 2f 75 70 63 61 73 65 29 29 e iname/upcase))
1120: 0a 0a 28 64 65 66 69 6e 65 20 61 74 74 72 69 62 ..(define attrib
1130: 75 74 65 0a 20 20 28 67 65 74 74 65 72 2d 77 69 ute. (getter-wi
1140: 74 68 2d 73 65 74 74 65 72 0a 20 20 09 28 66 6f th-setter. .(fo
1150: 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 reign-safe-lambd
1160: 61 20 63 2d 73 74 72 69 6e 67 20 22 49 75 70 47 a c-string "IupG
1170: 65 74 41 74 74 72 69 62 75 74 65 22 20 69 68 61 etAttribute" iha
1180: 6e 64 6c 65 20 69 6e 61 6d 65 2f 75 70 63 61 73 ndle iname/upcas
1190: 65 29 0a 20 20 09 61 74 74 72 69 62 75 74 65 2d e). .attribute-
11a0: 73 65 74 21 29 29 0a 0a 28 64 65 66 69 6e 65 20 set!))..(define
11b0: 68 61 6e 64 6c 65 2d 6e 61 6d 65 2d 73 65 74 21 handle-name-set!
11c0: 0a 09 28 6c 65 74 72 65 63 20 28 5b 68 61 6e 64 ..(letrec ([hand
11d0: 6c 65 2d 73 65 74 21 20 28 66 6f 72 65 69 67 6e le-set! (foreign
11e0: 2d 6c 61 6d 62 64 61 20 69 68 61 6e 64 6c 65 20 -lambda ihandle
11f0: 22 49 75 70 53 65 74 48 61 6e 64 6c 65 22 20 69 "IupSetHandle" i
1200: 6e 61 6d 65 2f 64 6f 77 6e 63 61 73 65 20 69 68 name/downcase ih
1210: 61 6e 64 6c 65 29 5d 29 0a 09 09 28 6c 61 6d 62 andle)])...(lamb
1220: 64 61 20 28 68 61 6e 64 6c 65 20 6e 61 6d 65 29 da (handle name)
1230: 0a 09 09 09 28 68 61 6e 64 6c 65 2d 73 65 74 21 ....(handle-set!
1240: 20 28 6f 72 20 6e 61 6d 65 20 28 68 61 6e 64 6c (or name (handl
1250: 65 2d 6e 61 6d 65 20 68 61 6e 64 6c 65 29 29 20 e-name handle))
1260: 28 61 6e 64 20 6e 61 6d 65 20 68 61 6e 64 6c 65 (and name handle
1270: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 )))))..(define h
1280: 61 6e 64 6c 65 2d 6e 61 6d 65 0a 20 20 28 67 65 andle-name. (ge
1290: 74 74 65 72 2d 77 69 74 68 2d 73 65 74 74 65 72 tter-with-setter
12a0: 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d . .(foreign-lam
12b0: 62 64 61 20 69 6e 61 6d 65 2f 64 6f 77 6e 63 61 bda iname/downca
12c0: 73 65 20 22 49 75 70 47 65 74 4e 61 6d 65 22 20 se "IupGetName"
12d0: 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 nonnull-ihandle)
12e0: 0a 20 20 09 68 61 6e 64 6c 65 2d 6e 61 6d 65 2d . .handle-name-
12f0: 73 65 74 21 29 29 0a 0a 28 64 65 66 69 6e 65 20 set!))..(define
1300: 68 61 6e 64 6c 65 2d 72 65 66 0a 09 28 66 6f 72 handle-ref..(for
1310: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 61 6e eign-lambda ihan
1320: 64 6c 65 20 22 49 75 70 47 65 74 48 61 6e 64 6c dle "IupGetHandl
1330: 65 22 20 69 6e 61 6d 65 2f 64 6f 77 6e 63 61 73 e" iname/downcas
1340: 65 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 e))..;; }}}..;;
1350: 7b 7b 7b 20 45 76 65 6e 74 20 66 75 6e 63 74 69 {{{ Event functi
1360: 6f 6e 73 0a 0a 28 64 65 66 69 6e 65 20 6d 61 69 ons..(define mai
1370: 6e 2d 6c 6f 6f 70 0a 09 28 6c 65 74 72 65 63 20 n-loop..(letrec
1380: 28 5b 6c 6f 6f 70 20 28 66 6f 72 65 69 67 6e 2d ([loop (foreign-
1390: 73 61 66 65 2d 6c 61 6d 62 64 61 20 69 73 74 61 safe-lambda ista
13a0: 74 75 73 20 22 49 75 70 4d 61 69 6e 4c 6f 6f 70 tus "IupMainLoop
13b0: 22 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 ")])...(lambda (
13c0: 29 0a 09 09 09 28 6c 65 74 20 28 5b 73 74 61 74 )....(let ([stat
13d0: 75 73 20 28 6c 6f 6f 70 29 5d 29 0a 09 09 09 09 us (loop)]).....
13e0: 28 63 61 73 65 20 73 74 61 74 75 73 0a 09 09 09 (case status....
13f0: 09 09 5b 28 23 74 29 20 28 76 6f 69 64 29 5d 0a ..[(#t) (void)].
1400: 09 09 09 09 09 5b 65 6c 73 65 20 28 65 72 72 6f .....[else (erro
1410: 72 20 27 6d 61 69 6e 2d 6c 6f 6f 70 20 28 66 6f r 'main-loop (fo
1420: 72 6d 61 74 20 22 65 72 72 6f 72 20 69 6e 20 49 rmat "error in I
1430: 55 50 20 6d 61 69 6e 20 6c 6f 6f 70 20 28 7e 73 UP main loop (~s
1440: 29 22 20 73 74 61 74 75 73 29 29 5d 29 29 29 29 )" status))]))))
1450: 29 0a 0a 28 64 65 66 69 6e 65 20 6d 61 69 6e 2d )..(define main-
1460: 6c 6f 6f 70 2d 73 74 65 70 0a 20 20 28 6c 65 74 loop-step. (let
1470: 72 65 63 20 28 5b 6c 6f 6f 70 2d 73 74 65 70 20 rec ([loop-step
1480: 28 66 6f 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 (foreign-safe-la
1490: 6d 62 64 61 20 69 73 74 61 74 75 73 20 22 49 75 mbda istatus "Iu
14a0: 70 4c 6f 6f 70 53 74 65 70 22 29 5d 0a 20 20 20 pLoopStep")].
14b0: 20 20 20 20 20 20 20 20 5b 6c 6f 6f 70 2d 73 74 [loop-st
14c0: 65 70 2f 77 61 69 74 20 28 66 6f 72 65 69 67 6e ep/wait (foreign
14d0: 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 69 73 74 -safe-lambda ist
14e0: 61 74 75 73 20 22 49 75 70 4c 6f 6f 70 53 74 65 atus "IupLoopSte
14f0: 70 57 61 69 74 22 29 5d 29 0a 20 20 20 20 28 6c pWait")]). (l
1500: 61 6d 62 64 61 20 28 70 6f 6c 6c 3f 29 0a 20 20 ambda (poll?).
1510: 20 20 20 20 28 6c 65 74 20 28 5b 73 74 61 74 75 (let ([statu
1520: 73 20 28 28 69 66 20 70 6f 6c 6c 3f 20 6c 6f 6f s ((if poll? loo
1530: 70 2d 73 74 65 70 20 6c 6f 6f 70 2d 73 74 65 70 p-step loop-step
1540: 2f 77 61 69 74 29 29 5d 29 0a 20 20 20 20 20 20 /wait))]).
1550: 20 20 28 63 61 73 65 20 73 74 61 74 75 73 0a 20 (case status.
1560: 20 20 20 20 20 20 20 20 20 5b 28 65 72 72 6f 72 [(error
1570: 29 20 28 65 72 72 6f 72 20 27 6d 61 69 6e 2d 6c ) (error 'main-l
1580: 6f 6f 70 2d 73 74 65 70 20 22 65 72 72 6f 72 20 oop-step "error
1590: 69 6e 20 49 55 50 20 6d 61 69 6e 20 6c 6f 6f 70 in IUP main loop
15a0: 22 29 5d 0a 20 20 20 20 20 20 20 20 20 20 5b 65 ")]. [e
15b0: 6c 73 65 20 20 20 20 73 74 61 74 75 73 5d 29 29 lse status]))
15c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 6d 61 69 )))..(define mai
15d0: 6e 2d 6c 6f 6f 70 2d 6c 65 76 65 6c 0a 09 28 66 n-loop-level..(f
15e0: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 6e oreign-lambda in
15f0: 74 20 22 49 75 70 4d 61 69 6e 4c 6f 6f 70 4c 65 t "IupMainLoopLe
1600: 76 65 6c 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 vel"))..(define
1610: 6d 61 69 6e 2d 6c 6f 6f 70 2d 65 78 69 74 0a 09 main-loop-exit..
1620: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 (foreign-lambda
1630: 76 6f 69 64 20 22 49 75 70 45 78 69 74 4c 6f 6f void "IupExitLoo
1640: 70 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 6d 61 p"))..(define ma
1650: 69 6e 2d 6c 6f 6f 70 2d 66 6c 75 73 68 0a 09 28 in-loop-flush..(
1660: 66 6f 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d foreign-safe-lam
1670: 62 64 61 20 76 6f 69 64 20 22 49 75 70 46 6c 75 bda void "IupFlu
1680: 73 68 22 29 29 0a 0a 28 64 65 66 69 6e 65 2d 76 sh"))..(define-v
1690: 61 6c 75 65 73 20 28 72 65 67 69 73 74 72 79 2d alues (registry-
16a0: 73 65 74 21 20 72 65 67 69 73 74 72 79 20 72 65 set! registry re
16b0: 67 69 73 74 72 79 2d 64 65 73 74 72 6f 79 21 29 gistry-destroy!)
16c0: 0a 20 20 28 6c 65 74 72 65 63 20 28 5b 72 65 67 . (letrec ([reg
16d0: 69 73 74 72 79 2d 63 65 6c 6c 2d 73 65 74 21 0a istry-cell-set!.
16e0: 20 20 09 09 09 09 09 28 66 6f 72 65 69 67 6e 2d .....(foreign-
16f0: 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 28 5b 6e lambda* void ([n
1700: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 68 onnull-ihandle h
1710: 61 6e 64 6c 65 5d 20 5b 63 2d 70 6f 69 6e 74 65 andle] [c-pointe
1720: 72 20 63 65 6c 6c 5d 29 0a 20 20 09 09 09 09 09 r cell]). .....
1730: 09 22 49 75 70 53 65 74 41 74 74 72 69 62 75 74 ."IupSetAttribut
1740: 65 28 68 61 6e 64 6c 65 2c 20 5c 22 43 48 49 43 e(handle, \"CHIC
1750: 4b 45 4e 5f 52 45 47 49 53 54 52 59 5c 22 2c 20 KEN_REGISTRY\",
1760: 63 65 6c 6c 29 3b 22 29 5d 0a 20 20 09 09 09 09 cell);")]. ....
1770: 20 5b 72 65 67 69 73 74 72 79 2d 63 65 6c 6c 0a [registry-cell.
1780: 20 20 09 09 09 09 20 20 28 66 6f 72 65 69 67 6e .... (foreign
1790: 2d 6c 61 6d 62 64 61 2a 20 63 2d 70 6f 69 6e 74 -lambda* c-point
17a0: 65 72 20 28 5b 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 er ([nonnull-iha
17b0: 6e 64 6c 65 20 68 61 6e 64 6c 65 5d 29 0a 20 20 ndle handle]).
17c0: 09 09 09 09 20 20 09 22 43 5f 72 65 74 75 72 6e .... ."C_return
17d0: 28 49 75 70 47 65 74 41 74 74 72 69 62 75 74 65 (IupGetAttribute
17e0: 28 68 61 6e 64 6c 65 2c 20 5c 22 43 48 49 43 4b (handle, \"CHICK
17f0: 45 4e 5f 52 45 47 49 53 54 52 59 5c 22 29 29 3b EN_REGISTRY\"));
1800: 22 29 5d 0a 20 20 09 09 09 09 20 5b 6d 61 6b 65 ")]. .... [make
1810: 2d 69 6d 6d 6f 62 69 6c 65 2d 63 65 6c 6c 0a 20 -immobile-cell.
1820: 20 09 09 09 09 20 20 28 66 6f 72 65 69 67 6e 2d .... (foreign-
1830: 6c 61 6d 62 64 61 2a 20 6e 6f 6e 6e 75 6c 6c 2d lambda* nonnull-
1840: 63 2d 70 6f 69 6e 74 65 72 20 28 5b 73 63 68 65 c-pointer ([sche
1850: 6d 65 2d 6f 62 6a 65 63 74 20 76 5d 29 0a 20 20 me-object v]).
1860: 09 09 09 09 20 20 09 22 76 6f 69 64 20 2a 63 65 .... ."void *ce
1870: 6c 6c 20 3d 20 43 48 49 43 4b 45 4e 5f 6e 65 77 ll = CHICKEN_new
1880: 5f 67 63 5f 72 6f 6f 74 28 29 3b 5c 6e 22 0a 20 _gc_root();\n".
1890: 20 09 09 09 09 20 20 09 22 43 48 49 43 4b 45 4e .... ."CHICKEN
18a0: 5f 67 63 5f 72 6f 6f 74 5f 73 65 74 28 63 65 6c _gc_root_set(cel
18b0: 6c 2c 20 76 29 3b 5c 6e 22 0a 20 20 09 09 09 09 l, v);\n". ....
18c0: 20 20 09 22 43 5f 72 65 74 75 72 6e 28 63 65 6c ."C_return(cel
18d0: 6c 29 3b 5c 6e 22 29 5d 0a 20 20 09 09 09 09 20 l);\n")]. ....
18e0: 5b 63 65 6c 6c 2d 64 65 73 74 72 6f 79 21 0a 20 [cell-destroy!.
18f0: 20 09 09 09 09 20 20 28 66 6f 72 65 69 67 6e 2d .... (foreign-
1900: 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 43 48 49 lambda void "CHI
1910: 43 4b 45 4e 5f 64 65 6c 65 74 65 5f 67 63 5f 72 CKEN_delete_gc_r
1920: 6f 6f 74 22 20 6e 6f 6e 6e 75 6c 6c 2d 63 2d 70 oot" nonnull-c-p
1930: 6f 69 6e 74 65 72 29 5d 0a 20 20 09 09 09 09 20 ointer)]. ....
1940: 5b 63 65 6c 6c 2d 73 65 74 21 0a 20 20 09 09 09 [cell-set!. ...
1950: 09 20 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 . (foreign-lamb
1960: 64 61 20 76 6f 69 64 20 22 43 48 49 43 4b 45 4e da void "CHICKEN
1970: 5f 67 63 5f 72 6f 6f 74 5f 73 65 74 22 20 6e 6f _gc_root_set" no
1980: 6e 6e 75 6c 6c 2d 63 2d 70 6f 69 6e 74 65 72 20 nnull-c-pointer
1990: 73 63 68 65 6d 65 2d 6f 62 6a 65 63 74 29 5d 0a scheme-object)].
19a0: 20 20 09 09 09 09 20 5b 63 65 6c 6c 2d 72 65 66 .... [cell-ref
19b0: 0a 20 20 09 09 09 09 20 20 28 66 6f 72 65 69 67 . .... (foreig
19c0: 6e 2d 6c 61 6d 62 64 61 20 73 63 68 65 6d 65 2d n-lambda scheme-
19d0: 6f 62 6a 65 63 74 20 22 43 48 49 43 4b 45 4e 5f object "CHICKEN_
19e0: 67 63 5f 72 6f 6f 74 5f 72 65 66 22 20 6e 6f 6e gc_root_ref" non
19f0: 6e 75 6c 6c 2d 63 2d 70 6f 69 6e 74 65 72 29 5d null-c-pointer)]
1a00: 29 0a 20 20 20 20 28 76 61 6c 75 65 73 0a 20 20 ). (values.
1a10: 20 20 20 28 6c 61 6d 62 64 61 20 28 68 61 6e 64 (lambda (hand
1a20: 6c 65 20 76 61 6c 75 65 29 0a 20 20 20 20 20 20 le value).
1a30: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
1a40: 5b 28 72 65 67 69 73 74 72 79 2d 63 65 6c 6c 20 [(registry-cell
1a50: 68 61 6e 64 6c 65 29 20 3d 3e 20 28 63 75 74 20 handle) => (cut
1a60: 63 65 6c 6c 2d 73 65 74 21 20 3c 3e 20 76 61 6c cell-set! <> val
1a70: 75 65 29 5d 0a 20 20 20 20 20 20 20 20 20 5b 65 ue)]. [e
1a80: 6c 73 65 20 28 72 65 67 69 73 74 72 79 2d 63 65 lse (registry-ce
1a90: 6c 6c 2d 73 65 74 21 20 68 61 6e 64 6c 65 20 28 ll-set! handle (
1aa0: 6d 61 6b 65 2d 69 6d 6d 6f 62 69 6c 65 2d 63 65 make-immobile-ce
1ab0: 6c 6c 20 76 61 6c 75 65 29 29 5d 29 29 0a 20 20 ll value))])).
1ac0: 20 20 20 28 6c 61 6d 62 64 61 20 28 68 61 6e 64 (lambda (hand
1ad0: 6c 65 29 0a 20 20 20 20 20 20 20 28 63 6f 6e 64 le). (cond
1ae0: 0a 20 20 20 20 20 20 20 20 20 5b 28 72 65 67 69 . [(regi
1af0: 73 74 72 79 2d 63 65 6c 6c 20 68 61 6e 64 6c 65 stry-cell handle
1b00: 29 20 3d 3e 20 63 65 6c 6c 2d 72 65 66 5d 0a 20 ) => cell-ref].
1b10: 20 20 20 20 20 20 20 20 5b 65 6c 73 65 20 27 28 [else '(
1b20: 29 5d 29 29 0a 20 20 20 20 20 28 6c 61 6d 62 64 )])). (lambd
1b30: 61 20 28 68 61 6e 64 6c 65 29 0a 20 20 20 20 20 a (handle).
1b40: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond.
1b50: 20 5b 28 72 65 67 69 73 74 72 79 2d 63 65 6c 6c [(registry-cell
1b60: 20 68 61 6e 64 6c 65 29 0a 20 20 20 20 20 20 20 handle).
1b70: 20 20 20 3d 3e 20 28 6c 61 6d 62 64 61 20 28 63 => (lambda (c
1b80: 65 6c 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 ell).
1b90: 20 20 20 20 28 72 65 67 69 73 74 72 79 2d 63 65 (registry-ce
1ba0: 6c 6c 2d 73 65 74 21 20 68 61 6e 64 6c 65 20 23 ll-set! handle #
1bb0: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
1bc0: 20 20 28 63 65 6c 6c 2d 64 65 73 74 72 6f 79 21 (cell-destroy!
1bd0: 20 63 65 6c 6c 29 29 5d 29 29 29 29 29 0a 0a 28 cell))])))))..(
1be0: 64 65 66 69 6e 65 2d 65 78 74 65 72 6e 61 6c 20 define-external
1bf0: 28 63 61 6c 6c 62 61 63 6b 5f 65 6e 74 72 79 20 (callback_entry
1c00: 5b 63 2d 70 6f 69 6e 74 65 72 20 63 65 6c 6c 5d [c-pointer cell]
1c10: 20 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d [c-pointer fram
1c20: 65 5d 29 20 76 6f 69 64 0a 09 28 64 65 66 69 6e e]) void..(defin
1c30: 65 20 63 65 6c 6c 2d 72 65 66 0a 09 09 28 66 6f e cell-ref...(fo
1c40: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 73 63 68 reign-lambda sch
1c50: 65 6d 65 2d 6f 62 6a 65 63 74 20 22 43 48 49 43 eme-object "CHIC
1c60: 4b 45 4e 5f 67 63 5f 72 6f 6f 74 5f 72 65 66 22 KEN_gc_root_ref"
1c70: 20 6e 6f 6e 6e 75 6c 6c 2d 63 2d 70 6f 69 6e 74 nonnull-c-point
1c80: 65 72 29 29 0a 09 0a 09 28 64 65 66 69 6e 65 20 er))....(define
1c90: 66 72 61 6d 65 2d 73 74 61 72 74 2f 75 62 79 74 frame-start/ubyt
1ca0: 65 21 0a 09 09 28 66 6f 72 65 69 67 6e 2d 6c 61 e!...(foreign-la
1cb0: 6d 62 64 61 2a 20 76 6f 69 64 20 28 5b 63 2d 70 mbda* void ([c-p
1cc0: 6f 69 6e 74 65 72 20 66 72 61 6d 65 5d 29 20 22 ointer frame]) "
1cd0: 76 61 5f 73 74 61 72 74 5f 75 63 68 61 72 28 28 va_start_uchar((
1ce0: 76 61 5f 61 6c 69 73 74 29 66 72 61 6d 65 29 3b va_alist)frame);
1cf0: 22 29 29 0a 09 28 64 65 66 69 6e 65 20 66 72 61 "))..(define fra
1d00: 6d 65 2d 73 74 61 72 74 2f 69 6e 74 21 0a 09 09 me-start/int!...
1d10: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a (foreign-lambda*
1d20: 20 76 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 void ([c-pointe
1d30: 72 20 66 72 61 6d 65 5d 29 20 22 76 61 5f 73 74 r frame]) "va_st
1d40: 61 72 74 5f 69 6e 74 28 28 76 61 5f 61 6c 69 73 art_int((va_alis
1d50: 74 29 66 72 61 6d 65 29 3b 22 29 29 0a 09 28 64 t)frame);"))..(d
1d60: 65 66 69 6e 65 20 66 72 61 6d 65 2d 73 74 61 72 efine frame-star
1d70: 74 2f 66 6c 6f 61 74 21 0a 09 09 28 66 6f 72 65 t/float!...(fore
1d80: 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 ign-lambda* void
1d90: 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 ([c-pointer fra
1da0: 6d 65 5d 29 20 22 76 61 5f 73 74 61 72 74 5f 66 me]) "va_start_f
1db0: 6c 6f 61 74 28 28 76 61 5f 61 6c 69 73 74 29 66 loat((va_alist)f
1dc0: 72 61 6d 65 29 3b 22 29 29 0a 09 28 64 65 66 69 rame);"))..(defi
1dd0: 6e 65 20 66 72 61 6d 65 2d 73 74 61 72 74 2f 64 ne frame-start/d
1de0: 6f 75 62 6c 65 21 0a 09 09 28 66 6f 72 65 69 67 ouble!...(foreig
1df0: 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 28 n-lambda* void (
1e00: 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 [c-pointer frame
1e10: 5d 29 20 22 76 61 5f 73 74 61 72 74 5f 64 6f 75 ]) "va_start_dou
1e20: 62 6c 65 28 28 76 61 5f 61 6c 69 73 74 29 66 72 ble((va_alist)fr
1e30: 61 6d 65 29 3b 22 29 29 0a 09 28 64 65 66 69 6e ame);"))..(defin
1e40: 65 20 66 72 61 6d 65 2d 73 74 61 72 74 2f 70 6f e frame-start/po
1e50: 69 6e 74 65 72 21 0a 09 09 28 66 6f 72 65 69 67 inter!...(foreig
1e60: 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 28 n-lambda* void (
1e70: 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 [c-pointer frame
1e80: 5d 29 20 22 76 61 5f 73 74 61 72 74 5f 70 74 72 ]) "va_start_ptr
1e90: 28 28 76 61 5f 61 6c 69 73 74 29 66 72 61 6d 65 ((va_alist)frame
1ea0: 2c 20 76 6f 69 64 20 2a 29 3b 22 29 29 0a 09 0a , void *);"))...
1eb0: 09 28 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 61 .(define frame-a
1ec0: 72 67 2f 75 62 79 74 65 21 0a 09 09 28 66 6f 72 rg/ubyte!...(for
1ed0: 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 75 6e 73 eign-lambda* uns
1ee0: 69 67 6e 65 64 2d 62 79 74 65 20 28 5b 63 2d 70 igned-byte ([c-p
1ef0: 6f 69 6e 74 65 72 20 66 72 61 6d 65 5d 29 20 22 ointer frame]) "
1f00: 43 5f 72 65 74 75 72 6e 28 76 61 5f 61 72 67 5f C_return(va_arg_
1f10: 75 63 68 61 72 28 28 76 61 5f 61 6c 69 73 74 29 uchar((va_alist)
1f20: 66 72 61 6d 65 29 29 3b 22 29 29 0a 09 28 64 65 frame));"))..(de
1f30: 66 69 6e 65 20 66 72 61 6d 65 2d 61 72 67 2f 69 fine frame-arg/i
1f40: 6e 74 21 0a 09 09 28 66 6f 72 65 69 67 6e 2d 6c nt!...(foreign-l
1f50: 61 6d 62 64 61 2a 20 69 6e 74 20 28 5b 63 2d 70 ambda* int ([c-p
1f60: 6f 69 6e 74 65 72 20 66 72 61 6d 65 5d 29 20 22 ointer frame]) "
1f70: 43 5f 72 65 74 75 72 6e 28 76 61 5f 61 72 67 5f C_return(va_arg_
1f80: 69 6e 74 28 28 76 61 5f 61 6c 69 73 74 29 66 72 int((va_alist)fr
1f90: 61 6d 65 29 29 3b 22 29 29 0a 09 28 64 65 66 69 ame));"))..(defi
1fa0: 6e 65 20 66 72 61 6d 65 2d 61 72 67 2f 66 6c 6f ne frame-arg/flo
1fb0: 61 74 21 0a 09 09 28 66 6f 72 65 69 67 6e 2d 6c at!...(foreign-l
1fc0: 61 6d 62 64 61 2a 20 66 6c 6f 61 74 20 28 5b 63 ambda* float ([c
1fd0: 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 5d 29 -pointer frame])
1fe0: 20 22 43 5f 72 65 74 75 72 6e 28 76 61 5f 61 72 "C_return(va_ar
1ff0: 67 5f 66 6c 6f 61 74 28 28 76 61 5f 61 6c 69 73 g_float((va_alis
2000: 74 29 66 72 61 6d 65 29 29 3b 22 29 29 0a 09 28 t)frame));"))..(
2010: 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 61 72 67 define frame-arg
2020: 2f 64 6f 75 62 6c 65 21 0a 09 09 28 66 6f 72 65 /double!...(fore
2030: 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 64 6f 75 62 ign-lambda* doub
2040: 6c 65 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 le ([c-pointer f
2050: 72 61 6d 65 5d 29 20 22 43 5f 72 65 74 75 72 6e rame]) "C_return
2060: 28 76 61 5f 61 72 67 5f 64 6f 75 62 6c 65 28 28 (va_arg_double((
2070: 76 61 5f 61 6c 69 73 74 29 66 72 61 6d 65 29 29 va_alist)frame))
2080: 3b 22 29 29 0a 09 28 64 65 66 69 6e 65 20 66 72 ;"))..(define fr
2090: 61 6d 65 2d 61 72 67 2f 73 74 72 69 6e 67 21 0a ame-arg/string!.
20a0: 09 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 ..(foreign-lambd
20b0: 61 2a 20 63 2d 73 74 72 69 6e 67 20 28 5b 63 2d a* c-string ([c-
20c0: 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 5d 29 20 pointer frame])
20d0: 22 43 5f 72 65 74 75 72 6e 28 76 61 5f 61 72 67 "C_return(va_arg
20e0: 5f 70 74 72 28 28 76 61 5f 61 6c 69 73 74 29 66 _ptr((va_alist)f
20f0: 72 61 6d 65 2c 20 63 68 61 72 20 2a 29 29 3b 22 rame, char *));"
2100: 29 29 0a 09 28 64 65 66 69 6e 65 20 66 72 61 6d ))..(define fram
2110: 65 2d 61 72 67 2f 70 6f 69 6e 74 65 72 21 0a 09 e-arg/pointer!..
2120: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
2130: 2a 20 63 2d 70 6f 69 6e 74 65 72 20 28 5b 63 2d * c-pointer ([c-
2140: 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 5d 29 20 pointer frame])
2150: 22 43 5f 72 65 74 75 72 6e 28 76 61 5f 61 72 67 "C_return(va_arg
2160: 5f 70 74 72 28 28 76 61 5f 61 6c 69 73 74 29 66 _ptr((va_alist)f
2170: 72 61 6d 65 2c 20 76 6f 69 64 20 2a 29 29 3b 22 rame, void *));"
2180: 29 29 0a 09 28 64 65 66 69 6e 65 20 66 72 61 6d ))..(define fram
2190: 65 2d 61 72 67 2f 68 61 6e 64 6c 65 21 0a 09 09 e-arg/handle!...
21a0: 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a (foreign-lambda*
21b0: 20 69 68 61 6e 64 6c 65 20 28 5b 63 2d 70 6f 69 ihandle ([c-poi
21c0: 6e 74 65 72 20 66 72 61 6d 65 5d 29 20 22 43 5f nter frame]) "C_
21d0: 72 65 74 75 72 6e 28 76 61 5f 61 72 67 5f 70 74 return(va_arg_pt
21e0: 72 28 28 76 61 5f 61 6c 69 73 74 29 66 72 61 6d r((va_alist)fram
21f0: 65 2c 20 49 68 61 6e 64 6c 65 20 2a 29 29 3b 22 e, Ihandle *));"
2200: 29 29 0a 09 0a 09 28 64 65 66 69 6e 65 20 66 72 ))....(define fr
2210: 61 6d 65 2d 72 65 74 75 72 6e 2f 75 62 79 74 65 ame-return/ubyte
2220: 21 0a 09 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d !...(foreign-lam
2230: 62 64 61 2a 20 76 6f 69 64 20 28 5b 63 2d 70 6f bda* void ([c-po
2240: 69 6e 74 65 72 20 66 72 61 6d 65 5d 20 5b 75 6e inter frame] [un
2250: 73 69 67 6e 65 64 2d 62 79 74 65 20 72 65 74 5d signed-byte ret]
2260: 29 20 22 76 61 5f 72 65 74 75 72 6e 5f 75 63 68 ) "va_return_uch
2270: 61 72 28 28 76 61 5f 61 6c 69 73 74 29 66 72 61 ar((va_alist)fra
2280: 6d 65 2c 20 72 65 74 29 3b 22 29 29 0a 09 3b 28 me, ret);"))..;(
2290: 64 65 66 69 6e 65 20 66 72 61 6d 65 2d 72 65 74 define frame-ret
22a0: 75 72 6e 2f 69 6e 74 21 0a 09 3b 09 28 66 6f 72 urn/int!..;.(for
22b0: 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 eign-lambda* voi
22c0: 64 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 d ([c-pointer fr
22d0: 61 6d 65 5d 20 5b 69 6e 74 20 72 65 74 5d 29 20 ame] [int ret])
22e0: 22 76 61 5f 72 65 74 75 72 6e 5f 69 6e 74 28 28 "va_return_int((
22f0: 76 61 5f 61 6c 69 73 74 29 66 72 61 6d 65 2c 20 va_alist)frame,
2300: 72 65 74 29 3b 22 29 29 0a 09 28 64 65 66 69 6e ret);"))..(defin
2310: 65 20 66 72 61 6d 65 2d 72 65 74 75 72 6e 2f 73 e frame-return/s
2320: 74 61 74 75 73 21 0a 09 09 28 66 6f 72 65 69 67 tatus!...(foreig
2330: 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 28 n-lambda* void (
2340: 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 [c-pointer frame
2350: 5d 20 5b 69 73 74 61 74 75 73 20 72 65 74 5d 29 ] [istatus ret])
2360: 20 22 76 61 5f 72 65 74 75 72 6e 5f 69 6e 74 28 "va_return_int(
2370: 28 76 61 5f 61 6c 69 73 74 29 66 72 61 6d 65 2c (va_alist)frame,
2380: 20 72 65 74 29 3b 22 29 29 0a 09 28 64 65 66 69 ret);"))..(defi
2390: 6e 65 20 66 72 61 6d 65 2d 72 65 74 75 72 6e 2f ne frame-return/
23a0: 66 6c 6f 61 74 21 0a 09 09 28 66 6f 72 65 69 67 float!...(foreig
23b0: 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 28 n-lambda* void (
23c0: 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 [c-pointer frame
23d0: 5d 20 5b 66 6c 6f 61 74 20 72 65 74 5d 29 20 22 ] [float ret]) "
23e0: 76 61 5f 72 65 74 75 72 6e 5f 66 6c 6f 61 74 28 va_return_float(
23f0: 28 76 61 5f 61 6c 69 73 74 29 66 72 61 6d 65 2c (va_alist)frame,
2400: 20 72 65 74 29 3b 22 29 29 0a 09 28 64 65 66 69 ret);"))..(defi
2410: 6e 65 20 66 72 61 6d 65 2d 72 65 74 75 72 6e 2f ne frame-return/
2420: 64 6f 75 62 6c 65 21 0a 09 09 28 66 6f 72 65 69 double!...(forei
2430: 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 gn-lambda* void
2440: 28 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d ([c-pointer fram
2450: 65 5d 20 5b 64 6f 75 62 6c 65 20 72 65 74 5d 29 e] [double ret])
2460: 20 22 76 61 5f 72 65 74 75 72 6e 5f 64 6f 75 62 "va_return_doub
2470: 6c 65 28 28 76 61 5f 61 6c 69 73 74 29 66 72 61 le((va_alist)fra
2480: 6d 65 2c 20 72 65 74 29 3b 22 29 29 0a 09 28 64 me, ret);"))..(d
2490: 65 66 69 6e 65 20 66 72 61 6d 65 2d 72 65 74 75 efine frame-retu
24a0: 72 6e 2f 70 6f 69 6e 74 65 72 21 0a 09 09 28 66 rn/pointer!...(f
24b0: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 76 oreign-lambda* v
24c0: 6f 69 64 20 28 5b 63 2d 70 6f 69 6e 74 65 72 20 oid ([c-pointer
24d0: 66 72 61 6d 65 5d 20 5b 63 2d 70 6f 69 6e 74 65 frame] [c-pointe
24e0: 72 20 72 65 74 5d 29 20 22 76 61 5f 72 65 74 75 r ret]) "va_retu
24f0: 72 6e 5f 70 74 72 28 28 76 61 5f 61 6c 69 73 74 rn_ptr((va_alist
2500: 29 66 72 61 6d 65 2c 20 76 6f 69 64 20 2a 2c 20 )frame, void *,
2510: 72 65 74 29 3b 22 29 29 0a 09 28 64 65 66 69 6e ret);"))..(defin
2520: 65 20 66 72 61 6d 65 2d 72 65 74 75 72 6e 2f 68 e frame-return/h
2530: 61 6e 64 6c 65 21 0a 09 09 28 66 6f 72 65 69 67 andle!...(foreig
2540: 6e 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 28 n-lambda* void (
2550: 5b 63 2d 70 6f 69 6e 74 65 72 20 66 72 61 6d 65 [c-pointer frame
2560: 5d 20 5b 69 68 61 6e 64 6c 65 20 72 65 74 5d 29 ] [ihandle ret])
2570: 20 22 76 61 5f 72 65 74 75 72 6e 5f 70 74 72 28 "va_return_ptr(
2580: 28 76 61 5f 61 6c 69 73 74 29 66 72 61 6d 65 2c (va_alist)frame,
2590: 20 49 68 61 6e 64 6c 65 20 2a 2c 20 72 65 74 29 Ihandle *, ret)
25a0: 3b 22 29 29 0a 09 0a 09 28 6c 65 74 2a 20 28 5b ;"))....(let* ([
25b0: 64 61 74 61 20 28 63 65 6c 6c 2d 72 65 66 20 63 data (cell-ref c
25c0: 65 6c 6c 29 5d 0a 09 09 09 09 20 5b 73 69 67 20 ell)]..... [sig
25d0: 28 63 61 72 20 64 61 74 61 29 5d 0a 09 09 09 09 (car data)].....
25e0: 20 5b 70 72 6f 63 20 28 63 64 72 20 64 61 74 61 [proc (cdr data
25f0: 29 5d 29 0a 09 09 28 63 61 73 65 20 28 73 74 72 )])...(case (str
2600: 69 6e 67 2d 72 65 66 20 73 69 67 20 30 29 0a 09 ing-ref sig 0)..
2610: 09 09 5b 28 23 5c 62 29 20 20 20 20 20 28 66 72 ..[(#\b) (fr
2620: 61 6d 65 2d 73 74 61 72 74 2f 75 62 79 74 65 21 ame-start/ubyte!
2630: 20 66 72 61 6d 65 29 5d 0a 09 09 09 5b 28 23 5c frame)]....[(#\
2640: 69 29 20 20 20 20 20 28 66 72 61 6d 65 2d 73 74 i) (frame-st
2650: 61 72 74 2f 69 6e 74 21 20 66 72 61 6d 65 29 5d art/int! frame)]
2660: 0a 09 09 09 5b 28 23 5c 66 29 20 20 20 20 20 28 ....[(#\f) (
2670: 66 72 61 6d 65 2d 73 74 61 72 74 2f 66 6c 6f 61 frame-start/floa
2680: 74 21 20 66 72 61 6d 65 29 5d 0a 09 09 09 5b 28 t! frame)]....[(
2690: 23 5c 64 29 20 20 20 20 20 28 66 72 61 6d 65 2d #\d) (frame-
26a0: 73 74 61 72 74 2f 64 6f 75 62 6c 65 21 20 66 72 start/double! fr
26b0: 61 6d 65 29 5d 0a 09 09 09 5b 28 23 5c 76 20 23 ame)]....[(#\v #
26c0: 5c 68 29 20 28 66 72 61 6d 65 2d 73 74 61 72 74 \h) (frame-start
26d0: 2f 70 6f 69 6e 74 65 72 21 20 66 72 61 6d 65 29 /pointer! frame)
26e0: 5d 29 0a 09 09 28 6c 65 74 2a 20 28 5b 61 72 67 ])...(let* ([arg
26f0: 73 20 28 6c 69 73 74 2d 65 63 20 28 3a 73 74 72 s (list-ec (:str
2700: 69 6e 67 20 63 68 72 20 22 68 22 20 28 73 74 72 ing chr "h" (str
2710: 69 6e 67 2d 64 72 6f 70 20 73 69 67 20 31 29 29 ing-drop sig 1))
2720: 0a 09 09 09 09 09 20 20 20 20 20 20 20 20 20 28 ...... (
2730: 63 61 73 65 20 63 68 72 0a 09 09 09 09 09 20 20 case chr......
2740: 20 20 20 20 20 20 20 09 20 5b 28 23 5c 62 29 20 . [(#\b)
2750: 28 66 72 61 6d 65 2d 61 72 67 2f 75 62 79 74 65 (frame-arg/ubyte
2760: 21 20 66 72 61 6d 65 29 5d 0a 09 09 09 09 09 20 ! frame)]......
2770: 20 20 20 20 20 20 20 20 09 20 5b 28 23 5c 69 29 . [(#\i)
2780: 20 28 66 72 61 6d 65 2d 61 72 67 2f 69 6e 74 21 (frame-arg/int!
2790: 20 66 72 61 6d 65 29 5d 0a 09 09 09 09 09 20 20 frame)]......
27a0: 20 20 20 20 20 20 20 09 20 5b 28 23 5c 66 29 20 . [(#\f)
27b0: 28 66 72 61 6d 65 2d 61 72 67 2f 66 6c 6f 61 74 (frame-arg/float
27c0: 21 20 66 72 61 6d 65 29 5d 0a 09 09 09 09 09 20 ! frame)]......
27d0: 20 20 20 20 20 20 20 20 09 20 5b 28 23 5c 64 29 . [(#\d)
27e0: 20 28 66 72 61 6d 65 2d 61 72 67 2f 64 6f 75 62 (frame-arg/doub
27f0: 6c 65 21 20 66 72 61 6d 65 29 5d 0a 09 09 09 09 le! frame)].....
2800: 09 20 20 20 20 20 20 20 20 20 09 20 5b 28 23 5c . . [(#\
2810: 73 29 20 28 66 72 61 6d 65 2d 61 72 67 2f 73 74 s) (frame-arg/st
2820: 72 69 6e 67 21 20 66 72 61 6d 65 29 5d 0a 09 09 ring! frame)]...
2830: 09 09 09 20 20 20 20 20 20 20 20 20 09 20 5b 28 ... . [(
2840: 23 5c 76 29 20 28 66 72 61 6d 65 2d 61 72 67 2f #\v) (frame-arg/
2850: 70 6f 69 6e 74 65 72 21 20 66 72 61 6d 65 29 5d pointer! frame)]
2860: 0a 09 09 09 09 09 20 20 20 20 20 20 20 20 20 09 ...... .
2870: 20 5b 28 23 5c 68 29 20 28 66 72 61 6d 65 2d 61 [(#\h) (frame-a
2880: 72 67 2f 68 61 6e 64 6c 65 21 20 66 72 61 6d 65 rg/handle! frame
2890: 29 5d 29 29 5d 0a 09 09 09 09 20 20 20 5b 72 65 )]))]..... [re
28a0: 74 20 28 61 70 70 6c 79 20 70 72 6f 63 20 61 72 t (apply proc ar
28b0: 67 73 29 5d 29 0a 09 09 09 28 63 61 73 65 20 28 gs)])....(case (
28c0: 73 74 72 69 6e 67 2d 72 65 66 20 73 69 67 20 30 string-ref sig 0
28d0: 29 0a 09 09 09 09 5b 28 23 5c 62 29 20 28 66 72 ).....[(#\b) (fr
28e0: 61 6d 65 2d 72 65 74 75 72 6e 2f 75 62 79 74 65 ame-return/ubyte
28f0: 21 20 66 72 61 6d 65 20 72 65 74 29 5d 0a 09 09 ! frame ret)]...
2900: 09 09 5b 28 23 5c 69 29 20 28 66 72 61 6d 65 2d ..[(#\i) (frame-
2910: 72 65 74 75 72 6e 2f 73 74 61 74 75 73 21 20 66 return/status! f
2920: 72 61 6d 65 20 72 65 74 29 5d 0a 09 09 09 09 5b rame ret)].....[
2930: 28 23 5c 66 29 20 28 66 72 61 6d 65 2d 72 65 74 (#\f) (frame-ret
2940: 75 72 6e 2f 66 6c 6f 61 74 21 20 66 72 61 6d 65 urn/float! frame
2950: 20 72 65 74 29 5d 0a 09 09 09 09 5b 28 23 5c 64 ret)].....[(#\d
2960: 29 20 28 66 72 61 6d 65 2d 72 65 74 75 72 6e 2f ) (frame-return/
2970: 64 6f 75 62 6c 65 21 20 66 72 61 6d 65 20 72 65 double! frame re
2980: 74 29 5d 0a 09 09 09 09 5b 28 23 5c 76 29 20 28 t)].....[(#\v) (
2990: 66 72 61 6d 65 2d 72 65 74 75 72 6e 2f 70 6f 69 frame-return/poi
29a0: 6e 74 65 72 21 20 66 72 61 6d 65 20 72 65 74 29 nter! frame ret)
29b0: 5d 0a 09 09 09 09 5b 28 23 5c 68 29 20 28 66 72 ].....[(#\h) (fr
29c0: 61 6d 65 2d 72 65 74 75 72 6e 2f 68 61 6e 64 6c ame-return/handl
29d0: 65 21 20 66 72 61 6d 65 20 72 65 74 29 5d 29 29 e! frame ret)]))
29e0: 29 29 0a 0a 28 64 65 66 69 6e 65 2d 76 61 6c 75 ))..(define-valu
29f0: 65 73 20 28 63 61 6c 6c 62 61 63 6b 2d 73 65 74 es (callback-set
2a00: 21 20 63 61 6c 6c 62 61 63 6b 29 0a 09 28 6c 65 ! callback)..(le
2a10: 74 72 65 63 20 28 5b 73 69 67 6e 61 74 75 72 65 trec ([signature
2a20: 2f 72 61 77 0a 09 09 09 09 09 09 28 66 6f 72 65 /raw.......(fore
2a30: 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 63 2d 73 74 ign-lambda* c-st
2a40: 72 69 6e 67 20 28 5b 6e 6f 6e 6e 75 6c 6c 2d 69 ring ([nonnull-i
2a50: 68 61 6e 64 6c 65 20 68 61 6e 64 6c 65 5d 20 5b handle handle] [
2a60: 69 6e 61 6d 65 2f 75 70 63 61 73 65 20 6e 61 6d iname/upcase nam
2a70: 65 5d 29 0a 09 09 09 09 09 09 09 22 43 5f 72 65 e])........"C_re
2a80: 74 75 72 6e 28 69 75 70 43 6c 61 73 73 43 61 6c turn(iupClassCal
2a90: 6c 62 61 63 6b 47 65 74 46 6f 72 6d 61 74 28 68 lbackGetFormat(h
2aa0: 61 6e 64 6c 65 2d 3e 69 63 6c 61 73 73 2c 20 6e andle->iclass, n
2ab0: 61 6d 65 29 29 3b 22 29 5d 0a 09 09 09 09 09 20 ame));")]......
2ac0: 5b 6d 61 6b 65 2d 77 72 61 70 70 65 72 0a 09 09 [make-wrapper...
2ad0: 09 09 09 20 20 28 66 6f 72 65 69 67 6e 2d 6c 61 ... (foreign-la
2ae0: 6d 62 64 61 2a 20 63 2d 70 6f 69 6e 74 65 72 20 mbda* c-pointer
2af0: 28 5b 73 63 68 65 6d 65 2d 6f 62 6a 65 63 74 20 ([scheme-object
2b00: 76 5d 29 0a 09 09 09 09 09 20 20 09 22 76 6f 69 v])...... ."voi
2b10: 64 20 2a 63 65 6c 6c 20 3d 20 43 48 49 43 4b 45 d *cell = CHICKE
2b20: 4e 5f 6e 65 77 5f 67 63 5f 72 6f 6f 74 28 29 3b N_new_gc_root();
2b30: 5c 6e 22 0a 09 09 09 09 09 20 20 09 22 43 48 49 \n"...... ."CHI
2b40: 43 4b 45 4e 5f 67 63 5f 72 6f 6f 74 5f 73 65 74 CKEN_gc_root_set
2b50: 28 63 65 6c 6c 2c 20 76 29 3b 5c 6e 22 0a 09 09 (cell, v);\n"...
2b60: 09 09 09 20 20 09 22 43 5f 72 65 74 75 72 6e 28 ... ."C_return(
2b70: 61 6c 6c 6f 63 5f 63 61 6c 6c 62 61 63 6b 28 26 alloc_callback(&
2b80: 63 61 6c 6c 62 61 63 6b 5f 65 6e 74 72 79 2c 20 callback_entry,
2b90: 63 65 6c 6c 29 29 3b 5c 6e 22 29 5d 0a 09 09 09 cell));\n")]....
2ba0: 09 09 20 5b 77 72 61 70 70 65 72 2d 64 61 74 61 .. [wrapper-data
2bb0: 0a 09 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 .. (for
2bc0: 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 73 63 68 eign-lambda* sch
2bd0: 65 6d 65 2d 6f 62 6a 65 63 74 20 28 5b 63 2d 70 eme-object ([c-p
2be0: 6f 69 6e 74 65 72 20 70 72 6f 63 5d 29 0a 09 20 ointer proc])..
2bf0: 20 20 20 20 20 20 20 20 20 09 22 43 5f 72 65 74 ."C_ret
2c00: 75 72 6e 28 28 70 72 6f 63 20 26 26 20 69 73 5f urn((proc && is_
2c10: 63 61 6c 6c 62 61 63 6b 28 70 72 6f 63 29 20 3f callback(proc) ?
2c20: 20 43 48 49 43 4b 45 4e 5f 67 63 5f 72 6f 6f 74 CHICKEN_gc_root
2c30: 5f 72 65 66 28 63 61 6c 6c 62 61 63 6b 5f 64 61 _ref(callback_da
2c40: 74 61 28 70 72 6f 63 29 29 20 3a 20 43 5f 53 43 ta(proc)) : C_SC
2c50: 48 45 4d 45 5f 46 41 4c 53 45 29 29 3b 22 29 5d HEME_FALSE));")]
2c60: 0a 09 20 20 20 20 20 20 20 20 20 5b 77 72 61 70 .. [wrap
2c70: 70 65 72 2d 64 65 73 74 72 6f 79 21 0a 09 20 20 per-destroy!..
2c80: 20 20 20 20 20 20 20 20 28 66 6f 72 65 69 67 6e (foreign
2c90: 2d 6c 61 6d 62 64 61 2a 20 76 6f 69 64 20 28 5b -lambda* void ([
2ca0: 63 2d 70 6f 69 6e 74 65 72 20 70 72 6f 63 5d 29 c-pointer proc])
2cb0: 0a 09 20 20 20 20 20 20 20 20 20 20 09 22 69 66 .. ."if
2cc0: 20 28 70 72 6f 63 20 26 26 20 69 73 5f 63 61 6c (proc && is_cal
2cd0: 6c 62 61 63 6b 28 70 72 6f 63 29 29 20 7b 5c 6e lback(proc)) {\n
2ce0: 22 0a 09 20 20 20 20 20 20 20 20 20 20 09 22 20 ".. ."
2cf0: 20 43 48 49 43 4b 45 4e 5f 64 65 6c 65 74 65 5f CHICKEN_delete_
2d00: 67 63 5f 72 6f 6f 74 28 63 61 6c 6c 62 61 63 6b gc_root(callback
2d10: 5f 64 61 74 61 28 70 72 6f 63 29 29 3b 5c 6e 22 _data(proc));\n"
2d20: 0a 09 20 20 20 20 20 20 20 20 20 20 09 22 20 20 .. ."
2d30: 66 72 65 65 5f 63 61 6c 6c 62 61 63 6b 28 70 72 free_callback(pr
2d40: 6f 63 29 3b 5c 6e 22 0a 09 20 20 20 20 20 20 20 oc);\n"..
2d50: 20 20 20 09 22 7d 5c 6e 22 29 5d 0a 09 20 20 20 ."}\n")]..
2d60: 20 20 20 20 20 20 5b 77 72 61 70 70 65 72 2d 3e [wrapper->
2d70: 70 72 6f 63 0a 09 20 20 20 20 20 20 20 20 20 20 proc..
2d80: 28 6c 61 6d 62 64 61 20 28 73 69 67 6e 61 74 75 (lambda (signatu
2d90: 72 65 20 70 72 6f 63 29 0a 09 20 20 20 20 20 20 re proc)..
2da0: 20 20 20 20 09 28 63 6f 6e 64 0a 09 20 20 20 20 .(cond..
2db0: 20 20 20 20 20 20 09 09 5b 28 77 72 61 70 70 65 ..[(wrappe
2dc0: 72 2d 64 61 74 61 20 70 72 6f 63 29 20 3d 3e 20 r-data proc) =>
2dd0: 63 64 72 5d 0a 09 20 20 20 20 20 20 20 20 20 20 cdr]..
2de0: 09 09 5b 65 6c 73 65 20 70 72 6f 63 5d 29 29 5d ..[else proc]))]
2df0: 0a 09 09 09 09 09 20 5b 73 65 74 2f 70 6f 69 6e ...... [set/poin
2e00: 74 65 72 21 0a 09 09 09 09 09 20 20 28 66 6f 72 ter!...... (for
2e10: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 63 2d 70 6f eign-lambda c-po
2e20: 69 6e 74 65 72 20 22 49 75 70 53 65 74 43 61 6c inter "IupSetCal
2e30: 6c 62 61 63 6b 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 lback" nonnull-i
2e40: 68 61 6e 64 6c 65 20 69 6e 61 6d 65 2f 75 70 63 handle iname/upc
2e50: 61 73 65 20 63 2d 70 6f 69 6e 74 65 72 29 5d 0a ase c-pointer)].
2e60: 09 09 09 09 09 20 5b 67 65 74 2f 70 6f 69 6e 74 ..... [get/point
2e70: 65 72 0a 09 09 09 09 09 20 20 28 66 6f 72 65 69 er...... (forei
2e80: 67 6e 2d 6c 61 6d 62 64 61 20 63 2d 70 6f 69 6e gn-lambda c-poin
2e90: 74 65 72 20 22 49 75 70 47 65 74 43 61 6c 6c 62 ter "IupGetCallb
2ea0: 61 63 6b 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 ack" nonnull-iha
2eb0: 6e 64 6c 65 20 69 6e 61 6d 65 2f 75 70 63 61 73 ndle iname/upcas
2ec0: 65 29 5d 0a 09 09 09 09 09 20 5b 73 69 67 69 6c e)]...... [sigil
2ed0: 73 0a 09 09 09 09 09 20 20 28 69 72 72 65 67 65 s...... (irrege
2ee0: 78 20 22 28 5b 62 69 66 64 73 76 68 5d 2a 29 28 x "([bifdsvh]*)(
2ef0: 3f 3a 3d 28 5b 62 69 66 64 76 68 5d 29 29 3f 22 ?:=([bifdvh]))?"
2f00: 29 5d 0a 09 09 09 09 09 20 5b 63 61 6c 6c 62 61 )]...... [callba
2f10: 63 6b 2d 73 65 74 21 0a 09 09 09 09 09 20 20 28 ck-set!...... (
2f20: 6c 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 20 6e lambda (handle n
2f30: 61 6d 65 20 70 72 6f 63 29 0a 09 09 09 09 09 20 ame proc)......
2f40: 20 09 28 6c 65 74 2a 20 28 5b 73 69 67 0a 09 09 .(let* ([sig...
2f50: 09 09 09 20 20 09 20 20 20 20 20 20 20 20 28 63 ... . (c
2f60: 6f 6e 64 0a 09 09 09 09 09 09 09 09 09 09 09 09 ond.............
2f70: 5b 28 69 72 72 65 67 65 78 2d 6d 61 74 63 68 20 [(irregex-match
2f80: 73 69 67 69 6c 73 20 28 6f 72 20 28 73 69 67 6e sigils (or (sign
2f90: 61 74 75 72 65 2f 72 61 77 20 68 61 6e 64 6c 65 ature/raw handle
2fa0: 20 6e 61 6d 65 29 20 22 22 29 29 0a 09 09 09 09 name) "")).....
2fb0: 09 09 09 09 09 09 09 09 20 3d 3e 20 28 6c 61 6d ........ => (lam
2fc0: 62 64 61 20 28 67 72 6f 75 70 73 29 0a 09 09 09 bda (groups)....
2fd0: 09 09 09 09 09 09 09 09 09 09 09 09 28 73 74 72 ............(str
2fe0: 69 6e 67 2d 61 70 70 65 6e 64 0a 09 09 09 09 09 ing-append......
2ff0: 09 09 09 09 09 09 09 09 09 09 09 28 6f 72 20 28 ...........(or (
3000: 69 72 72 65 67 65 78 2d 6d 61 74 63 68 2d 73 75 irregex-match-su
3010: 62 73 74 72 69 6e 67 20 67 72 6f 75 70 73 20 32 bstring groups 2
3020: 29 20 22 69 22 29 0a 09 09 09 09 09 09 09 09 09 ) "i")..........
3030: 09 09 09 09 09 09 09 28 69 72 72 65 67 65 78 2d .......(irregex-
3040: 6d 61 74 63 68 2d 73 75 62 73 74 72 69 6e 67 20 match-substring
3050: 67 72 6f 75 70 73 20 31 29 29 29 5d 0a 09 09 09 groups 1)))]....
3060: 09 09 09 09 09 09 09 09 09 5b 65 6c 73 65 0a 09 .........[else..
3070: 09 09 09 09 09 09 09 09 09 09 09 20 28 65 72 72 ........... (err
3080: 6f 72 20 27 63 61 6c 6c 62 61 63 6b 2d 73 65 74 or 'callback-set
3090: 21 20 22 63 61 6c 6c 62 61 63 6b 20 68 61 73 20 ! "callback has
30a0: 62 61 64 20 73 69 67 6e 61 74 75 72 65 22 20 68 bad signature" h
30b0: 61 6e 64 6c 65 20 6e 61 6d 65 29 5d 29 5d 0a 09 andle name)])]..
30c0: 09 09 09 09 20 20 09 09 09 20 20 20 5b 6e 65 77 .... ... [new
30d0: 0a 09 09 09 09 09 20 20 09 20 20 20 20 20 20 20 ...... .
30e0: 20 28 63 6f 6e 64 0a 09 09 09 09 09 20 20 09 20 (cond...... .
30f0: 20 20 20 20 20 20 20 09 5b 28 6f 72 20 28 6e 6f .[(or (no
3100: 74 20 70 72 6f 63 29 20 28 70 6f 69 6e 74 65 72 t proc) (pointer
3110: 3f 20 70 72 6f 63 29 29 20 70 72 6f 63 5d 0a 09 ? proc)) proc]..
3120: 09 09 09 09 20 20 09 20 20 20 20 20 20 20 20 09 .... . .
3130: 5b 65 6c 73 65 20 28 73 65 74 2d 66 69 6e 61 6c [else (set-final
3140: 69 7a 65 72 21 20 28 6d 61 6b 65 2d 77 72 61 70 izer! (make-wrap
3150: 70 65 72 20 28 63 6f 6e 73 20 73 69 67 20 70 72 per (cons sig pr
3160: 6f 63 29 29 20 77 72 61 70 70 65 72 2d 64 65 73 oc)) wrapper-des
3170: 74 72 6f 79 21 29 5d 29 5d 0a 09 09 09 09 09 20 troy!)])]......
3180: 20 09 20 20 20 20 20 20 20 5b 6f 6c 64 0a 09 09 . [old...
3190: 09 09 09 20 20 09 20 20 20 20 20 20 20 20 28 73 ... . (s
31a0: 65 74 2f 70 6f 69 6e 74 65 72 21 20 68 61 6e 64 et/pointer! hand
31b0: 6c 65 20 6e 61 6d 65 20 6e 65 77 29 5d 29 0a 09 le name new)])..
31c0: 09 09 09 09 09 09 09 28 72 65 67 69 73 74 72 79 .......(registry
31d0: 2d 73 65 74 21 20 68 61 6e 64 6c 65 20 28 63 6f -set! handle (co
31e0: 6e 73 20 6e 65 77 20 28 28 69 66 20 6f 6c 64 20 ns new ((if old
31f0: 28 63 75 74 20 72 65 6d 6f 76 65 21 20 28 63 75 (cut remove! (cu
3200: 74 20 70 6f 69 6e 74 65 72 3d 3f 20 3c 3e 20 6f t pointer=? <> o
3210: 6c 64 29 20 3c 3e 29 20 69 64 65 6e 74 69 74 79 ld) <>) identity
3220: 29 20 28 72 65 67 69 73 74 72 79 20 68 61 6e 64 ) (registry hand
3230: 6c 65 29 29 29 29 29 29 5d 0a 09 09 09 09 09 20 le))))))]......
3240: 5b 63 61 6c 6c 62 61 63 6b 0a 09 09 09 09 09 20 [callback......
3250: 20 28 6c 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 (lambda (handle
3260: 20 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 09 28 name)...... .(
3270: 6c 65 74 20 28 5b 70 72 6f 63 20 28 67 65 74 2f let ([proc (get/
3280: 70 6f 69 6e 74 65 72 20 68 61 6e 64 6c 65 20 6e pointer handle n
3290: 61 6d 65 29 5d 29 0a 09 09 09 09 09 20 20 09 09 ame)])...... ..
32a0: 28 63 6f 6e 64 0a 09 09 09 09 09 20 20 09 09 09 (cond...... ...
32b0: 5b 28 77 72 61 70 70 65 72 2d 64 61 74 61 20 70 [(wrapper-data p
32c0: 72 6f 63 29 20 3d 3e 20 63 64 72 5d 0a 09 09 09 roc) => cdr]....
32d0: 09 09 20 20 09 09 09 5b 65 6c 73 65 20 70 72 6f .. ...[else pro
32e0: 63 5d 29 29 29 5d 29 0a 09 09 28 76 61 6c 75 65 c])))])...(value
32f0: 73 0a 09 09 09 63 61 6c 6c 62 61 63 6b 2d 73 65 s....callback-se
3300: 74 21 0a 09 09 09 28 67 65 74 74 65 72 2d 77 69 t!....(getter-wi
3310: 74 68 2d 73 65 74 74 65 72 20 63 61 6c 6c 62 61 th-setter callba
3320: 63 6b 20 63 61 6c 6c 62 61 63 6b 2d 73 65 74 21 ck callback-set!
3330: 29 29 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b ))))..;; }}}..;;
3340: 20 7b 7b 7b 20 4c 61 79 6f 75 74 20 66 75 6e 63 {{{ Layout func
3350: 74 69 6f 6e 73 0a 0a 28 64 65 66 69 6e 65 20 63 tions..(define c
3360: 72 65 61 74 65 0a 20 20 28 6d 61 6b 65 2d 63 6f reate. (make-co
3370: 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 nstructor-proced
3380: 75 72 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d ure. .(foreign-
3390: 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 lambda nonnull-i
33a0: 68 61 6e 64 6c 65 20 22 49 75 70 43 72 65 61 74 handle "IupCreat
33b0: 65 22 20 69 6e 61 6d 65 2f 64 6f 77 6e 63 61 73 e" iname/downcas
33c0: 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 64 65 e)))..(define de
33d0: 73 74 72 6f 79 21 0a 20 20 28 6c 65 74 72 65 63 stroy!. (letrec
33e0: 20 28 5b 72 65 67 69 73 74 72 79 2d 64 65 73 74 ([registry-dest
33f0: 72 6f 79 2f 72 65 63 75 72 73 69 76 65 21 0a 20 roy/recursive!.
3400: 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 (lamb
3410: 64 61 20 28 68 61 6e 64 6c 65 29 0a 20 20 20 20 da (handle).
3420: 20 20 20 20 20 20 20 20 20 20 28 72 65 67 69 73 (regis
3430: 74 72 79 2d 64 65 73 74 72 6f 79 21 20 68 61 6e try-destroy! han
3440: 64 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 dle).
3450: 20 20 20 28 64 6f 2d 65 63 20 28 3a 63 68 69 6c (do-ec (:chil
3460: 64 72 65 6e 20 63 68 69 6c 64 20 68 61 6e 64 6c dren child handl
3470: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
3480: 20 20 20 28 72 65 67 69 73 74 72 79 2d 64 65 73 (registry-des
3490: 74 72 6f 79 2f 72 65 63 75 72 73 69 76 65 21 20 troy/recursive!
34a0: 63 68 69 6c 64 29 29 29 5d 0a 20 20 20 20 20 20 child)))].
34b0: 20 20 20 20 20 5b 68 61 6e 64 6c 65 2d 64 65 73 [handle-des
34c0: 74 72 6f 79 21 0a 20 20 20 20 20 20 20 20 20 20 troy!.
34d0: 20 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 (foreign-lambd
34e0: 61 20 76 6f 69 64 20 22 49 75 70 44 65 73 74 72 a void "IupDestr
34f0: 6f 79 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e oy" nonnull-ihan
3500: 64 6c 65 29 5d 29 0a 20 20 20 20 28 6c 61 6d 62 dle)]). (lamb
3510: 64 61 20 28 68 61 6e 64 6c 65 29 0a 20 20 20 20 da (handle).
3520: 20 20 28 72 65 67 69 73 74 72 79 2d 64 65 73 74 (registry-dest
3530: 72 6f 79 2f 72 65 63 75 72 73 69 76 65 21 20 68 roy/recursive! h
3540: 61 6e 64 6c 65 29 0a 20 20 20 20 20 20 28 68 61 andle). (ha
3550: 6e 64 6c 65 2d 64 65 73 74 72 6f 79 21 20 68 61 ndle-destroy! ha
3560: 6e 64 6c 65 29 29 29 29 0a 0a 28 64 65 66 69 6e ndle))))..(defin
3570: 65 20 6d 61 70 2d 70 65 65 72 21 0a 09 28 6c 65 e map-peer!..(le
3580: 74 72 65 63 20 28 5b 6d 61 70 2d 70 65 65 72 2f trec ([map-peer/
3590: 72 61 77 21 20 28 66 6f 72 65 69 67 6e 2d 73 61 raw! (foreign-sa
35a0: 66 65 2d 6c 61 6d 62 64 61 20 69 73 74 61 74 75 fe-lambda istatu
35b0: 73 20 22 49 75 70 4d 61 70 22 20 6e 6f 6e 6e 75 s "IupMap" nonnu
35c0: 6c 6c 2d 69 68 61 6e 64 6c 65 29 5d 29 0a 09 09 ll-ihandle)])...
35d0: 28 6c 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 29 (lambda (handle)
35e0: 0a 09 09 09 28 6c 65 74 20 28 5b 73 74 61 74 75 ....(let ([statu
35f0: 73 20 28 6d 61 70 2d 70 65 65 72 2f 72 61 77 21 s (map-peer/raw!
3600: 20 68 61 6e 64 6c 65 29 5d 29 0a 09 09 09 09 28 handle)]).....(
3610: 63 61 73 65 20 73 74 61 74 75 73 0a 09 09 09 09 case status.....
3620: 09 5b 28 23 74 29 20 28 76 6f 69 64 29 5d 0a 09 .[(#t) (void)]..
3630: 09 09 09 09 5b 65 6c 73 65 20 28 65 72 72 6f 72 ....[else (error
3640: 20 27 6d 61 70 2d 70 65 65 72 21 20 28 66 6f 72 'map-peer! (for
3650: 6d 61 74 20 22 66 61 69 6c 65 64 20 74 6f 20 6d mat "failed to m
3660: 61 70 20 70 65 65 72 20 28 7e 73 29 22 20 73 74 ap peer (~s)" st
3670: 61 74 75 73 29 20 68 61 6e 64 6c 65 29 5d 29 29 atus) handle)]))
3680: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 75 6e 6d )))..(define unm
3690: 61 70 2d 70 65 65 72 21 0a 09 28 66 6f 72 65 69 ap-peer!..(forei
36a0: 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 76 gn-safe-lambda v
36b0: 6f 69 64 20 22 49 75 70 55 6e 6d 61 70 22 20 6e oid "IupUnmap" n
36c0: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 29 onnull-ihandle))
36d0: 0a 0a 28 64 65 66 69 6e 65 20 63 6c 61 73 73 2d ..(define class-
36e0: 6e 61 6d 65 0a 09 28 66 6f 72 65 69 67 6e 2d 6c name..(foreign-l
36f0: 61 6d 62 64 61 20 69 6e 61 6d 65 2f 64 6f 77 6e ambda iname/down
3700: 63 61 73 65 20 22 49 75 70 47 65 74 43 6c 61 73 case "IupGetClas
3710: 73 4e 61 6d 65 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 sName" nonnull-i
3720: 68 61 6e 64 6c 65 29 29 0a 0a 28 64 65 66 69 6e handle))..(defin
3730: 65 20 63 6c 61 73 73 2d 74 79 70 65 0a 09 28 66 e class-type..(f
3740: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 6e oreign-lambda in
3750: 61 6d 65 2f 64 6f 77 6e 63 61 73 65 20 22 49 75 ame/downcase "Iu
3760: 70 47 65 74 43 6c 61 73 73 54 79 70 65 22 20 6e pGetClassType" n
3770: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 29 onnull-ihandle))
3780: 0a 0a 28 64 65 66 69 6e 65 20 73 61 76 65 2d 61 ..(define save-a
3790: 74 74 72 69 62 75 74 65 73 21 0a 09 28 66 6f 72 ttributes!..(for
37a0: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 eign-lambda void
37b0: 20 22 49 75 70 53 61 76 65 43 6c 61 73 73 41 74 "IupSaveClassAt
37c0: 74 72 69 62 75 74 65 73 22 20 6e 6f 6e 6e 75 6c tributes" nonnul
37d0: 6c 2d 69 68 61 6e 64 6c 65 29 29 0a 0a 28 64 65 l-ihandle))..(de
37e0: 66 69 6e 65 20 70 61 72 65 6e 74 0a 09 28 66 6f fine parent..(fo
37f0: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 61 reign-lambda iha
3800: 6e 64 6c 65 20 22 49 75 70 47 65 74 50 61 72 65 ndle "IupGetPare
3810: 6e 74 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e nt" nonnull-ihan
3820: 64 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 70 dle))..(define p
3830: 61 72 65 6e 74 2d 64 69 61 6c 6f 67 0a 09 28 66 arent-dialog..(f
3840: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 oreign-lambda ih
3850: 61 6e 64 6c 65 20 22 49 75 70 47 65 74 44 69 61 andle "IupGetDia
3860: 6c 6f 67 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 log" nonnull-iha
3870: 6e 64 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 ndle))..(define
3880: 73 69 62 6c 69 6e 67 0a 09 28 66 6f 72 65 69 67 sibling..(foreig
3890: 6e 2d 6c 61 6d 62 64 61 20 69 68 61 6e 64 6c 65 n-lambda ihandle
38a0: 20 22 49 75 70 47 65 74 42 72 6f 74 68 65 72 22 "IupGetBrother"
38b0: 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 nonnull-ihandle
38c0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 69 6c ))..(define chil
38d0: 64 2d 61 64 64 21 0a 20 20 28 6c 65 74 72 65 63 d-add!. (letrec
38e0: 20 28 5b 61 70 70 65 6e 64 21 20 28 66 6f 72 65 ([append! (fore
38f0: 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 ign-safe-lambda
3900: 69 68 61 6e 64 6c 65 20 22 49 75 70 41 70 70 65 ihandle "IupAppe
3910: 6e 64 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e nd" nonnull-ihan
3920: 64 6c 65 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e dle nonnull-ihan
3930: 64 6c 65 29 5d 0a 20 20 20 20 20 20 20 20 20 20 dle)].
3940: 20 5b 69 6e 73 65 72 74 21 20 28 66 6f 72 65 69 [insert! (forei
3950: 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 69 gn-safe-lambda i
3960: 68 61 6e 64 6c 65 20 22 49 75 70 49 6e 73 65 72 handle "IupInser
3970: 74 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 t" nonnull-ihand
3980: 6c 65 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 le nonnull-ihand
3990: 6c 65 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 le nonnull-ihand
39a0: 6c 65 29 5d 29 0a 20 20 20 20 28 6c 61 6d 62 64 le)]). (lambd
39b0: 61 20 28 63 68 69 6c 64 20 63 6f 6e 74 61 69 6e a (child contain
39c0: 65 72 20 23 21 6f 70 74 69 6f 6e 61 6c 20 5b 61 er #!optional [a
39d0: 6e 63 68 6f 72 20 23 66 5d 29 0a 20 20 20 20 20 nchor #f]).
39e0: 20 28 6f 72 20 28 69 66 20 61 6e 63 68 6f 72 0a (or (if anchor.
39f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
3a00: 6e 73 65 72 74 21 20 63 6f 6e 74 61 69 6e 65 72 nsert! container
3a10: 20 61 6e 63 68 6f 72 20 63 68 69 6c 64 29 0a 20 anchor child).
3a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
3a30: 70 65 6e 64 21 20 63 6f 6e 74 61 69 6e 65 72 20 pend! container
3a40: 63 68 69 6c 64 29 29 0a 09 09 09 09 09 28 65 72 child))......(er
3a50: 72 6f 72 20 27 63 68 69 6c 64 2d 61 64 64 21 20 ror 'child-add!
3a60: 22 66 61 69 6c 65 64 20 74 6f 20 61 64 64 20 63 "failed to add c
3a70: 68 69 6c 64 22 20 63 68 69 6c 64 20 63 6f 6e 74 hild" child cont
3a80: 61 69 6e 65 72 20 61 6e 63 68 6f 72 29 29 29 29 ainer anchor))))
3a90: 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 69 6c 64 )..(define child
3aa0: 2d 72 65 6d 6f 76 65 21 0a 09 28 66 6f 72 65 69 -remove!..(forei
3ab0: 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 76 gn-safe-lambda v
3ac0: 6f 69 64 20 22 49 75 70 44 65 74 61 63 68 22 20 oid "IupDetach"
3ad0: 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 29 nonnull-ihandle)
3ae0: 29 0a 0a 28 64 65 66 69 6e 65 20 63 68 69 6c 64 )..(define child
3af0: 2d 6d 6f 76 65 21 0a 09 28 6c 65 74 72 65 63 20 -move!..(letrec
3b00: 28 5b 6d 6f 76 65 21 20 28 66 6f 72 65 69 67 6e ([move! (foreign
3b10: 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 69 73 74 -safe-lambda ist
3b20: 61 74 75 73 20 22 49 75 70 52 65 70 61 72 65 6e atus "IupReparen
3b30: 74 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 t" nonnull-ihand
3b40: 6c 65 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 le nonnull-ihand
3b50: 6c 65 20 69 68 61 6e 64 6c 65 29 5d 29 0a 09 09 le ihandle)])...
3b60: 28 6c 61 6d 62 64 61 20 28 63 68 69 6c 64 20 70 (lambda (child p
3b70: 61 72 65 6e 74 20 23 21 6f 70 74 69 6f 6e 61 6c arent #!optional
3b80: 20 72 65 66 2d 63 68 69 6c 64 29 0a 09 09 09 28 ref-child)....(
3b90: 6c 65 74 20 28 5b 73 74 61 74 75 73 20 28 6d 6f let ([status (mo
3ba0: 76 65 21 20 63 68 69 6c 64 20 70 61 72 65 6e 74 ve! child parent
3bb0: 20 72 65 66 2d 63 68 69 6c 64 29 5d 29 0a 09 09 ref-child)])...
3bc0: 09 09 28 63 61 73 65 20 73 74 61 74 75 73 0a 09 ..(case status..
3bd0: 09 09 09 09 5b 28 23 74 29 20 28 76 6f 69 64 29 ....[(#t) (void)
3be0: 5d 0a 09 09 09 09 09 5b 65 6c 73 65 20 28 65 72 ]......[else (er
3bf0: 72 6f 72 20 27 63 68 69 6c 64 2d 6d 6f 76 65 21 ror 'child-move!
3c00: 20 28 66 6f 72 6d 61 74 20 22 66 61 69 6c 65 64 (format "failed
3c10: 20 74 6f 20 6d 6f 76 65 20 63 68 69 6c 64 20 28 to move child (
3c20: 7e 73 29 22 20 73 74 61 74 75 73 29 20 63 68 69 ~s)" status) chi
3c30: 6c 64 20 70 61 72 65 6e 74 29 5d 29 29 29 29 29 ld parent)])))))
3c40: 0a 0a 28 64 65 66 69 6e 65 20 63 68 69 6c 64 2d ..(define child-
3c50: 72 65 66 0a 20 20 28 6c 65 74 72 65 63 20 28 5b ref. (letrec ([
3c60: 72 65 66 2f 70 6f 73 69 74 69 6f 6e 20 28 66 6f ref/position (fo
3c70: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 61 reign-lambda iha
3c80: 6e 64 6c 65 20 22 49 75 70 47 65 74 43 68 69 6c ndle "IupGetChil
3c90: 64 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 d" nonnull-ihand
3ca0: 6c 65 20 69 6e 74 29 5d 0a 20 20 20 20 20 20 20 le int)].
3cb0: 20 20 20 20 5b 72 65 66 2f 6e 61 6d 65 20 28 66 [ref/name (f
3cc0: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 68 oreign-lambda ih
3cd0: 61 6e 64 6c 65 20 22 49 75 70 47 65 74 44 69 61 andle "IupGetDia
3ce0: 6c 6f 67 43 68 69 6c 64 22 20 6e 6f 6e 6e 75 6c logChild" nonnul
3cf0: 6c 2d 69 68 61 6e 64 6c 65 20 69 6e 61 6d 65 2f l-ihandle iname/
3d00: 75 70 63 61 73 65 29 5d 29 0a 20 20 20 20 28 6c upcase)]). (l
3d10: 61 6d 62 64 61 20 28 63 6f 6e 74 61 69 6e 65 72 ambda (container
3d20: 20 69 64 29 0a 20 20 20 20 20 20 28 28 69 66 20 id). ((if
3d30: 28 69 6e 74 65 67 65 72 3f 20 69 64 29 20 72 65 (integer? id) re
3d40: 66 2f 70 6f 73 69 74 69 6f 6e 20 72 65 66 2f 6e f/position ref/n
3d50: 61 6d 65 29 20 63 6f 6e 74 61 69 6e 65 72 20 69 ame) container i
3d60: 64 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 d))))..(define c
3d70: 68 69 6c 64 2d 70 6f 73 0a 09 28 6c 65 74 72 65 hild-pos..(letre
3d80: 63 20 28 5b 70 6f 73 2f 72 61 77 20 28 66 6f 72 c ([pos/raw (for
3d90: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 6e 74 20 eign-lambda int
3da0: 22 49 75 70 47 65 74 43 68 69 6c 64 50 6f 73 22 "IupGetChildPos"
3db0: 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 nonnull-ihandle
3dc0: 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 nonnull-ihandle
3dd0: 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 70 )])...(lambda (p
3de0: 61 72 65 6e 74 20 63 68 69 6c 64 29 0a 09 09 09 arent child)....
3df0: 28 6c 65 74 20 28 5b 70 6f 73 20 28 70 6f 73 2f (let ([pos (pos/
3e00: 72 61 77 20 70 61 72 65 6e 74 20 63 68 69 6c 64 raw parent child
3e10: 29 5d 29 0a 09 09 09 09 28 61 6e 64 20 28 6e 6f )]).....(and (no
3e20: 74 20 28 6e 65 67 61 74 69 76 65 3f 20 70 6f 73 t (negative? pos
3e30: 29 29 20 70 6f 73 29 29 29 29 29 0a 0a 28 64 65 )) pos)))))..(de
3e40: 66 69 6e 65 20 63 68 69 6c 64 2d 63 6f 75 6e 74 fine child-count
3e50: 0a 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 ..(foreign-lambd
3e60: 61 20 69 6e 74 20 22 49 75 70 47 65 74 43 68 69 a int "IupGetChi
3e70: 6c 64 43 6f 75 6e 74 22 20 6e 6f 6e 6e 75 6c 6c ldCount" nonnull
3e80: 2d 69 68 61 6e 64 6c 65 29 29 0a 0a 28 64 65 66 -ihandle))..(def
3e90: 69 6e 65 20 28 63 68 69 6c 64 72 65 6e 20 68 61 ine (children ha
3ea0: 6e 64 6c 65 29 0a 09 28 6c 69 73 74 2d 65 63 20 ndle)..(list-ec
3eb0: 28 3a 63 68 69 6c 64 72 65 6e 20 63 68 69 6c 64 (:children child
3ec0: 20 68 61 6e 64 6c 65 29 20 63 68 69 6c 64 29 29 handle) child))
3ed0: 0a 0a 28 64 65 66 69 6e 65 20 72 65 66 72 65 73 ..(define refres
3ee0: 68 0a 09 28 66 6f 72 65 69 67 6e 2d 73 61 66 65 h..(foreign-safe
3ef0: 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 49 75 -lambda void "Iu
3f00: 70 52 65 66 72 65 73 68 22 20 6e 6f 6e 6e 75 6c pRefresh" nonnul
3f10: 6c 2d 69 68 61 6e 64 6c 65 29 29 0a 0a 28 64 65 l-ihandle))..(de
3f20: 66 69 6e 65 20 72 65 64 72 61 77 0a 09 28 6c 65 fine redraw..(le
3f30: 74 72 65 63 20 28 5b 75 70 64 61 74 65 0a 09 20 trec ([update..
3f40: 20 20 20 20 20 20 20 20 20 28 66 6f 72 65 69 67 (foreig
3f50: 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 2a 20 76 n-safe-lambda* v
3f60: 6f 69 64 20 28 5b 6e 6f 6e 6e 75 6c 6c 2d 69 68 oid ([nonnull-ih
3f70: 61 6e 64 6c 65 20 68 61 6e 64 6c 65 5d 20 5b 62 andle handle] [b
3f80: 6f 6f 6c 20 63 68 69 6c 64 72 65 6e 5d 29 0a 09 ool children])..
3f90: 20 20 20 20 20 20 20 20 20 20 09 22 49 75 70 55 ."IupU
3fa0: 70 64 61 74 65 28 68 61 6e 64 6c 65 29 3b 20 69 pdate(handle); i
3fb0: 66 20 28 63 68 69 6c 64 72 65 6e 29 20 49 75 70 f (children) Iup
3fc0: 55 70 64 61 74 65 43 68 69 6c 64 72 65 6e 28 68 UpdateChildren(h
3fd0: 61 6e 64 6c 65 29 3b 22 29 5d 0a 09 20 20 20 20 andle);")]..
3fe0: 20 20 20 20 20 5b 75 70 64 61 74 65 2f 73 79 6e [update/syn
3ff0: 63 0a 09 20 20 20 20 20 20 20 20 20 20 28 66 6f c.. (fo
4000: 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 reign-safe-lambd
4010: 61 20 76 6f 69 64 20 22 49 75 70 52 65 64 72 61 a void "IupRedra
4020: 77 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 w" nonnull-ihand
4030: 6c 65 20 62 6f 6f 6c 29 5d 29 0a 09 20 20 28 6c le bool)]).. (l
4040: 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 20 23 21 ambda (handle #!
4050: 6b 65 79 20 5b 63 68 69 6c 64 72 65 6e 3f 20 23 key [children? #
4060: 66 5d 20 5b 73 79 6e 63 3f 20 23 66 5d 29 0a 09 f] [sync? #f])..
4070: 20 20 09 28 28 69 66 20 73 79 6e 63 3f 20 75 70 .((if sync? up
4080: 64 61 74 65 2f 73 79 6e 63 20 75 70 64 61 74 65 date/sync update
4090: 29 20 68 61 6e 64 6c 65 20 63 68 69 6c 64 72 65 ) handle childre
40a0: 6e 3f 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 n?))))..(define
40b0: 63 68 69 6c 64 2d 78 2f 79 2d 3e 70 6f 73 0a 09 child-x/y->pos..
40c0: 28 6c 65 74 72 65 63 20 28 5b 78 2f 79 2d 3e 70 (letrec ([x/y->p
40d0: 6f 73 2f 72 61 77 20 28 66 6f 72 65 69 67 6e 2d os/raw (foreign-
40e0: 6c 61 6d 62 64 61 20 69 6e 74 20 22 49 75 70 43 lambda int "IupC
40f0: 6f 6e 76 65 72 74 58 59 54 6f 50 6f 73 22 20 6e onvertXYToPos" n
4100: 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 69 onnull-ihandle i
4110: 6e 74 20 69 6e 74 29 5d 29 0a 09 09 28 6c 61 6d nt int)])...(lam
4120: 62 64 61 20 28 70 61 72 65 6e 74 20 78 20 79 29 bda (parent x y)
4130: 0a 09 09 09 28 6c 65 74 20 28 5b 70 6f 73 20 28 ....(let ([pos (
4140: 78 2f 79 2d 3e 70 6f 73 2f 72 61 77 20 70 61 72 x/y->pos/raw par
4150: 65 6e 74 20 78 20 79 29 5d 29 0a 09 09 09 09 28 ent x y)]).....(
4160: 61 6e 64 20 28 6e 6f 74 20 28 6e 65 67 61 74 69 and (not (negati
4170: 76 65 3f 20 70 6f 73 29 29 20 70 6f 73 29 29 29 ve? pos)) pos)))
4180: 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b ))..;; }}}..;; {
4190: 7b 7b 20 44 69 61 6c 6f 67 20 66 75 6e 63 74 69 {{ Dialog functi
41a0: 6f 6e 73 0a 0a 28 64 65 66 69 6e 65 20 73 68 6f ons..(define sho
41b0: 77 0a 20 20 28 6c 65 74 72 65 63 20 28 5b 70 6f w. (letrec ([po
41c0: 73 69 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 20 sition.
41d0: 20 20 20 28 6c 61 6d 62 64 61 20 28 76 29 0a 20 (lambda (v).
41e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
41f0: 73 65 20 76 0a 20 20 20 20 20 20 20 20 20 20 20 se v.
4200: 20 20 20 20 20 5b 28 63 65 6e 74 65 72 29 20 20 [(center)
4210: 20 20 20 20 20 20 20 20 20 23 78 66 66 66 66 5d #xffff]
4220: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4230: 20 5b 28 73 74 61 72 74 20 74 6f 70 20 6c 65 66 [(start top lef
4240: 74 29 20 20 20 23 78 66 66 66 65 5d 0a 20 20 20 t) #xfffe].
4250: 20 20 20 20 20 20 20 20 20 20 20 20 20 5b 28 65 [(e
4260: 6e 64 20 62 6f 74 74 6f 6d 20 72 69 67 68 74 29 nd bottom right)
4270: 20 23 78 66 66 66 64 5d 0a 20 20 20 20 20 20 20 #xfffd].
4280: 20 20 20 20 20 20 20 20 20 5b 28 6d 6f 75 73 65 [(mouse
4290: 29 20 20 20 20 20 20 20 20 20 20 20 20 23 78 66 ) #xf
42a0: 66 66 63 5d 0a 20 20 20 20 20 20 20 20 20 20 20 ffc].
42b0: 20 20 20 20 20 5b 28 70 61 72 65 6e 74 2d 63 65 [(parent-ce
42c0: 6e 74 65 72 29 20 20 20 20 23 78 66 66 66 61 5d nter) #xfffa]
42d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
42e0: 20 5b 28 63 75 72 72 65 6e 74 29 20 20 20 20 20 [(current)
42f0: 20 20 20 20 20 23 78 66 66 66 62 5d 0a 20 20 20 #xfffb].
4300: 20 20 20 20 20 20 20 20 20 20 20 20 20 5b 65 6c [el
4310: 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 se
4320: 20 76 5d 29 29 5d 0a 20 20 20 20 20 20 20 20 20 v]))].
4330: 20 20 5b 70 6f 70 75 70 20 28 66 6f 72 65 69 67 [popup (foreig
4340: 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 69 73 n-safe-lambda is
4350: 74 61 74 75 73 20 22 49 75 70 50 6f 70 75 70 22 tatus "IupPopup"
4360: 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 nonnull-ihandle
4370: 20 69 6e 74 20 69 6e 74 29 5d 0a 20 20 20 20 20 int int)].
4380: 20 20 20 20 20 20 5b 73 68 6f 77 2f 78 2f 79 20 [show/x/y
4390: 28 66 6f 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 (foreign-safe-la
43a0: 6d 62 64 61 20 69 73 74 61 74 75 73 20 22 49 75 mbda istatus "Iu
43b0: 70 53 68 6f 77 58 59 22 20 6e 6f 6e 6e 75 6c 6c pShowXY" nonnull
43c0: 2d 69 68 61 6e 64 6c 65 20 69 6e 74 20 69 6e 74 -ihandle int int
43d0: 29 5d 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 )]). (lambda
43e0: 28 68 61 6e 64 6c 65 20 23 21 6b 65 79 20 5b 78 (handle #!key [x
43f0: 20 27 63 75 72 72 65 6e 74 5d 20 5b 79 20 27 63 'current] [y 'c
4400: 75 72 72 65 6e 74 5d 20 5b 6d 6f 64 61 6c 3f 20 urrent] [modal?
4410: 23 66 5d 29 0a 20 20 20 20 20 20 28 6c 65 74 20 #f]). (let
4420: 28 5b 73 74 61 74 75 73 20 28 28 69 66 20 6d 6f ([status ((if mo
4430: 64 61 6c 3f 20 70 6f 70 75 70 20 73 68 6f 77 2f dal? popup show/
4440: 78 2f 79 29 20 68 61 6e 64 6c 65 20 28 70 6f 73 x/y) handle (pos
4450: 69 74 69 6f 6e 20 78 29 20 28 70 6f 73 69 74 69 ition x) (positi
4460: 6f 6e 20 79 29 29 5d 29 0a 20 20 20 20 20 20 20 on y))]).
4470: 20 28 63 61 73 65 20 73 74 61 74 75 73 0a 20 20 (case status.
4480: 20 20 20 20 20 20 20 20 5b 28 65 72 72 6f 72 29 [(error)
4490: 20 28 65 72 72 6f 72 20 27 73 68 6f 77 20 22 66 (error 'show "f
44a0: 61 69 6c 65 64 20 74 6f 20 73 68 6f 77 22 20 68 ailed to show" h
44b0: 61 6e 64 6c 65 29 5d 0a 20 20 20 20 20 20 20 20 andle)].
44c0: 20 20 5b 65 6c 73 65 20 20 20 20 73 74 61 74 75 [else statu
44d0: 73 5d 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 s])))))..(define
44e0: 20 68 69 64 65 0a 09 28 6c 65 74 72 65 63 20 28 hide..(letrec (
44f0: 5b 68 69 64 65 2f 72 61 77 20 28 66 6f 72 65 69 [hide/raw (forei
4500: 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 69 gn-safe-lambda i
4510: 73 74 61 74 75 73 20 22 49 75 70 48 69 64 65 22 status "IupHide"
4520: 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 nonnull-ihandle
4530: 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 28 68 )])...(lambda (h
4540: 61 6e 64 6c 65 29 0a 09 09 09 28 6c 65 74 20 28 andle)....(let (
4550: 5b 73 74 61 74 75 73 20 28 68 69 64 65 2f 72 61 [status (hide/ra
4560: 77 20 68 61 6e 64 6c 65 29 5d 29 0a 09 09 09 09 w handle)]).....
4570: 28 63 61 73 65 20 73 74 61 74 75 73 0a 09 09 09 (case status....
4580: 09 09 5b 28 23 74 29 20 28 76 6f 69 64 29 5d 0a ..[(#t) (void)].
4590: 09 09 09 09 09 5b 65 6c 73 65 20 28 65 72 72 6f .....[else (erro
45a0: 72 20 27 68 69 64 65 20 28 66 6f 72 6d 61 74 20 r 'hide (format
45b0: 22 66 61 69 6c 65 64 20 74 6f 20 68 69 64 65 20 "failed to hide
45c0: 28 7e 73 29 22 20 73 74 61 74 75 73 29 20 68 61 (~s)" status) ha
45d0: 6e 64 6c 65 29 5d 29 29 29 29 29 0a 0a 3b 3b 20 ndle)])))))..;;
45e0: 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 43 6f 6d 70 }}}..;; {{{ Comp
45f0: 6f 73 69 74 69 6f 6e 20 66 75 6e 63 74 69 6f 6e osition function
4600: 73 0a 0a 28 64 65 66 69 6e 65 20 64 69 61 6c 6f s..(define dialo
4610: 67 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 g. (make-constr
4620: 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a uctor-procedure.
4630: 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 .(foreign-lamb
4640: 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 da nonnull-ihand
4650: 6c 65 20 22 49 75 70 44 69 61 6c 6f 67 22 20 69 le "IupDialog" i
4660: 68 61 6e 64 6c 65 29 29 29 0a 0a 28 64 65 66 69 handle)))..(defi
4670: 6e 65 20 66 69 6c 6c 0a 20 20 28 6d 61 6b 65 2d ne fill. (make-
4680: 63 6f 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 constructor-proc
4690: 65 64 75 72 65 0a 20 20 09 28 66 6f 72 65 69 67 edure. .(foreig
46a0: 6e 2d 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c n-lambda nonnull
46b0: 2d 69 68 61 6e 64 6c 65 20 22 49 75 70 46 69 6c -ihandle "IupFil
46c0: 6c 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 l")))..(define h
46d0: 62 6f 78 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 box. (make-cons
46e0: 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 tructor-procedur
46f0: 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 e. .(foreign-la
4700: 6d 62 64 61 2a 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 mbda* nonnull-ih
4710: 61 6e 64 6c 65 20 28 5b 69 68 61 6e 64 6c 65 2d andle ([ihandle-
4720: 6c 69 73 74 20 68 61 6e 64 6c 65 73 5d 29 20 22 list handles]) "
4730: 43 5f 72 65 74 75 72 6e 28 49 75 70 48 62 6f 78 C_return(IupHbox
4740: 76 28 28 49 68 61 6e 64 6c 65 20 2a 2a 29 68 61 v((Ihandle **)ha
4750: 6e 64 6c 65 73 29 29 3b 22 29 0a 20 20 09 23 3a ndles));"). .#:
4760: 61 70 70 6c 79 2d 61 72 67 73 20 6c 69 73 74 29 apply-args list)
4770: 29 0a 0a 28 64 65 66 69 6e 65 20 76 62 6f 78 0a )..(define vbox.
4780: 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 75 63 (make-construc
4790: 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a 20 20 tor-procedure.
47a0: 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 .(foreign-lambda
47b0: 2a 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c * nonnull-ihandl
47c0: 65 20 28 5b 69 68 61 6e 64 6c 65 2d 6c 69 73 74 e ([ihandle-list
47d0: 20 68 61 6e 64 6c 65 73 5d 29 20 22 43 5f 72 65 handles]) "C_re
47e0: 74 75 72 6e 28 49 75 70 56 62 6f 78 76 28 28 49 turn(IupVboxv((I
47f0: 68 61 6e 64 6c 65 20 2a 2a 29 68 61 6e 64 6c 65 handle **)handle
4800: 73 29 29 3b 22 29 0a 20 20 09 23 3a 61 70 70 6c s));"). .#:appl
4810: 79 2d 61 72 67 73 20 6c 69 73 74 29 29 0a 0a 28 y-args list))..(
4820: 64 65 66 69 6e 65 20 7a 62 6f 78 0a 20 20 28 6d define zbox. (m
4830: 61 6b 65 2d 63 6f 6e 73 74 72 75 63 74 6f 72 2d ake-constructor-
4840: 70 72 6f 63 65 64 75 72 65 0a 20 20 09 28 66 6f procedure. .(fo
4850: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 2a 20 6e 6f reign-lambda* no
4860: 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 28 5b nnull-ihandle ([
4870: 69 68 61 6e 64 6c 65 2d 6c 69 73 74 20 68 61 6e ihandle-list han
4880: 64 6c 65 73 5d 29 20 22 43 5f 72 65 74 75 72 6e dles]) "C_return
4890: 28 49 75 70 5a 62 6f 78 76 28 28 49 68 61 6e 64 (IupZboxv((Ihand
48a0: 6c 65 20 2a 2a 29 68 61 6e 64 6c 65 73 29 29 3b le **)handles));
48b0: 22 29 0a 20 20 09 23 3a 61 70 70 6c 79 2d 61 72 "). .#:apply-ar
48c0: 67 73 20 6c 69 73 74 29 29 0a 0a 28 64 65 66 69 gs list))..(defi
48d0: 6e 65 20 63 62 6f 78 0a 20 20 28 6d 61 6b 65 2d ne cbox. (make-
48e0: 63 6f 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 constructor-proc
48f0: 65 64 75 72 65 0a 20 20 09 28 66 6f 72 65 69 67 edure. .(foreig
4900: 6e 2d 6c 61 6d 62 64 61 2a 20 6e 6f 6e 6e 75 6c n-lambda* nonnul
4910: 6c 2d 69 68 61 6e 64 6c 65 20 28 5b 69 68 61 6e l-ihandle ([ihan
4920: 64 6c 65 2d 6c 69 73 74 20 68 61 6e 64 6c 65 73 dle-list handles
4930: 5d 29 20 22 43 5f 72 65 74 75 72 6e 28 49 75 70 ]) "C_return(Iup
4940: 43 62 6f 78 76 28 28 49 68 61 6e 64 6c 65 20 2a Cboxv((Ihandle *
4950: 2a 29 68 61 6e 64 6c 65 73 29 29 3b 22 29 0a 20 *)handles));").
4960: 20 09 23 3a 61 70 70 6c 79 2d 61 72 67 73 20 6c .#:apply-args l
4970: 69 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 73 ist))..(define s
4980: 62 6f 78 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 box. (make-cons
4990: 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 tructor-procedur
49a0: 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 e. .(foreign-la
49b0: 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 mbda nonnull-iha
49c0: 6e 64 6c 65 20 22 49 75 70 53 62 6f 78 22 20 69 ndle "IupSbox" i
49d0: 68 61 6e 64 6c 65 29 29 29 0a 0a 28 64 65 66 69 handle)))..(defi
49e0: 6e 65 20 72 61 64 69 6f 0a 20 20 28 6d 61 6b 65 ne radio. (make
49f0: 2d 63 6f 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f -constructor-pro
4a00: 63 65 64 75 72 65 0a 20 20 09 28 66 6f 72 65 69 cedure. .(forei
4a10: 67 6e 2d 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c gn-lambda nonnul
4a20: 6c 2d 69 68 61 6e 64 6c 65 20 22 49 75 70 52 61 l-ihandle "IupRa
4a30: 64 69 6f 22 20 69 68 61 6e 64 6c 65 29 29 29 0a dio" ihandle))).
4a40: 0a 28 64 65 66 69 6e 65 20 6e 6f 72 6d 61 6c 69 .(define normali
4a50: 7a 65 72 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 zer. (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 2a 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 mbda* nonnull-ih
4a90: 61 6e 64 6c 65 20 28 5b 69 68 61 6e 64 6c 65 2d andle ([ihandle-
4aa0: 6c 69 73 74 20 68 61 6e 64 6c 65 73 5d 29 20 22 list handles]) "
4ab0: 43 5f 72 65 74 75 72 6e 28 49 75 70 4e 6f 72 6d C_return(IupNorm
4ac0: 61 6c 69 7a 65 72 76 28 28 49 68 61 6e 64 6c 65 alizerv((Ihandle
4ad0: 20 2a 2a 29 68 61 6e 64 6c 65 73 29 29 3b 22 29 **)handles));")
4ae0: 0a 20 20 09 23 3a 61 70 70 6c 79 2d 61 72 67 73 . .#:apply-args
4af0: 20 6c 69 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 list))..(define
4b00: 20 73 70 6c 69 74 0a 20 20 28 6d 61 6b 65 2d 63 split. (make-c
4b10: 6f 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 onstructor-proce
4b20: 64 75 72 65 0a 20 20 09 28 66 6f 72 65 69 67 6e dure. .(foreign
4b30: 2d 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d -lambda nonnull-
4b40: 69 68 61 6e 64 6c 65 20 22 49 75 70 53 70 6c 69 ihandle "IupSpli
4b50: 74 22 20 69 68 61 6e 64 6c 65 20 69 68 61 6e 64 t" ihandle ihand
4b60: 6c 65 29 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b le)))..;; }}}..;
4b70: 3b 20 7b 7b 7b 20 49 6d 61 67 65 20 72 65 73 6f ; {{{ Image reso
4b80: 75 72 63 65 20 66 75 6e 63 74 69 6f 6e 73 0a 0a urce functions..
4b90: 28 64 65 66 69 6e 65 20 69 6d 61 67 65 2f 70 61 (define image/pa
4ba0: 6c 65 74 74 65 0a 20 20 28 6d 61 6b 65 2d 63 6f lette. (make-co
4bb0: 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 nstructor-proced
4bc0: 75 72 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d ure. .(foreign-
4bd0: 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 lambda nonnull-i
4be0: 68 61 6e 64 6c 65 20 22 49 75 70 49 6d 61 67 65 handle "IupImage
4bf0: 22 20 69 6e 74 20 69 6e 74 20 62 6c 6f 62 29 29 " int int blob))
4c00: 29 0a 0a 28 64 65 66 69 6e 65 20 69 6d 61 67 65 )..(define image
4c10: 2f 72 67 62 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e /rgb. (make-con
4c20: 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 structor-procedu
4c30: 72 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c re. .(foreign-l
4c40: 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 ambda nonnull-ih
4c50: 61 6e 64 6c 65 20 22 49 75 70 49 6d 61 67 65 52 andle "IupImageR
4c60: 47 42 22 20 69 6e 74 20 69 6e 74 20 62 6c 6f 62 GB" int int blob
4c70: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 69 6d 61 )))..(define ima
4c80: 67 65 2f 72 67 62 61 0a 20 20 28 6d 61 6b 65 2d ge/rgba. (make-
4c90: 63 6f 6e 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 constructor-proc
4ca0: 65 64 75 72 65 0a 20 20 09 28 66 6f 72 65 69 67 edure. .(foreig
4cb0: 6e 2d 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c n-lambda nonnull
4cc0: 2d 69 68 61 6e 64 6c 65 20 22 49 75 70 49 6d 61 -ihandle "IupIma
4cd0: 67 65 52 47 42 41 22 20 69 6e 74 20 69 6e 74 20 geRGBA" int int
4ce0: 62 6c 6f 62 29 29 29 0a 0a 28 64 65 66 69 6e 65 blob)))..(define
4cf0: 20 69 6d 61 67 65 2f 66 69 6c 65 0a 09 28 6c 65 image/file..(le
4d00: 74 72 65 63 20 28 5b 6c 6f 61 64 2d 69 6d 61 67 trec ([load-imag
4d10: 65 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 e (foreign-lambd
4d20: 61 20 69 68 61 6e 64 6c 65 20 22 49 75 70 4c 6f a ihandle "IupLo
4d30: 61 64 49 6d 61 67 65 22 20 63 2d 73 74 72 69 6e adImage" c-strin
4d40: 67 29 5d 29 0a 09 09 28 6d 61 6b 65 2d 63 6f 6e g)])...(make-con
4d50: 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 structor-procedu
4d60: 72 65 0a 09 09 09 28 6c 61 6d 62 64 61 20 28 66 re....(lambda (f
4d70: 69 6c 65 29 0a 09 09 09 09 28 6f 72 20 28 6c 6f ile).....(or (lo
4d80: 61 64 2d 69 6d 61 67 65 20 66 69 6c 65 29 20 28 ad-image file) (
4d90: 65 72 72 6f 72 20 27 69 6d 61 67 65 2f 66 69 6c error 'image/fil
4da0: 65 20 28 61 74 74 72 69 62 75 74 65 20 23 66 20 e (attribute #f
4db0: 27 69 75 70 69 6d 2d 6c 61 73 74 65 72 72 6f 72 'iupim-lasterror
4dc0: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
4dd0: 20 69 6d 61 67 65 2d 73 61 76 65 0a 09 28 6c 65 image-save..(le
4de0: 74 72 65 63 20 28 5b 73 61 76 65 2d 69 6d 61 67 trec ([save-imag
4df0: 65 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 e (foreign-lambd
4e00: 61 20 62 6f 6f 6c 20 22 49 75 70 53 61 76 65 49 a bool "IupSaveI
4e10: 6d 61 67 65 22 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 mage" nonnull-ih
4e20: 61 6e 64 6c 65 20 63 2d 73 74 72 69 6e 67 20 69 andle c-string i
4e30: 6e 61 6d 65 2f 75 70 63 61 73 65 29 5d 29 0a 09 name/upcase)])..
4e40: 09 28 6c 61 6d 62 64 61 20 28 68 61 6e 64 6c 65 .(lambda (handle
4e50: 20 66 69 6c 65 20 66 6f 72 6d 61 74 29 0a 09 09 file format)...
4e60: 09 28 75 6e 6c 65 73 73 20 28 73 61 76 65 2d 69 .(unless (save-i
4e70: 6d 61 67 65 20 68 61 6e 64 6c 65 20 66 69 6c 65 mage handle file
4e80: 20 66 6f 72 6d 61 74 29 0a 09 09 09 09 28 65 72 format).....(er
4e90: 72 6f 72 20 27 69 6d 61 67 65 2d 73 61 76 65 20 ror 'image-save
4ea0: 28 61 74 74 72 69 62 75 74 65 20 23 66 20 27 69 (attribute #f 'i
4eb0: 75 70 69 6d 2d 6c 61 73 74 65 72 72 6f 72 29 29 upim-lasterror))
4ec0: 29 29 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a 3b 3b ))))..;; }}}..;;
4ed0: 20 7b 7b 7b 20 46 6f 63 75 73 20 66 75 6e 63 74 {{{ Focus funct
4ee0: 69 6f 6e 73 0a 0a 28 64 65 66 69 6e 65 20 63 75 ions..(define cu
4ef0: 72 72 65 6e 74 2d 66 6f 63 75 73 0a 20 20 28 6c rrent-focus. (l
4f00: 65 74 72 65 63 20 28 5b 66 6f 63 75 73 20 28 66 etrec ([focus (f
4f10: 6f 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 oreign-safe-lamb
4f20: 64 61 20 69 68 61 6e 64 6c 65 20 22 49 75 70 47 da ihandle "IupG
4f30: 65 74 46 6f 63 75 73 22 29 5d 0a 20 20 20 20 20 etFocus")].
4f40: 20 20 20 20 20 20 5b 66 6f 63 75 73 2d 73 65 74 [focus-set
4f50: 21 20 28 66 6f 72 65 69 67 6e 2d 73 61 66 65 2d ! (foreign-safe-
4f60: 6c 61 6d 62 64 61 20 69 68 61 6e 64 6c 65 20 22 lambda ihandle "
4f70: 49 75 70 53 65 74 46 6f 63 75 73 22 20 69 68 61 IupSetFocus" iha
4f80: 6e 64 6c 65 29 5d 0a 20 20 20 20 20 20 20 20 20 ndle)].
4f90: 20 20 5b 63 75 72 72 65 6e 74 2d 66 6f 63 75 73 [current-focus
4fa0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 . (ca
4fb0: 73 65 2d 6c 61 6d 62 64 61 0a 20 20 20 20 20 20 se-lambda.
4fc0: 20 20 20 20 20 20 20 20 5b 28 29 20 20 20 20 20 [()
4fd0: 20 20 28 66 6f 63 75 73 29 5d 0a 20 20 20 20 20 (focus)].
4fe0: 20 20 20 20 20 20 20 20 20 5b 28 68 61 6e 64 6c [(handl
4ff0: 65 29 20 28 66 6f 63 75 73 2d 73 65 74 21 20 68 e) (focus-set! h
5000: 61 6e 64 6c 65 29 5d 29 5d 29 0a 20 20 20 20 28 andle)])]). (
5010: 67 65 74 74 65 72 2d 77 69 74 68 2d 73 65 74 74 getter-with-sett
5020: 65 72 20 63 75 72 72 65 6e 74 2d 66 6f 63 75 73 er current-focus
5030: 20 63 75 72 72 65 6e 74 2d 66 6f 63 75 73 29 29 current-focus))
5040: 29 0a 0a 28 64 65 66 69 6e 65 20 66 6f 63 75 73 )..(define focus
5050: 2d 6e 65 78 74 0a 09 28 6c 65 74 72 65 63 20 28 -next..(letrec (
5060: 5b 66 6f 63 75 73 2d 6e 65 78 74 2f 72 61 77 20 [focus-next/raw
5070: 28 66 6f 72 65 69 67 6e 2d 73 61 66 65 2d 6c 61 (foreign-safe-la
5080: 6d 62 64 61 20 69 68 61 6e 64 6c 65 20 22 49 75 mbda ihandle "Iu
5090: 70 4e 65 78 74 46 69 65 6c 64 22 20 69 68 61 6e pNextField" ihan
50a0: 64 6c 65 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 dle)])...(lambda
50b0: 20 28 23 21 6f 70 74 69 6f 6e 61 6c 20 5b 68 61 (#!optional [ha
50c0: 6e 64 6c 65 20 28 63 75 72 72 65 6e 74 2d 66 6f ndle (current-fo
50d0: 63 75 73 29 5d 29 0a 09 09 09 28 66 6f 63 75 73 cus)])....(focus
50e0: 2d 6e 65 78 74 2f 72 61 77 20 68 61 6e 64 6c 65 -next/raw handle
50f0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 66 6f ))))..(define fo
5100: 63 75 73 2d 70 72 65 76 69 6f 75 73 0a 09 28 6c cus-previous..(l
5110: 65 74 72 65 63 20 28 5b 66 6f 63 75 73 2d 70 72 etrec ([focus-pr
5120: 65 76 69 6f 75 73 2f 72 61 77 20 28 66 6f 72 65 evious/raw (fore
5130: 69 67 6e 2d 73 61 66 65 2d 6c 61 6d 62 64 61 20 ign-safe-lambda
5140: 69 68 61 6e 64 6c 65 20 22 49 75 70 50 72 65 76 ihandle "IupPrev
5150: 69 6f 75 73 46 69 65 6c 64 22 20 69 68 61 6e 64 iousField" ihand
5160: 6c 65 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 le)])...(lambda
5170: 28 23 21 6f 70 74 69 6f 6e 61 6c 20 5b 68 61 6e (#!optional [han
5180: 64 6c 65 20 28 63 75 72 72 65 6e 74 2d 66 6f 63 dle (current-foc
5190: 75 73 29 5d 29 0a 09 09 09 28 66 6f 63 75 73 2d us)])....(focus-
51a0: 70 72 65 76 69 6f 75 73 2f 72 61 77 20 68 61 6e previous/raw han
51b0: 64 6c 65 29 29 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a dle))))..;; }}}.
51c0: 0a 3b 3b 20 7b 7b 7b 20 4d 65 6e 75 20 66 75 6e .;; {{{ Menu fun
51d0: 63 74 69 6f 6e 73 0a 0a 28 64 65 66 69 6e 65 20 ctions..(define
51e0: 6d 65 6e 75 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e menu. (make-con
51f0: 73 74 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 structor-procedu
5200: 72 65 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c re. .(foreign-l
5210: 61 6d 62 64 61 2a 20 6e 6f 6e 6e 75 6c 6c 2d 69 ambda* nonnull-i
5220: 68 61 6e 64 6c 65 20 28 5b 69 68 61 6e 64 6c 65 handle ([ihandle
5230: 2d 6c 69 73 74 20 68 61 6e 64 6c 65 73 5d 29 20 -list handles])
5240: 22 43 5f 72 65 74 75 72 6e 28 49 75 70 4d 65 6e "C_return(IupMen
5250: 75 76 28 28 49 68 61 6e 64 6c 65 20 2a 2a 29 68 uv((Ihandle **)h
5260: 61 6e 64 6c 65 73 29 29 3b 22 29 0a 20 20 09 23 andles));"). .#
5270: 3a 61 70 70 6c 79 2d 61 72 67 73 20 6c 69 73 74 :apply-args list
5280: 29 29 0a 0a 28 64 65 66 69 6e 65 20 6d 65 6e 75 ))..(define menu
5290: 2d 69 74 65 6d 0a 20 20 28 6c 65 74 72 65 63 20 -item. (letrec
52a0: 28 5b 61 63 74 69 6f 6e 2d 69 74 65 6d 20 28 66 ([action-item (f
52b0: 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 6e 6f oreign-lambda no
52c0: 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 22 49 nnull-ihandle "I
52d0: 75 70 49 74 65 6d 22 20 63 2d 73 74 72 69 6e 67 upItem" c-string
52e0: 20 69 6e 61 6d 65 2f 75 70 63 61 73 65 29 5d 0a iname/upcase)].
52f0: 20 20 20 20 20 20 20 20 20 20 20 5b 73 75 62 6d [subm
5300: 65 6e 75 2d 69 74 65 6d 20 28 66 6f 72 65 69 67 enu-item (foreig
5310: 6e 2d 6c 61 6d 62 64 61 20 6e 6f 6e 6e 75 6c 6c n-lambda nonnull
5320: 2d 69 68 61 6e 64 6c 65 20 22 49 75 70 53 75 62 -ihandle "IupSub
5330: 6d 65 6e 75 22 20 63 2d 73 74 72 69 6e 67 20 69 menu" c-string i
5340: 68 61 6e 64 6c 65 29 5d 29 0a 20 20 20 20 28 6d handle)]). (m
5350: 61 6b 65 2d 63 6f 6e 73 74 72 75 63 74 6f 72 2d ake-constructor-
5360: 70 72 6f 63 65 64 75 72 65 0a 20 20 20 20 20 28 procedure. (
5370: 6c 61 6d 62 64 61 20 28 23 21 6f 70 74 69 6f 6e lambda (#!option
5380: 61 6c 20 5b 74 69 74 6c 65 20 23 66 5d 20 5b 61 al [title #f] [a
5390: 63 74 69 6f 6e 2f 6d 65 6e 75 20 23 66 5d 29 0a ction/menu #f]).
53a0: 20 20 20 20 20 20 20 28 28 69 66 20 28 69 68 61 ((if (iha
53b0: 6e 64 6c 65 3f 20 61 63 74 69 6f 6e 2f 6d 65 6e ndle? action/men
53c0: 75 29 20 73 75 62 6d 65 6e 75 2d 69 74 65 6d 20 u) submenu-item
53d0: 61 63 74 69 6f 6e 2d 69 74 65 6d 29 20 74 69 74 action-item) tit
53e0: 6c 65 20 61 63 74 69 6f 6e 2f 6d 65 6e 75 29 29 le action/menu))
53f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 6d 65 6e )))..(define men
5400: 75 2d 73 65 70 61 72 61 74 6f 72 0a 20 20 28 6d u-separator. (m
5410: 61 6b 65 2d 63 6f 6e 73 74 72 75 63 74 6f 72 2d ake-constructor-
5420: 70 72 6f 63 65 64 75 72 65 0a 20 20 09 28 66 6f procedure. .(fo
5430: 72 65 69 67 6e 2d 6c 61 6d 62 64 61 20 6e 6f 6e reign-lambda non
5440: 6e 75 6c 6c 2d 69 68 61 6e 64 6c 65 20 22 49 75 null-ihandle "Iu
5450: 70 53 65 70 61 72 61 74 6f 72 22 29 29 29 0a 0a pSeparator")))..
5460: 3b 3b 20 7d 7d 7d 0a 0a 3b 3b 20 7b 7b 7b 20 4d ;; }}}..;; {{{ M
5470: 69 73 63 65 6c 6c 61 6e 65 6f 75 73 20 72 65 73 iscellaneous res
5480: 6f 75 72 63 65 20 66 75 6e 63 74 69 6f 6e 73 0a ource functions.
5490: 0a 28 64 65 66 69 6e 65 20 63 6c 69 70 62 6f 61 .(define clipboa
54a0: 72 64 0a 09 28 6d 61 6b 65 2d 63 6f 6e 73 74 72 rd..(make-constr
54b0: 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 0a uctor-procedure.
54c0: 09 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d 62 64 ..(foreign-lambd
54d0: 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e 64 6c a nonnull-ihandl
54e0: 65 20 22 49 75 70 43 6c 69 70 62 6f 61 72 64 22 e "IupClipboard"
54f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 74 69 6d )))..(define tim
5500: 65 72 0a 20 20 28 6d 61 6b 65 2d 63 6f 6e 73 74 er. (make-const
5510: 72 75 63 74 6f 72 2d 70 72 6f 63 65 64 75 72 65 ructor-procedure
5520: 0a 20 20 09 28 66 6f 72 65 69 67 6e 2d 6c 61 6d . .(foreign-lam
5530: 62 64 61 20 6e 6f 6e 6e 75 6c 6c 2d 69 68 61 6e bda nonnull-ihan
5540: 64 6c 65 20 22 49 75 70 54 69 6d 65 72 22 29 29 dle "IupTimer"))
5550: 29 0a 0a 28 64 65 66 69 6e 65 20 73 65 6e 64 2d )..(define send-
5560: 75 72 6c 0a 09 28 6c 65 74 72 65 63 20 28 5b 73 url..(letrec ([s
5570: 65 6e 64 2d 75 72 6c 2f 72 61 77 20 28 66 6f 72 end-url/raw (for
5580: 65 69 67 6e 2d 6c 61 6d 62 64 61 20 69 6e 74 20 eign-lambda int
5590: 22 49 75 70 48 65 6c 70 22 20 63 2d 73 74 72 69 "IupHelp" c-stri
55a0: 6e 67 29 5d 29 0a 09 09 28 6c 61 6d 62 64 61 20 ng)])...(lambda
55b0: 28 75 72 6c 29 0a 09 09 09 28 61 6e 64 2d 6c 65 (url)....(and-le
55c0: 74 2a 20 28 5b 73 74 61 74 75 73 20 28 73 65 6e t* ([status (sen
55d0: 64 2d 75 72 6c 2f 72 61 77 20 75 72 6c 29 5d 0a d-url/raw url)].
55e0: 09 09 09 20 20 20 20 20 20 20 20 20 20 20 5b 28 ... [(
55f0: 6e 6f 74 20 28 3d 20 73 74 61 74 75 73 20 31 29 not (= status 1)
5600: 29 5d 29 0a 09 09 09 20 20 28 65 72 72 6f 72 20 )]).... (error
5610: 27 73 65 6e 64 2d 75 72 6c 20 28 66 6f 72 6d 61 'send-url (forma
5620: 74 20 22 66 61 69 6c 65 64 20 74 6f 20 6f 70 65 t "failed to ope
5630: 6e 20 55 52 4c 20 28 7e 73 29 22 20 73 74 61 74 n URL (~s)" stat
5640: 75 73 29 20 75 72 6c 29 29 0a 09 09 09 28 76 6f us) url))....(vo
5650: 69 64 29 29 29 29 0a 0a 3b 3b 20 7d 7d 7d 0a 0a id))))..;; }}}..
5660: 3b 3b 20 7b 7b 7b 20 54 68 65 20 6c 69 62 72 61 ;; {{{ The libra
5670: 72 79 20 77 61 74 63 68 64 6f 67 0a 0a 28 64 65 ry watchdog..(de
5680: 66 69 6e 65 20 74 68 72 65 61 64 2d 77 61 74 63 fine thread-watc
5690: 68 64 6f 67 0a 20 20 28 6c 65 74 72 65 63 20 28 hdog. (letrec (
56a0: 5b 6f 70 65 6e 20 28 66 6f 72 65 69 67 6e 2d 6c [open (foreign-l
56b0: 61 6d 62 64 61 2a 20 69 73 74 61 74 75 73 20 28 ambda* istatus (
56c0: 29 20 22 43 5f 72 65 74 75 72 6e 28 49 75 70 4f ) "C_return(IupO
56d0: 70 65 6e 28 4e 55 4c 4c 2c 20 4e 55 4c 4c 29 29 pen(NULL, NULL))
56e0: 3b 22 29 5d 0a 09 09 09 09 09 20 5b 73 65 74 6c ;")]...... [setl
56f0: 6f 63 61 6c 65 20 28 66 6f 72 65 69 67 6e 2d 6c ocale (foreign-l
5700: 61 6d 62 64 61 2a 20 76 6f 69 64 20 28 29 20 22 ambda* void () "
5710: 73 65 74 6c 6f 63 61 6c 65 28 4c 43 5f 4e 55 4d setlocale(LC_NUM
5720: 45 52 49 43 2c 20 5c 22 43 5c 22 29 3b 22 29 5d ERIC, \"C\");")]
5730: 0a 20 20 20 20 20 20 20 20 20 20 20 5b 6f 70 65 . [ope
5740: 6e 2d 69 6d 67 6c 69 62 20 28 66 6f 72 65 69 67 n-imglib (foreig
5750: 6e 2d 6c 61 6d 62 64 61 20 76 6f 69 64 20 22 49 n-lambda void "I
5760: 75 70 49 6d 61 67 65 4c 69 62 4f 70 65 6e 22 29 upImageLibOpen")
5770: 5d 0a 20 20 20 20 20 20 20 20 20 20 20 5b 63 6c ]. [cl
5780: 6f 73 65 20 28 66 6f 72 65 69 67 6e 2d 6c 61 6d ose (foreign-lam
5790: 62 64 61 20 76 6f 69 64 20 22 49 75 70 43 6c 6f bda void "IupClo
57a0: 73 65 22 29 5d 0a 20 20 20 20 20 20 20 20 20 20 se")].
57b0: 20 5b 63 68 69 63 6b 65 6e 2d 79 69 65 6c 64 20 [chicken-yield
57c0: 28 66 6f 72 65 69 67 6e 2d 76 61 6c 75 65 20 22 (foreign-value "
57d0: 26 43 48 49 43 4b 45 4e 5f 79 69 65 6c 64 22 20 &CHICKEN_yield"
57e0: 63 2d 70 6f 69 6e 74 65 72 29 5d 29 0a 09 09 28 c-pointer)])...(
57f0: 61 6e 64 2d 6c 65 74 2a 20 28 5b 28 6c 65 74 20 and-let* ([(let
5800: 28 5b 73 74 61 74 75 73 20 28 64 79 6e 61 6d 69 ([status (dynami
5810: 63 2d 77 69 6e 64 20 76 6f 69 64 20 6f 70 65 6e c-wind void open
5820: 20 73 65 74 6c 6f 63 61 6c 65 29 5d 29 0a 20 20 setlocale)]).
5830: 20 20 09 09 09 20 20 20 20 20 20 20 20 28 63 61 ... (ca
5840: 73 65 20 73 74 61 74 75 73 0a 09 09 09 09 09 09 se status.......
5850: 09 09 09 09 5b 28 23 74 29 20 20 20 20 20 23 74 ....[(#t) #t
5860: 5d 0a 09 09 09 09 09 09 09 09 09 09 5b 28 69 67 ]...........[(ig
5870: 6e 6f 72 65 29 20 23 66 5d 0a 09 09 09 09 09 09 nore) #f].......
5880: 09 09 09 09 5b 65 6c 73 65 20 20 20 20 20 28 65 ....[else (e
5890: 72 72 6f 72 20 27 69 75 70 20 28 66 6f 72 6d 61 rror 'iup (forma
58a0: 74 20 22 66 61 69 6c 65 64 20 74 6f 20 69 6e 69 t "failed to ini
58b0: 74 69 61 6c 69 7a 65 20 6c 69 62 72 61 72 79 20 tialize library
58c0: 28 7e 73 29 22 20 73 74 61 74 75 73 29 29 5d 29 (~s)" status))])
58d0: 29 5d 0a 20 20 20 20 20 20 09 20 20 20 20 20 20 )]. .
58e0: 20 5b 28 6f 70 65 6e 2d 69 6d 67 6c 69 62 29 5d [(open-imglib)]
58f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5900: 5b 77 61 74 63 68 64 6f 67 20 28 74 69 6d 65 72 [watchdog (timer
5910: 29 5d 29 0a 20 20 20 20 20 20 28 73 65 74 2d 66 )]). (set-f
5920: 69 6e 61 6c 69 7a 65 72 21 0a 20 20 20 20 20 20 inalizer!.
5930: 20 77 61 74 63 68 64 6f 67 0a 20 20 20 20 20 20 watchdog.
5940: 20 28 6c 61 6d 62 64 61 20 28 77 61 74 63 68 64 (lambda (watchd
5950: 6f 67 29 0a 20 20 20 20 20 20 20 20 20 28 64 65 og). (de
5960: 73 74 72 6f 79 21 20 77 61 74 63 68 64 6f 67 29 stroy! watchdog)
5970: 0a 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 . (close
5980: 29 29 29 0a 20 20 20 20 20 20 28 63 61 6c 6c 62 ))). (callb
5990: 61 63 6b 2d 73 65 74 21 20 77 61 74 63 68 64 6f ack-set! watchdo
59a0: 67 20 27 61 63 74 69 6f 6e 2d 63 62 20 63 68 69 g 'action-cb chi
59b0: 63 6b 65 6e 2d 79 69 65 6c 64 29 0a 20 20 20 20 cken-yield).
59c0: 20 20 28 61 74 74 72 69 62 75 74 65 2d 73 65 74 (attribute-set
59d0: 21 20 77 61 74 63 68 64 6f 67 20 27 74 69 6d 65 ! watchdog 'time
59e0: 20 35 30 30 29 0a 20 20 20 20 20 20 28 61 74 74 500). (att
59f0: 72 69 62 75 74 65 2d 73 65 74 21 20 77 61 74 63 ribute-set! watc
5a00: 68 64 6f 67 20 27 72 75 6e 20 23 74 29 0a 20 20 hdog 'run #t).
5a10: 20 20 20 20 77 61 74 63 68 64 6f 67 29 29 29 0a watchdog))).
5a20: 0a 3b 3b 20 7d 7d 7d 0a .;; }}}.