Artifact
4b8ee9d250fa360117d6edb027b7b66dce1b90c7:
- File
free-gettext.sls
— part of check-in
[f7b95bffe0]
at
2016-12-14 00:08:31
on branch trunk
— some cleanup on free-gettext.sls
(user:
aldo
size: 29059)
0000: 3b 3b 20 67 65 74 74 65 78 74 2e 73 63 6d 20 2d ;; gettext.scm -
0010: 2d 20 67 65 74 74 65 78 74 20 73 75 70 65 72 73 - gettext supers
0020: 65 74 20 69 6d 70 6c 65 6d 65 6e 74 65 64 20 69 et implemented i
0030: 6e 20 53 63 68 65 6d 65 0a 3b 3b 0a 3b 3b 20 43 n Scheme.;;.;; C
0040: 6f 70 79 72 69 67 68 74 20 28 63 29 20 32 30 30 opyright (c) 200
0050: 33 2d 32 30 31 32 20 41 6c 65 78 20 53 68 69 6e 3-2012 Alex Shin
0060: 6e 2e 20 20 41 6c 6c 20 72 69 67 68 74 73 20 72 n. All rights r
0070: 65 73 65 72 76 65 64 2e 0a 3b 3b 20 42 53 44 2d eserved..;; BSD-
0080: 73 74 79 6c 65 20 6c 69 63 65 6e 73 65 3a 20 68 style license: h
0090: 74 74 70 3a 2f 2f 73 79 6e 74 68 63 6f 64 65 2e ttp://synthcode.
00a0: 63 6f 6d 2f 6c 69 63 65 6e 73 65 2e 74 78 74 0a com/license.txt.
00b0: 0a 3b 3b 20 4d 6f 64 69 66 69 63 61 74 69 6f 6e .;; Modification
00c0: 73 20 66 6f 72 20 43 48 49 43 4b 45 4e 20 34 20 s for CHICKEN 4
00d0: 62 79 20 54 68 6f 6d 61 73 20 43 68 75 73 74 20 by Thomas Chust
00e0: 28 32 30 31 30 29 0a 3b 3b 0a 3b 3b 20 4d 6f 64 (2010).;;.;; Mod
00f0: 69 66 69 63 61 74 69 6f 6e 73 20 66 6f 72 20 43 ifications for C
0100: 68 65 7a 20 53 63 68 65 6d 65 20 62 79 20 41 6c hez Scheme by Al
0110: 64 6f 20 4e 69 63 6f 6c 61 73 20 42 72 75 6e 6f do Nicolas Bruno
0120: 20 28 32 30 31 36 29 0a 3b 3b 0a 3b 3b 20 54 68 (2016).;;.;; Th
0130: 69 73 20 69 73 20 2a 6e 6f 74 2a 20 67 65 74 74 is is *not* gett
0140: 65 78 74 2c 20 6e 6f 72 20 64 6f 65 73 20 69 74 ext, nor does it
0150: 20 75 73 65 20 74 68 65 20 43 20 67 65 74 74 65 use the C gette
0160: 78 74 20 6c 69 62 72 61 72 79 2e 0a 3b 3b 0a 3b xt library..;;.;
0170: 3b 20 54 68 69 73 20 69 73 20 61 20 66 75 6c 6c ; This is a full
0180: 20 67 65 74 74 65 78 74 20 73 75 70 65 72 73 65 gettext superse
0190: 74 20 77 72 69 74 74 65 6e 20 69 6e 20 70 75 72 t written in pur
01a0: 65 20 53 63 68 65 6d 65 20 66 72 6f 6d 20 72 65 e Scheme from re
01b0: 61 64 69 6e 67 0a 3b 3b 20 74 68 65 20 67 65 74 ading.;; the get
01c0: 74 65 78 74 20 64 6f 63 75 6d 65 6e 74 61 74 69 text documentati
01d0: 6f 6e 20 2d 20 49 20 68 61 76 65 20 6e 65 76 65 on - I have neve
01e0: 72 20 6c 6f 6f 6b 65 64 20 61 74 20 74 68 65 20 r looked at the
01f0: 67 65 74 74 65 78 74 20 73 6f 75 72 63 65 0a 3b gettext source.;
0200: 3b 20 63 6f 64 65 2c 20 73 6f 20 74 68 69 73 20 ; code, so this
0210: 6d 61 79 20 62 65 20 75 73 65 64 20 75 6e 64 65 may be used unde
0220: 72 20 61 20 6d 6f 72 65 20 6c 69 62 65 72 61 6c r a more liberal
0230: 20 42 53 44 2d 73 74 79 6c 65 20 6c 69 63 65 6e BSD-style licen
0240: 73 65 20 61 73 0a 3b 3b 20 61 62 6f 76 65 2e 0a se as.;; above..
0250: 3b 3b 0a 3b 3b 20 54 68 69 73 20 6c 69 62 72 61 ;;.;; This libra
0260: 72 79 20 69 6e 63 6c 75 64 65 73 20 76 61 72 69 ry includes vari
0270: 6f 75 73 20 65 78 74 65 6e 73 69 6f 6e 73 2c 20 ous extensions,
0280: 69 6e 63 6c 75 64 69 6e 67 20 74 68 65 20 61 62 including the ab
0290: 69 6c 69 74 79 20 74 6f 0a 3b 3b 20 73 75 70 70 ility to.;; supp
02a0: 6f 72 74 20 6d 75 6c 74 69 70 6c 65 20 64 6f 6d ort multiple dom
02b0: 61 69 6e 73 2c 20 6c 6f 63 61 6c 65 73 20 61 6e ains, locales an
02c0: 64 20 73 65 61 72 63 68 20 70 61 74 68 73 3b 20 d search paths;
02d0: 74 68 65 20 61 62 69 6c 69 74 79 20 74 6f 0a 3b the ability to.;
02e0: 3b 20 72 65 61 64 20 62 6f 74 68 20 2e 70 6f 20 ; read both .po
02f0: 61 6e 64 20 2e 6d 6f 20 66 69 6c 65 73 20 64 69 and .mo files di
0300: 72 65 63 74 6c 79 20 61 73 20 6d 65 73 73 61 67 rectly as messag
0310: 65 20 63 61 74 61 6c 6f 67 73 3b 20 61 6e 64 20 e catalogs; and
0320: 61 20 6d 6f 72 65 0a 3b 3b 20 53 63 68 65 6d 65 a more.;; Scheme
0330: 69 73 68 20 64 69 73 70 61 74 63 68 20 69 6e 74 ish dispatch int
0340: 65 72 66 61 63 65 2e 0a 3b 3b 0a 3b 3b 20 54 68 erface..;;.;; Th
0350: 65 20 6d 75 6c 74 69 70 6c 65 20 64 6f 6d 61 69 e multiple domai
0360: 6e 20 69 6e 74 65 72 66 61 63 65 20 69 73 20 75 n interface is u
0370: 73 65 66 75 6c 20 62 65 63 61 75 73 65 20 69 74 seful because it
0380: 20 61 6c 6c 6f 77 73 20 6d 75 6c 74 69 70 6c 65 allows multiple
0390: 0a 3b 3b 20 61 70 70 6c 69 63 61 74 69 6f 6e 73 .;; applications
03a0: 20 74 6f 20 73 68 61 72 65 20 6d 65 73 73 61 67 to share messag
03b0: 65 20 63 61 74 61 6c 6f 67 73 20 77 68 69 6c 65 e catalogs while
03c0: 20 73 74 69 6c 6c 20 65 78 74 65 6e 64 69 6e 67 still extending
03d0: 20 74 68 65 69 72 0a 3b 3b 20 6f 77 6e 20 6d 65 their.;; own me
03e0: 73 73 61 67 65 73 2e 20 20 4d 61 6e 79 20 61 70 ssages. Many ap
03f0: 70 6c 69 63 61 74 69 6f 6e 73 20 75 73 65 20 6d plications use m
0400: 61 6e 79 20 6f 66 20 74 68 65 20 73 61 6d 65 20 any of the same
0410: 6d 65 73 73 61 67 65 73 2c 20 73 75 63 68 0a 3b messages, such.;
0420: 3b 20 61 73 20 74 68 6f 73 65 20 66 6f 72 20 6d ; as those for m
0430: 65 6e 75 20 6e 61 6d 65 73 2c 20 61 6e 64 20 74 enu names, and t
0440: 68 65 73 65 20 6d 65 73 73 61 67 65 73 20 63 61 hese messages ca
0450: 6e 20 65 61 73 69 6c 79 20 62 65 20 6c 65 76 65 n easily be leve
0460: 72 61 67 65 64 0a 3b 3b 20 69 6e 20 53 63 68 65 raged.;; in Sche
0470: 6d 65 20 61 73 20 66 6f 6c 6c 6f 77 73 3a 0a 3b me as follows:.;
0480: 3b 0a 3b 3b 20 20 20 28 74 65 78 74 64 6f 6d 61 ;.;; (textdoma
0490: 69 6e 20 27 28 22 6d 79 61 70 70 22 20 22 67 69 in '("myapp" "gi
04a0: 6d 70 22 29 29 20 20 3b 20 73 65 61 72 63 68 20 mp")) ; search
04b0: 31 73 74 20 6d 79 61 70 70 2c 20 74 68 65 6e 20 1st myapp, then
04c0: 67 69 6d 70 0a 3b 3b 20 20 20 28 67 65 74 74 65 gimp.;; (gette
04d0: 78 74 20 22 2f 46 69 6c 65 2f 43 6c 6f 73 65 22 xt "/File/Close"
04e0: 29 20 20 20 20 20 20 20 20 20 3b 20 22 43 6c 6f ) ; "Clo
04f0: 73 65 22 20 66 72 6f 6d 20 67 69 6d 70 20 75 6e se" from gimp un
0500: 6c 65 73 73 20 6f 76 65 72 72 69 64 64 65 6e 0a less overridden.
0510: 3b 3b 0a 3b 3b 20 4d 75 6c 74 69 70 6c 65 20 6c ;;.;; Multiple l
0520: 6f 63 61 6c 65 73 20 63 61 6e 20 62 65 20 75 73 ocales can be us
0530: 65 66 75 6c 20 77 68 69 6c 65 20 74 72 61 6e 73 eful while trans
0540: 6c 61 74 69 6f 6e 73 20 61 72 65 20 73 74 69 6c lations are stil
0550: 6c 20 69 6e 0a 3b 3b 20 70 72 6f 67 72 65 73 73 l in.;; progress
0560: 2e 20 20 49 74 20 69 73 20 6e 6f 74 20 66 61 69 . It is not fai
0570: 72 20 74 6f 20 61 73 73 75 6d 65 20 74 68 61 74 r to assume that
0580: 20 45 6e 67 6c 69 73 68 20 28 6f 72 20 77 68 61 English (or wha
0590: 74 65 76 65 72 20 74 68 65 0a 3b 3b 20 6e 61 74 tever the.;; nat
05a0: 69 76 65 20 73 6f 75 72 63 65 20 75 73 65 73 29 ive source uses)
05b0: 20 69 73 20 74 68 65 20 62 65 73 74 20 61 6c 74 is the best alt
05c0: 65 72 6e 61 74 69 76 65 20 66 6f 72 20 61 20 6d ernative for a m
05d0: 65 73 73 61 67 65 20 74 68 61 74 20 68 61 73 0a essage that has.
05e0: 3b 3b 20 6e 6f 74 20 79 65 74 20 62 65 65 6e 20 ;; not yet been
05f0: 74 72 61 6e 73 6c 61 74 65 64 2c 20 73 6f 20 74 translated, so t
0600: 68 65 20 6c 6f 63 61 6c 65 20 6d 61 79 20 61 6c he locale may al
0610: 73 6f 20 62 65 20 61 20 6c 69 73 74 3a 0a 3b 3b so be a list:.;;
0620: 0a 3b 3b 20 20 20 28 74 65 78 74 64 6f 6d 61 69 .;; (textdomai
0630: 6e 20 22 6d 79 61 70 70 22 20 27 28 22 72 75 22 n "myapp" '("ru"
0640: 20 22 75 6b 22 29 29 20 20 3b 20 73 65 61 72 63 "uk")) ; searc
0650: 68 20 31 73 74 20 52 75 73 73 69 61 6e 20 74 68 h 1st Russian th
0660: 65 6e 20 55 6b 72 61 6e 69 61 6e 2c 0a 3b 3b 20 en Ukranian,.;;
0670: 20 20 28 67 65 74 74 65 78 74 20 22 48 65 6c 6c (gettext "Hell
0680: 6f 2c 20 57 6f 72 6c 64 21 22 29 20 20 20 20 20 o, World!")
0690: 20 20 20 20 20 3b 20 77 68 69 63 68 20 61 72 65 ; which are
06a0: 20 73 6f 6d 65 77 68 61 74 20 73 69 6d 69 6c 61 somewhat simila
06b0: 72 0a 3b 3b 0a 3b 3b 20 4e 6f 74 65 20 69 6e 20 r.;;.;; Note in
06c0: 62 6f 74 68 20 63 61 73 65 73 20 74 68 65 20 64 both cases the d
06d0: 6f 6d 61 69 6e 20 61 6e 64 20 6c 6f 63 61 6c 65 omain and locale
06e0: 20 6d 61 79 20 62 65 20 65 69 74 68 65 72 20 61 may be either a
06f0: 20 73 69 6e 67 6c 65 0a 3b 3b 20 73 74 72 69 6e single.;; strin
0700: 67 20 28 61 73 20 69 6e 20 74 68 65 20 43 20 67 g (as in the C g
0710: 65 74 74 65 78 74 29 20 6f 72 20 61 20 6c 69 73 ettext) or a lis
0720: 74 20 6f 66 20 73 74 72 69 6e 67 73 20 69 6e 20 t of strings in
0730: 6f 72 64 65 72 20 6f 66 0a 3b 3b 20 64 65 63 72 order of.;; decr
0740: 65 61 73 69 6e 67 20 70 72 69 6f 72 69 74 79 2e easing priority.
0750: 20 20 41 6c 73 6f 20 54 45 58 54 44 4f 4d 41 49 Also TEXTDOMAI
0760: 4e 20 74 61 6b 65 73 20 6c 6f 63 61 6c 65 20 61 N takes locale a
0770: 73 20 61 6e 20 6f 70 74 69 6f 6e 61 6c 20 32 6e s an optional 2n
0780: 64 0a 3b 3b 20 70 61 72 61 6d 65 74 65 72 20 28 d.;; parameter (
0790: 74 6f 20 6f 76 65 72 72 69 64 65 20 74 68 65 20 to override the
07a0: 55 6e 69 78 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 Unix environment
07b0: 20 76 61 72 69 61 62 6c 65 29 2c 20 61 6e 64 20 variable), and
07c0: 69 6e 20 66 61 63 74 0a 3b 3b 20 74 68 65 20 66 in fact.;; the f
07d0: 75 6c 6c 20 70 61 72 61 6d 65 74 65 72 20 6c 69 ull parameter li
07e0: 73 74 20 69 73 20 61 73 20 66 6f 6c 6c 6f 77 73 st is as follows
07f0: 3a 0a 3b 3b 0a 3b 3b 20 20 20 28 74 65 78 74 64 :.;;.;; (textd
0800: 6f 6d 61 69 6e 20 64 6f 6d 61 69 6e 20 5b 6c 6f omain domain [lo
0810: 63 61 6c 65 5d 20 5b 64 69 72 73 5d 20 5b 63 64 cale] [dirs] [cd
0820: 69 72 5d 20 5b 63 61 63 68 65 64 3f 5d 20 5b 6c ir] [cached?] [l
0830: 6f 6f 6b 75 70 2d 63 61 63 68 65 64 3f 5d 29 0a ookup-cached?]).
0840: 3b 3b 0a 3b 3b 20 44 4f 4d 41 49 4e 20 69 73 20 ;;.;; DOMAIN is
0850: 61 20 73 74 72 69 6e 67 20 6f 72 20 6c 69 73 74 a string or list
0860: 20 6f 66 20 73 74 72 69 6e 67 73 20 73 70 65 63 of strings spec
0870: 69 66 79 69 6e 67 20 74 68 65 20 64 6f 6d 61 69 ifying the domai
0880: 6e 20 28 6e 61 6d 65 20 6f 66 0a 3b 3b 20 2e 6d n (name of.;; .m
0890: 6f 20 6f 72 20 2e 70 6f 20 66 69 6c 65 73 29 20 o or .po files)
08a0: 61 73 20 69 6e 20 43 20 67 65 74 74 65 78 74 2e as in C gettext.
08b0: 0a 3b 3b 0a 3b 3b 20 4c 4f 43 41 4c 45 20 69 73 .;;.;; LOCALE is
08c0: 20 61 20 73 74 72 69 6e 67 20 6f 72 20 6c 69 73 a string or lis
08d0: 74 20 6f 66 20 73 74 72 69 6e 67 73 20 69 6e 20 t of strings in
08e0: 74 68 65 20 73 74 61 6e 64 61 72 64 20 55 6e 69 the standard Uni
08f0: 78 20 66 6f 72 6d 61 74 20 6f 66 0a 3b 3b 20 4c x format of.;; L
0900: 41 4e 47 5b 5f 52 45 47 49 4f 4e 5d 5b 2e 45 4e ANG[_REGION][.EN
0910: 43 4f 44 49 4e 47 5d 0a 3b 3b 0a 3b 3b 20 44 49 CODING].;;.;; DI
0920: 52 53 20 69 73 20 74 68 65 20 73 65 61 72 63 68 RS is the search
0930: 20 70 61 74 68 20 6f 66 20 64 69 72 65 63 74 6f path of directo
0940: 72 69 65 73 20 77 68 69 63 68 20 73 68 6f 75 6c ries which shoul
0950: 64 20 68 6f 6c 64 20 74 68 65 0a 3b 3b 20 4c 4f d hold the.;; LO
0960: 43 41 4c 45 2f 43 44 49 52 2f 20 64 69 72 65 63 CALE/CDIR/ direc
0970: 74 6f 72 69 65 73 20 77 68 69 63 68 20 63 6f 6e tories which con
0980: 74 61 69 6e 20 74 68 65 20 61 63 74 75 61 6c 20 tain the actual
0990: 6d 65 73 73 61 67 65 20 63 61 74 61 6c 6f 67 73 message catalogs
09a0: 2e 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 6c 77 ..;; This is alw
09b0: 61 79 73 20 61 70 70 65 6e 64 65 64 20 77 69 74 ays appended wit
09c0: 68 20 74 68 65 20 73 79 73 74 65 6d 20 64 65 66 h the system def
09d0: 61 75 6c 74 2c 20 65 2e 67 2e 0a 3b 3b 20 22 2f ault, e.g..;; "/
09e0: 75 73 72 2f 73 68 61 72 65 2f 6c 6f 63 61 6c 65 usr/share/locale
09f0: 22 2c 20 61 6e 64 20 6d 61 79 20 61 6c 73 6f 20 ", and may also
0a00: 69 6e 68 65 72 69 74 20 66 72 6f 6d 20 74 68 65 inherit from the
0a10: 20 47 45 54 54 45 58 54 5f 50 41 54 48 0a 3b 3b GETTEXT_PATH.;;
0a20: 20 63 6f 6c 6f 6e 2d 64 65 6c 69 6d 69 74 65 64 colon-delimited
0a30: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 environment var
0a40: 69 61 62 6c 65 2e 0a 3b 3b 0a 3b 3b 20 43 44 49 iable..;;.;; CDI
0a50: 52 20 69 73 20 74 68 65 20 63 61 74 61 67 6f 72 R is the catagor
0a60: 79 20 64 69 72 65 63 74 6f 72 79 2c 20 64 65 66 y directory, def
0a70: 61 75 6c 74 69 6e 67 20 74 6f 20 65 69 74 68 65 aulting to eithe
0a80: 72 20 74 68 65 20 4c 43 5f 43 41 54 45 47 4f 52 r the LC_CATEGOR
0a90: 59 0a 3b 3b 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 Y.;; environment
0aa0: 20 76 61 72 69 61 62 6c 65 20 6f 72 20 74 68 65 variable or the
0ab0: 20 61 70 70 72 6f 70 72 69 61 74 65 20 73 79 73 appropriate sys
0ac0: 74 65 6d 20 64 65 66 61 75 6c 74 0a 3b 3b 20 28 tem default.;; (
0ad0: 65 2e 67 2e 20 4c 43 5f 4d 45 53 53 41 47 45 53 e.g. LC_MESSAGES
0ae0: 29 2e 20 20 59 6f 75 20 67 65 6e 65 72 61 6c 6c ). You generall
0af0: 79 20 77 6f 6e 27 74 20 6e 65 65 64 20 74 68 69 y won't need thi
0b00: 73 2e 0a 3b 3b 0a 3b 3b 20 43 41 43 48 45 44 3f s..;;.;; CACHED?
0b10: 20 6d 65 61 6e 73 20 74 6f 20 63 61 63 68 65 20 means to cache
0b20: 69 6e 64 69 76 69 64 75 61 6c 20 6d 65 73 73 61 individual messa
0b30: 67 65 73 2c 20 61 6e 64 20 64 65 66 61 75 6c 74 ges, and default
0b40: 73 20 74 6f 20 23 74 2e 0a 3b 3b 0a 3b 3b 20 4c s to #t..;;.;; L
0b50: 4f 4f 4b 55 50 2d 43 41 43 48 45 44 3f 20 6d 65 OOKUP-CACHED? me
0b60: 61 6e 73 20 74 6f 20 63 61 63 68 65 20 74 68 65 ans to cache the
0b70: 20 6c 6f 6f 6b 75 70 20 64 69 73 70 61 74 63 68 lookup dispatch
0b80: 20 67 65 6e 65 72 61 74 65 64 20 62 79 20 74 68 generated by th
0b90: 65 73 65 0a 3b 3b 20 70 61 72 61 6d 65 74 65 72 ese.;; parameter
0ba0: 73 2c 20 61 6e 64 20 64 65 66 61 75 6c 74 73 20 s, and defaults
0bb0: 74 6f 20 23 74 2e 0a 3b 3b 0a 3b 3b 20 54 45 58 to #t..;;.;; TEX
0bc0: 54 44 4f 4d 41 49 4e 20 6a 75 73 74 20 70 61 73 TDOMAIN just pas
0bd0: 73 65 73 20 74 68 65 73 65 20 70 61 72 61 6d 65 ses these parame
0be0: 74 65 72 73 20 74 6f 20 74 68 65 20 69 6e 74 65 ters to the inte
0bf0: 72 6e 61 6c 20 4d 41 4b 45 2d 47 45 54 54 45 58 rnal MAKE-GETTEX
0c00: 54 2c 0a 3b 3b 20 61 6e 64 20 62 69 6e 64 73 20 T,.;; and binds
0c10: 74 68 65 20 72 65 73 75 6c 74 20 74 6f 20 74 68 the result to th
0c20: 65 20 67 6c 6f 62 61 6c 20 64 69 73 70 61 74 63 e global dispatc
0c30: 68 20 75 73 65 64 20 62 79 20 47 45 54 54 45 58 h used by GETTEX
0c40: 54 2e 20 20 59 6f 75 20 6d 61 79 0a 3b 3b 20 62 T. You may.;; b
0c50: 75 69 6c 64 20 74 68 65 73 65 20 63 6c 6f 73 75 uild these closu
0c60: 72 65 73 20 6d 61 6e 75 61 6c 6c 79 20 66 6f 72 res manually for
0c70: 20 63 6f 6e 76 65 6e 69 65 6e 63 65 20 69 6e 20 convenience in
0c80: 75 73 69 6e 67 20 6d 75 6c 74 69 70 6c 65 0a 3b using multiple.;
0c90: 3b 20 73 65 70 61 72 61 74 65 20 64 6f 6d 61 69 ; separate domai
0ca0: 6e 73 20 6f 72 20 6c 6f 63 61 6c 65 73 20 61 74 ns or locales at
0cb0: 20 6f 6e 63 65 20 28 75 73 65 66 75 6c 20 66 6f once (useful fo
0cc0: 72 20 73 65 72 76 65 72 20 65 6e 76 69 72 6f 6e r server environ
0cd0: 6d 65 6e 74 73 29 3a 0a 3b 3b 0a 3b 3b 20 20 28 ments):.;;.;; (
0ce0: 64 65 66 69 6e 65 20 6d 79 2d 67 65 74 74 65 78 define my-gettex
0cf0: 74 20 28 6d 61 6b 65 2d 67 65 74 74 65 78 74 20 t (make-gettext
0d00: 22 6d 79 61 70 70 22 29 29 0a 3b 3b 20 20 28 64 "myapp")).;; (d
0d10: 65 66 69 6e 65 20 5f 20 28 6d 79 2d 67 65 74 74 efine _ (my-gett
0d20: 65 78 74 20 27 67 65 74 74 65 72 29 29 0a 3b 3b ext 'getter)).;;
0d30: 20 20 28 5f 22 48 65 6c 6c 6f 2c 20 57 6f 72 6c (_"Hello, Worl
0d40: 64 21 22 29 0a 0a 28 6c 69 62 72 61 72 79 20 28 d!")..(library (
0d50: 66 72 65 65 2d 67 65 74 74 65 78 74 29 0a 20 20 free-gettext).
0d60: 28 65 78 70 6f 72 74 0a 20 20 20 3b 3b 20 73 74 (export. ;; st
0d70: 61 6e 64 61 72 64 20 67 65 74 74 65 78 74 20 69 andard gettext i
0d80: 6e 74 65 72 66 61 63 65 0a 20 20 20 67 65 74 74 nterface. gett
0d90: 65 78 74 20 74 65 78 74 64 6f 6d 61 69 6e 20 64 ext textdomain d
0da0: 67 65 74 74 65 78 74 20 64 63 67 65 74 74 65 78 gettext dcgettex
0db0: 74 20 62 69 6e 64 74 65 78 74 64 6f 6d 61 69 6e t bindtextdomain
0dc0: 0a 20 20 20 6e 67 65 74 74 65 78 74 20 64 6e 67 . ngettext dng
0dd0: 65 74 74 65 78 74 20 64 63 6e 67 65 74 74 65 78 ettext dcngettex
0de0: 74 0a 20 20 20 3b 3b 20 74 68 65 20 70 61 72 61 t. ;; the para
0df0: 6d 65 74 65 72 20 66 6f 72 20 74 68 65 20 73 74 meter for the st
0e00: 61 6e 64 61 72 64 20 69 6e 74 65 72 66 61 63 65 andard interface
0e10: 0a 20 20 20 64 65 66 61 75 6c 74 2d 67 65 74 74 . default-gett
0e20: 65 78 74 2d 6c 6f 6f 6b 75 70 0a 20 20 20 3b 3b ext-lookup. ;;
0e30: 20 6d 6f 72 65 20 66 6c 65 78 69 62 6c 65 20 69 more flexible i
0e40: 6e 74 65 72 66 61 63 65 20 66 6f 72 20 62 75 69 nterface for bui
0e50: 6c 64 69 6e 67 20 6c 6f 6f 6b 75 70 73 0a 20 20 lding lookups.
0e60: 20 6d 61 6b 65 2d 67 65 74 74 65 78 74 0a 20 20 make-gettext.
0e70: 20 3b 3b 20 67 66 69 6c 65 20 61 63 63 65 73 73 ;; gfile access
0e80: 6f 72 73 0a 20 20 20 67 66 69 6c 65 3f 20 67 66 ors. gfile? gf
0e90: 69 6c 65 2d 66 69 6c 65 6e 61 6d 65 20 67 66 69 ile-filename gfi
0ea0: 6c 65 2d 6c 6f 63 61 6c 65 20 67 66 69 6c 65 2d le-locale gfile-
0eb0: 65 6e 63 6f 64 69 6e 67 0a 20 20 20 67 66 69 6c encoding. gfil
0ec0: 65 2d 70 72 6f 70 65 72 74 69 65 73 20 67 66 69 e-properties gfi
0ed0: 6c 65 2d 74 79 70 65 20 67 66 69 6c 65 2d 70 6c le-type gfile-pl
0ee0: 75 72 61 6c 2d 69 6e 64 65 78 0a 20 20 20 6d 61 ural-index. ma
0ef0: 6b 65 2d 67 65 74 74 65 78 74 2d 66 69 6c 65 0a ke-gettext-file.
0f00: 20 20 20 3b 3b 20 6c 6f 77 2d 6c 65 76 65 6c 20 ;; low-level
0f10: 70 61 72 73 65 72 73 0a 20 20 20 6c 6f 6f 6b 75 parsers. looku
0f20: 70 2d 70 6f 2d 6d 65 73 73 61 67 65 20 6c 6f 6f p-po-message loo
0f30: 6b 75 70 2d 6d 6f 2d 6d 65 73 73 61 67 65 29 0a kup-mo-message).
0f40: 20 20 28 69 6d 70 6f 72 74 20 28 63 68 65 7a 73 (import (chezs
0f50: 63 68 65 6d 65 29 0a 09 20 20 28 64 61 74 61 2d cheme).. (data-
0f60: 73 74 72 75 63 74 75 72 65 73 29 0a 09 20 20 28 structures).. (
0f70: 69 72 72 65 67 65 78 29 0a 09 20 20 28 73 72 66 irregex).. (srf
0f80: 69 20 73 32 20 61 6e 64 2d 6c 65 74 29 0a 09 20 i s2 and-let)..
0f90: 20 28 73 72 66 69 20 70 72 69 76 61 74 65 20 6c (srfi private l
0fa0: 65 74 2d 6f 70 74 29 0a 09 20 20 28 73 72 66 69 et-opt).. (srfi
0fb0: 20 73 32 36 20 63 75 74 29 0a 09 20 20 28 6f 6e s26 cut).. (on
0fc0: 6c 79 20 28 73 72 66 69 20 73 31 20 6c 69 73 74 ly (srfi s1 list
0fd0: 73 29 20 61 70 70 65 6e 64 2d 6d 61 70 20 61 6e s) append-map an
0fe0: 79 29 0a 09 20 20 28 6f 6e 6c 79 20 28 73 72 66 y).. (only (srf
0ff0: 69 20 73 31 33 20 73 74 72 69 6e 67 73 29 20 73 i s13 strings) s
1000: 74 72 69 6e 67 2d 74 72 69 6d 20 73 74 72 69 6e tring-trim strin
1010: 67 2d 74 72 69 6d 2d 62 6f 74 68 0a 09 09 73 75 g-trim-both...su
1020: 62 73 74 72 69 6e 67 2f 73 68 61 72 65 64 20 73 bstring/shared s
1030: 74 72 69 6e 67 2d 69 6e 64 65 78 20 73 74 72 69 tring-index stri
1040: 6e 67 2d 73 75 66 66 69 78 3f 20 73 74 72 69 6e ng-suffix? strin
1050: 67 2d 70 72 65 66 69 78 3f 0a 09 09 73 74 72 69 g-prefix?...stri
1060: 6e 67 2d 63 6f 6e 63 61 74 65 6e 61 74 65 2d 72 ng-concatenate-r
1070: 65 76 65 72 73 65 29 0a 09 20 20 28 6f 6e 6c 79 everse).. (only
1080: 20 28 74 68 75 6e 64 65 72 2d 75 74 69 6c 73 29 (thunder-utils)
1090: 20 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 72 65 string-split re
10a0: 61 64 2d 73 74 72 69 6e 67 29 29 0a 0a 20 20 3b ad-string)).. ;
10b0: 3b 20 69 6d 70 6c 65 6d 65 6e 74 20 73 74 72 69 ; implement stri
10c0: 6e 67 2d 6d 61 74 63 68 20 77 69 74 68 20 69 72 ng-match with ir
10d0: 72 65 67 65 78 0a 20 20 28 64 65 66 69 6e 65 20 regex. (define
10e0: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 72 65 (string-match re
10f0: 67 65 78 20 74 78 74 29 0a 20 20 20 20 28 63 6f gex txt). (co
1100: 6e 64 0a 20 20 20 20 20 5b 28 69 72 72 65 67 65 nd. [(irrege
1110: 78 2d 6d 61 74 63 68 20 28 69 72 72 65 67 65 78 x-match (irregex
1120: 20 72 65 67 65 78 29 20 74 78 74 29 0a 20 20 20 regex) txt).
1130: 20 20 20 3d 3e 20 28 6c 61 6d 62 64 61 20 28 6d => (lambda (m
1140: 29 0a 09 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 ).. (map (lamb
1150: 64 61 20 28 78 29 0a 09 09 20 20 28 69 72 72 65 da (x)... (irre
1160: 67 65 78 2d 6d 61 74 63 68 2d 73 75 62 73 74 72 gex-match-substr
1170: 69 6e 67 20 6d 20 78 29 29 0a 09 09 28 69 6f 74 ing m x))...(iot
1180: 61 20 28 2b 20 31 20 28 69 72 72 65 67 65 78 2d a (+ 1 (irregex-
1190: 6d 61 74 63 68 2d 6e 75 6d 2d 73 75 62 6d 61 74 match-num-submat
11a0: 63 68 65 73 20 6d 29 29 29 29 29 5d 0a 20 20 20 ches m)))))].
11b0: 20 20 5b 65 6c 73 65 20 23 66 5d 29 29 0a 20 20 [else #f])).
11c0: 0a 20 20 28 61 6c 69 61 73 20 67 65 74 2d 65 6e . (alias get-en
11d0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
11e0: 6c 65 20 67 65 74 65 6e 76 29 0a 20 20 28 61 6c le getenv). (al
11f0: 69 61 73 20 61 72 69 74 68 6d 65 74 69 63 2d 73 ias arithmetic-s
1200: 68 69 66 74 20 62 69 74 77 69 73 65 2d 61 72 69 hift bitwise-ari
1210: 74 68 6d 65 74 69 63 2d 73 68 69 66 74 29 0a 20 thmetic-shift).
1220: 20 28 61 6c 69 61 73 20 68 61 73 68 2d 74 61 62 (alias hash-tab
1230: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 le-ref/default h
1240: 61 73 68 74 61 62 6c 65 2d 72 65 66 29 0a 20 20 ashtable-ref).
1250: 28 61 6c 69 61 73 20 68 61 73 68 2d 74 61 62 6c (alias hash-tabl
1260: 65 2d 73 65 74 21 20 68 61 73 68 74 61 62 6c 65 e-set! hashtable
1270: 2d 73 65 74 21 29 0a 20 20 28 61 6c 69 61 73 20 -set!). (alias
1280: 68 61 73 68 2d 74 61 62 6c 65 2d 65 78 69 73 74 hash-table-exist
1290: 73 3f 20 68 61 73 68 74 61 62 6c 65 2d 63 6f 6e s? hashtable-con
12a0: 74 61 69 6e 73 3f 29 0a 20 20 0a 20 20 28 64 65 tains?). . (de
12b0: 66 69 6e 65 20 28 72 65 61 64 2d 62 79 74 65 20 fine (read-byte
12c0: 70 29 20 28 67 65 74 2d 75 38 20 70 29 29 0a 20 p) (get-u8 p)).
12d0: 20 0a 20 20 28 64 65 66 69 6e 65 20 72 65 61 64 . (define read
12e0: 2d 6c 69 6e 65 20 28 63 61 73 65 2d 6c 61 6d 62 -line (case-lamb
12f0: 64 61 0a 09 09 20 20 20 20 20 5b 28 29 20 28 67 da... [() (g
1300: 65 74 2d 6c 69 6e 65 20 28 63 75 72 72 65 6e 74 et-line (current
1310: 2d 69 6e 70 75 74 2d 70 6f 72 74 29 29 5d 0a 09 -input-port))]..
1320: 09 20 20 20 20 20 5b 28 70 6f 72 74 29 20 28 67 . [(port) (g
1330: 65 74 2d 6c 69 6e 65 20 70 6f 72 74 29 5d 29 29 et-line port)]))
1340: 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 73 74 72 .. (define (str
1350: 69 6e 67 2d 6e 75 6c 6c 3f 20 78 29 20 28 73 74 ing-null? x) (st
1360: 72 69 6e 67 3d 3f 20 78 20 22 22 29 29 0a 20 20 ring=? x "")).
1370: 0a 20 20 28 64 65 66 69 6e 65 20 28 63 61 6c 6c . (define (call
1380: 2d 77 69 74 68 2d 69 6e 70 75 74 2d 73 74 72 69 -with-input-stri
1390: 6e 67 20 73 74 72 20 70 72 6f 63 29 0a 20 20 20 ng str proc).
13a0: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
13b0: 6d 2d 73 74 72 69 6e 67 20 73 74 72 0a 20 20 20 m-string str.
13c0: 20 20 20 28 70 72 6f 63 20 28 63 75 72 72 65 6e (proc (curren
13d0: 74 2d 69 6e 70 75 74 2d 70 6f 72 74 29 29 29 29 t-input-port))))
13e0: 0a 20 20 0a 20 20 28 64 65 66 69 6e 65 20 28 73 . . (define (s
13f0: 65 6c 65 63 74 2d 74 72 61 6e 73 63 6f 64 65 72 elect-transcoder
1400: 20 65 6e 63 29 0a 20 20 20 20 28 6d 61 6b 65 2d enc). (make-
1410: 74 72 61 6e 73 63 6f 64 65 72 0a 09 09 20 20 20 transcoder...
1420: 28 63 6f 6e 64 20 5b 28 6f 72 20 28 6e 6f 74 20 (cond [(or (not
1430: 65 6e 63 29 20 28 73 74 72 69 6e 67 2d 63 69 3d enc) (string-ci=
1440: 3f 20 65 6e 63 20 22 75 74 66 38 22 29 20 28 73 ? enc "utf8") (s
1450: 74 72 69 6e 67 2d 63 69 3d 3f 20 65 6e 63 20 22 tring-ci=? enc "
1460: 75 74 66 2d 38 22 29 29 0a 09 09 09 20 20 28 75 utf-8")).... (u
1470: 74 66 2d 38 2d 63 6f 64 65 63 29 5d 0a 09 09 09 tf-8-codec)]....
1480: 20 5b 28 73 74 72 69 6e 67 2d 63 69 3d 3f 20 65 [(string-ci=? e
1490: 6e 63 20 22 6c 61 74 69 6e 31 22 29 0a 09 09 09 nc "latin1")....
14a0: 20 20 28 6c 61 74 69 6e 2d 31 2d 63 6f 64 65 63 (latin-1-codec
14b0: 29 5d 0a 09 09 09 20 5b 65 6c 73 65 0a 09 09 09 )].... [else....
14c0: 20 20 28 69 63 6f 6e 76 2d 63 6f 64 65 63 20 65 (iconv-codec e
14d0: 6e 63 29 5d 29 29 29 0a 0a 20 20 28 64 65 66 69 nc)]))).. (defi
14e0: 6e 65 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 ne (with-input-f
14f0: 72 6f 6d 2d 65 6e 63 6f 64 65 64 2d 66 69 6c 65 rom-encoded-file
1500: 20 66 69 6c 65 20 65 6e 63 20 74 68 75 6e 6b 29 file enc thunk)
1510: 0a 20 20 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d . (call-with-
1520: 70 6f 72 74 0a 20 20 20 20 20 28 74 72 61 6e 73 port. (trans
1530: 63 6f 64 65 64 2d 70 6f 72 74 20 28 6f 70 65 6e coded-port (open
1540: 2d 69 6e 70 75 74 2d 66 69 6c 65 20 66 69 6c 65 -input-file file
1550: 29 20 28 73 65 6c 65 63 74 2d 74 72 61 6e 73 63 ) (select-transc
1560: 6f 64 65 72 20 65 6e 63 29 29 0a 20 20 20 20 20 oder enc)).
1570: 28 6c 61 6d 62 64 61 20 28 70 6f 72 74 29 0a 20 (lambda (port).
1580: 20 20 20 20 20 20 28 70 61 72 61 6d 65 74 65 72 (parameter
1590: 69 7a 65 20 28 5b 63 75 72 72 65 6e 74 2d 69 6e ize ([current-in
15a0: 70 75 74 2d 70 6f 72 74 20 70 6f 72 74 5d 29 20 put-port port])
15b0: 28 74 68 75 6e 6b 29 29 29 29 29 0a 20 20 0a 20 (thunk))))). .
15c0: 20 28 64 65 66 69 6e 65 20 28 66 69 6c 65 2d 72 (define (file-r
15d0: 65 61 64 2d 61 63 63 65 73 73 3f 20 70 61 74 68 ead-access? path
15e0: 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ). (cond.
15f0: 20 5b 28 67 75 61 72 64 20 28 65 20 5b 65 6c 73 [(guard (e [els
1600: 65 20 23 66 5d 29 20 28 6f 70 65 6e 2d 66 69 6c e #f]) (open-fil
1610: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 70 61 74 e-input-port pat
1620: 68 20 29 29 0a 20 20 20 20 20 20 3d 3e 20 28 6c h )). => (l
1630: 61 6d 62 64 61 20 28 70 29 0a 09 20 20 20 28 63 ambda (p).. (c
1640: 6c 6f 73 65 2d 70 6f 72 74 20 70 29 0a 09 20 20 lose-port p)..
1650: 20 23 74 29 5d 0a 20 20 20 20 20 5b 65 6c 73 65 #t)]. [else
1660: 0a 20 20 20 20 20 20 23 66 5d 29 29 0a 20 20 20 . #f])).
1670: 20 0a 20 20 28 64 65 66 69 6e 65 20 28 6d 61 6b . (define (mak
1680: 65 2d 70 61 74 68 6e 61 6d 65 20 2e 20 6c 29 0a e-pathname . l).
1690: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
16a0: 72 73 70 65 72 73 65 20 6c 20 28 73 74 72 69 6e rsperse l (strin
16b0: 67 20 28 64 69 72 65 63 74 6f 72 79 2d 73 65 70 g (directory-sep
16c0: 61 72 61 74 6f 72 29 29 29 29 0a 0a 20 20 28 64 arator)))).. (d
16d0: 65 66 69 6e 65 20 28 70 72 69 6e 74 2d 65 72 72 efine (print-err
16e0: 6f 72 2d 6d 65 73 73 61 67 65 20 63 6f 6e 64 20 or-message cond
16f0: 70 6f 72 74 20 64 65 73 63 29 0a 20 20 20 20 28 port desc). (
1700: 64 69 73 70 6c 61 79 20 64 65 73 63 20 70 6f 72 display desc por
1710: 74 29 20 28 64 69 73 70 6c 61 79 2d 63 6f 6e 64 t) (display-cond
1720: 69 74 69 6f 6e 20 63 6f 6e 64 20 70 6f 72 74 29 ition cond port)
1730: 20 29 0a 20 20 0a 3b 3b 20 5e 5e 5e 20 4e 6f 6e ). .;; ^^^ Non
1740: 2d 53 52 46 49 20 69 6d 70 6f 72 74 73 3a 0a 3b -SRFI imports:.;
1750: 3b 0a 3b 3b 20 57 49 54 48 2d 49 4e 50 55 54 2d ;.;; WITH-INPUT-
1760: 46 52 4f 4d 2d 45 4e 43 4f 44 45 44 2d 46 49 4c FROM-ENCODED-FIL
1770: 45 2c 20 43 45 53 2d 43 4f 4e 56 45 52 54 20 61 E, CES-CONVERT a
1780: 6e 64 20 44 45 54 45 43 54 2d 46 49 4c 45 2d 45 nd DETECT-FILE-E
1790: 4e 43 4f 44 49 4e 47 0a 3b 3b 20 20 20 66 72 6f NCODING.;; fro
17a0: 6d 20 63 68 61 72 63 6f 6e 76 20 28 47 61 75 63 m charconv (Gauc
17b0: 68 65 20 63 6f 6d 70 61 74 69 62 6c 65 20 41 50 he compatible AP
17c0: 49 29 0a 3b 3b 20 47 45 54 2d 45 4e 56 49 52 4f I).;; GET-ENVIRO
17d0: 4e 4d 45 4e 54 2d 56 41 52 49 41 42 4c 45 20 61 NMENT-VARIABLE a
17e0: 6e 64 20 46 49 4c 45 2d 52 45 41 44 2d 41 43 43 nd FILE-READ-ACC
17f0: 45 53 53 3f 20 66 72 6f 6d 20 70 6f 73 69 78 0a ESS? from posix.
1800: 3b 3b 20 52 46 43 38 32 32 2d 48 45 41 44 45 52 ;; RFC822-HEADER
1810: 2d 3e 4c 49 53 54 20 66 72 6f 6d 20 6d 69 6d 65 ->LIST from mime
1820: 20 28 70 6f 72 74 20 66 72 6f 6d 20 47 61 75 63 (port from Gauc
1830: 68 65 29 0a 3b 3b 20 4c 45 54 2d 4f 50 54 49 4f he).;; LET-OPTIO
1840: 4e 41 4c 53 2a 20 66 72 6f 6d 20 53 68 69 76 65 NALS* from Shive
1850: 72 73 27 20 53 52 46 49 73 0a 3b 3b 20 53 54 52 rs' SRFIs.;; STR
1860: 49 4e 47 2d 53 50 4c 49 54 20 66 72 6f 6d 20 43 ING-SPLIT from C
1870: 68 69 63 6b 65 6e 20 61 6e 64 20 47 61 75 63 68 hicken and Gauch
1880: 65 0a 3b 3b 20 43 41 4c 4c 2d 57 49 54 48 2d 49 e.;; CALL-WITH-I
1890: 4e 50 55 54 2d 53 54 52 49 4e 47 20 61 6e 64 20 NPUT-STRING and
18a0: 57 49 54 48 2d 49 4e 50 55 54 2d 46 52 4f 4d 2d WITH-INPUT-FROM-
18b0: 53 54 52 49 4e 47 20 28 61 6c 6d 6f 73 74 20 75 STRING (almost u
18c0: 62 69 71 75 69 74 6f 75 73 29 0a 3b 3b 20 43 4f biquitous).;; CO
18d0: 4e 44 49 54 49 4f 4e 2d 43 41 53 45 20 66 72 6f NDITION-CASE fro
18e0: 6d 20 53 52 46 49 2d 31 32 0a 3b 3b 20 57 41 52 m SRFI-12.;; WAR
18f0: 4e 49 4e 47 20 28 6c 69 6b 65 20 65 72 72 6f 72 NING (like error
1900: 2c 20 62 75 74 20 64 69 61 67 6e 6f 73 74 69 63 , but diagnostic
1910: 20 6f 6e 6c 79 29 0a 3b 3b 20 53 45 54 2d 46 49 only).;; SET-FI
1920: 4c 45 2d 50 4f 53 49 54 49 4f 4e 21 20 28 66 74 LE-POSITION! (ft
1930: 65 6c 6c 29 0a 3b 3b 20 52 45 41 44 2d 53 54 52 ell).;; READ-STR
1940: 49 4e 47 20 28 52 45 41 44 2d 42 4c 4f 43 4b 20 ING (READ-BLOCK
1950: 69 6e 20 47 61 75 63 68 65 2c 20 72 65 61 64 73 in Gauche, reads
1960: 20 4e 20 63 68 61 72 73 29 0a 3b 3b 20 52 45 41 N chars).;; REA
1970: 44 2d 4c 49 4e 45 0a 0a 3b 3b 20 4f 74 68 65 72 D-LINE..;; Other
1980: 20 70 6f 72 74 61 62 69 6c 69 74 79 20 69 73 73 portability iss
1990: 75 65 73 3a 0a 3b 3b 20 20 20 2a 20 61 73 73 75 ues:.;; * assu
19a0: 6d 65 73 20 73 74 72 69 6e 67 73 20 63 61 6e 20 mes strings can
19b0: 63 6f 6e 74 61 69 6e 20 61 72 62 69 74 72 61 72 contain arbitrar
19c0: 79 20 62 69 6e 61 72 79 20 64 61 74 61 0a 3b 3b y binary data.;;
19d0: 20 20 20 2a 20 61 73 73 75 6d 65 73 20 43 48 41 * assumes CHA
19e0: 52 2d 3e 49 4e 54 45 47 45 52 20 61 6e 64 20 49 R->INTEGER and I
19f0: 4e 54 45 47 45 52 2d 3e 43 48 41 52 20 61 72 65 NTEGER->CHAR are
1a00: 20 41 53 43 49 49 0a 3b 3b 20 20 20 2a 20 75 73 ASCII.;; * us
1a10: 65 73 20 28 45 56 41 4c 20 2e 2e 2e 20 28 53 43 es (EVAL ... (SC
1a20: 48 45 4d 45 2d 52 45 50 4f 52 54 2d 45 4e 56 49 HEME-REPORT-ENVI
1a30: 52 4f 4e 4d 45 4e 54 20 35 29 29 0a 3b 3b 20 20 RONMENT 5)).;;
1a40: 20 20 20 69 6e 20 6f 6e 65 20 70 6c 61 63 65 20 in one place
1a50: 6f 6e 20 73 69 6d 70 6c 65 20 61 72 69 74 68 6d on simple arithm
1a60: 65 74 69 63 20 65 78 70 72 65 73 73 69 6f 6e 73 etic expressions
1a70: 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ..;;;;;;;;;;;;;;
1a80: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1a90: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1aa0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1ab0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 20 74 68 ;;;;;;;;;;.;; th
1ac0: 69 73 20 62 69 74 20 69 73 6e 27 74 20 70 6f 72 is bit isn't por
1ad0: 74 61 62 6c 65 0a 0a 28 64 65 66 69 6e 65 20 6e table..(define n
1ae0: 75 6c 6c 2d 63 68 20 28 69 6e 74 65 67 65 72 2d ull-ch (integer-
1af0: 3e 63 68 61 72 20 30 29 29 0a 28 64 65 66 69 6e >char 0)).(defin
1b00: 65 20 6e 75 6c 6c 2d 73 74 72 20 28 73 74 72 69 e null-str (stri
1b10: 6e 67 20 28 69 6e 74 65 67 65 72 2d 3e 63 68 61 ng (integer->cha
1b20: 72 20 30 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b r 0)))..;;;;;;;;
1b30: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1b40: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1b50: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1b60: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1b70: 0a 3b 3b 20 6c 69 73 74 20 75 74 69 6c 73 20 28 .;; list utils (
1b80: 66 72 6f 6d 20 47 61 75 63 68 65 27 73 20 75 74 from Gauche's ut
1b90: 69 6c 2e 63 6f 6d 62 69 6e 61 74 69 6f 6e 73 29 il.combinations)
1ba0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 61 72 74 65 ..(define (carte
1bb0: 73 69 61 6e 2d 70 72 6f 64 75 63 74 20 6c 6f 6c sian-product lol
1bc0: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c ). (if (null? l
1bd0: 6f 6c 29 0a 20 20 20 20 28 6c 69 73 74 20 27 28 ol). (list '(
1be0: 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 6c 20 )). (let ((l
1bf0: 28 63 61 72 20 6c 6f 6c 29 29 0a 20 20 20 20 20 (car lol)).
1c00: 20 20 20 20 20 28 72 65 73 74 20 28 63 61 72 74 (rest (cart
1c10: 65 73 69 61 6e 2d 70 72 6f 64 75 63 74 20 28 63 esian-product (c
1c20: 64 72 20 6c 6f 6c 29 29 29 29 0a 20 20 20 20 20 dr lol)))).
1c30: 20 28 61 70 70 65 6e 64 2d 6d 61 70 0a 20 20 20 (append-map.
1c40: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 0a (lambda (x).
1c50: 20 20 20 20 20 20 20 20 20 28 6d 61 70 20 28 6c (map (l
1c60: 61 6d 62 64 61 20 28 73 75 62 2d 70 72 6f 64 29 ambda (sub-prod)
1c70: 20 28 63 6f 6e 73 20 78 20 73 75 62 2d 70 72 6f (cons x sub-pro
1c80: 64 29 29 20 72 65 73 74 29 29 0a 20 20 20 20 20 d)) rest)).
1c90: 20 20 6c 29 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b l))))..;;;;;;;
1ca0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1cb0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1cc0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1cd0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
1ce0: 3b 0a 3b 3b 20 6d 69 6d 65 20 75 74 69 6c 73 20 ;.;; mime utils
1cf0: 28 66 72 6f 6d 20 68 61 74 6f 29 0a 28 64 65 66 (from hato).(def
1d00: 69 6e 65 20 28 72 66 63 38 32 32 2d 72 65 61 64 ine (rfc822-read
1d10: 2d 68 65 61 64 65 72 73 20 69 6e 29 0a 20 20 28 -headers in). (
1d20: 6c 65 74 20 6d 6f 72 65 20 28 5b 6c 69 6e 65 20 let more ([line
1d30: 28 72 65 61 64 2d 6c 69 6e 65 20 69 6e 29 5d 29 (read-line in)])
1d40: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
1d50: 28 28 6f 72 20 28 65 6f 66 2d 6f 62 6a 65 63 74 ((or (eof-object
1d60: 3f 20 6c 69 6e 65 29 20 28 73 74 72 69 6e 67 2d ? line) (string-
1d70: 6e 75 6c 6c 3f 20 6c 69 6e 65 29 29 0a 20 20 20 null? line)).
1d80: 20 20 20 27 28 29 29 0a 20 20 20 20 20 28 28 6c '()). ((l
1d90: 65 74 20 28 5b 63 6f 6e 74 20 28 70 65 65 6b 2d et ([cont (peek-
1da0: 63 68 61 72 20 69 6e 29 5d 29 0a 09 28 61 6e 64 char in)])..(and
1db0: 20 28 6e 6f 74 20 28 6f 72 20 28 65 6f 66 2d 6f (not (or (eof-o
1dc0: 62 6a 65 63 74 3f 20 63 6f 6e 74 29 20 28 6d 65 bject? cont) (me
1dd0: 6d 76 20 63 6f 6e 74 20 27 28 23 5c 72 65 74 75 mv cont '(#\retu
1de0: 72 6e 20 23 5c 6e 65 77 6c 69 6e 65 29 29 29 29 rn #\newline))))
1df0: 0a 09 20 20 20 20 20 28 63 68 61 72 2d 77 68 69 .. (char-whi
1e00: 74 65 73 70 61 63 65 3f 20 63 6f 6e 74 29 29 29 tespace? cont)))
1e10: 0a 20 20 20 20 20 20 28 6d 6f 72 65 20 28 73 74 . (more (st
1e20: 72 69 6e 67 2d 61 70 70 65 6e 64 20 6c 69 6e 65 ring-append line
1e30: 20 28 72 65 61 64 2d 6c 69 6e 65 20 69 6e 29 29 (read-line in))
1e40: 29 29 0a 20 20 20 20 20 28 28 73 74 72 69 6e 67 )). ((string
1e50: 2d 6d 61 74 63 68 20 22 28 2e 2a 3f 29 5c 5c 73 -match "(.*?)\\s
1e60: 2a 3a 5c 5c 73 2a 28 2e 2a 29 22 20 6c 69 6e 65 *:\\s*(.*)" line
1e70: 29 0a 20 20 20 20 20 20 3d 3e 20 28 6c 61 6d 62 ). => (lamb
1e80: 64 61 20 28 6d 61 74 63 68 29 0a 09 20 20 20 28 da (match).. (
1e90: 63 6f 6e 73 20 28 63 6f 6e 73 20 28 73 74 72 69 cons (cons (stri
1ea0: 6e 67 2d 64 6f 77 6e 63 61 73 65 20 28 73 74 72 ng-downcase (str
1eb0: 69 6e 67 2d 74 72 69 6d 20 28 63 61 64 72 20 6d ing-trim (cadr m
1ec0: 61 74 63 68 29 29 29 0a 09 09 20 20 20 20 20 20 atch)))...
1ed0: 20 28 63 64 64 72 20 6d 61 74 63 68 29 29 0a 09 (cddr match))..
1ee0: 09 20 28 72 66 63 38 32 32 2d 72 65 61 64 2d 68 . (rfc822-read-h
1ef0: 65 61 64 65 72 73 20 69 6e 29 29 29 29 0a 20 20 eaders in)))).
1f00: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 (else. (
1f10: 72 66 63 38 32 32 2d 72 65 61 64 2d 68 65 61 64 rfc822-read-head
1f20: 65 72 73 20 69 6e 29 29 29 29 29 0a 0a 28 64 65 ers in)))))..(de
1f30: 66 69 6e 65 20 28 6d 69 6d 65 2d 73 70 6c 69 74 fine (mime-split
1f40: 2d 6e 61 6d 65 2b 76 61 6c 75 65 20 73 29 0a 20 -name+value s).
1f50: 20 28 6c 65 74 20 28 28 69 20 28 73 74 72 69 6e (let ((i (strin
1f60: 67 2d 69 6e 64 65 78 20 73 20 23 5c 3d 29 29 29 g-index s #\=)))
1f70: 0a 20 20 20 20 28 69 66 20 69 0a 20 20 20 20 20 . (if i.
1f80: 20 20 20 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 (cons (string
1f90: 2d 64 6f 77 6e 63 61 73 65 20 28 73 74 72 69 6e -downcase (strin
1fa0: 67 2d 74 72 69 6d 2d 62 6f 74 68 20 28 73 75 62 g-trim-both (sub
1fb0: 73 74 72 69 6e 67 20 73 20 30 20 69 29 29 29 0a string s 0 i))).
1fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
1fd0: 66 20 28 3d 20 69 20 28 73 74 72 69 6e 67 2d 6c f (= i (string-l
1fe0: 65 6e 67 74 68 20 73 29 29 0a 20 20 20 20 20 20 ength s)).
1ff0: 20 20 20 20 20 20 20 20 20 20 20 20 22 22 0a 20 "".
2000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2010: 20 28 69 66 20 28 65 71 76 3f 20 23 5c 22 20 28 (if (eqv? #\" (
2020: 73 74 72 69 6e 67 2d 72 65 66 20 73 20 28 2b 20 string-ref s (+
2030: 69 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 i 1))).
2040: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 75 (su
2050: 62 73 74 72 69 6e 67 2f 73 68 61 72 65 64 20 73 bstring/shared s
2060: 20 28 2b 20 69 20 32 29 20 28 2d 20 28 73 74 72 (+ i 2) (- (str
2070: 69 6e 67 2d 6c 65 6e 67 74 68 20 73 29 20 32 29 ing-length s) 2)
2080: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2090: 20 20 20 20 20 20 20 20 28 73 75 62 73 74 72 69 (substri
20a0: 6e 67 2f 73 68 61 72 65 64 20 73 20 28 2b 20 69 ng/shared s (+ i
20b0: 20 31 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 1))))).
20c0: 28 63 6f 6e 73 20 28 73 74 72 69 6e 67 2d 64 6f (cons (string-do
20d0: 77 6e 63 61 73 65 20 28 73 74 72 69 6e 67 2d 74 wncase (string-t
20e0: 72 69 6d 2d 62 6f 74 68 20 73 29 29 20 23 66 29 rim-both s)) #f)
20f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d 69 )))..(define (mi
2100: 6d 65 2d 70 61 72 73 65 2d 63 6f 6e 74 65 6e 74 me-parse-content
2110: 2d 74 79 70 65 20 73 74 72 29 0a 20 20 28 6d 61 -type str). (ma
2120: 70 20 6d 69 6d 65 2d 73 70 6c 69 74 2d 6e 61 6d p mime-split-nam
2130: 65 2b 76 61 6c 75 65 20 28 73 74 72 69 6e 67 2d e+value (string-
2140: 73 70 6c 69 74 20 73 74 72 20 22 3b 22 29 29 29 split str ";")))
2150: 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ..;;;;;;;;;;;;;;
2160: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2170: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2180: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2190: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 20 62 69 ;;;;;;;;;;.;; bi
21a0: 6e 61 72 79 20 49 2f 4f 20 75 74 69 6c 73 20 28 nary I/O utils (
21b0: 66 72 6f 6d 20 53 52 46 49 2d 35 36 29 0a 0a 28 from SRFI-56)..(
21c0: 64 65 66 69 6e 65 20 28 72 65 61 64 2d 62 69 6e define (read-bin
21d0: 61 72 79 2d 75 69 6e 74 33 32 2d 6c 65 20 69 6e ary-uint32-le in
21e0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 62 31 20 28 ). (let* ((b1 (
21f0: 72 65 61 64 2d 62 79 74 65 20 69 6e 29 29 0a 20 read-byte in)).
2200: 20 20 20 20 20 20 20 20 28 62 32 20 28 72 65 61 (b2 (rea
2210: 64 2d 62 79 74 65 20 69 6e 29 29 0a 20 20 20 20 d-byte in)).
2220: 20 20 20 20 20 28 62 33 20 28 72 65 61 64 2d 62 (b3 (read-b
2230: 79 74 65 20 69 6e 29 29 0a 20 20 20 20 20 20 20 yte in)).
2240: 20 20 28 62 34 20 28 72 65 61 64 2d 62 79 74 65 (b4 (read-byte
2250: 20 69 6e 29 29 29 0a 20 20 20 20 28 69 66 20 28 in))). (if (
2260: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 62 34 29 0a eof-object? b4).
2270: 20 20 20 20 20 20 20 20 62 34 0a 20 20 20 20 20 b4.
2280: 20 20 20 28 2b 20 28 61 72 69 74 68 6d 65 74 69 (+ (arithmeti
2290: 63 2d 73 68 69 66 74 20 62 34 20 32 34 29 0a 20 c-shift b4 24).
22a0: 20 20 20 20 20 20 20 20 20 20 28 61 72 69 74 68 (arith
22b0: 6d 65 74 69 63 2d 73 68 69 66 74 20 62 33 20 31 metic-shift b3 1
22c0: 36 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 61 6). (a
22d0: 72 69 74 68 6d 65 74 69 63 2d 73 68 69 66 74 20 rithmetic-shift
22e0: 62 32 20 38 29 0a 20 20 20 20 20 20 20 20 20 20 b2 8).
22f0: 20 62 31 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 b1))))..(define
2300: 20 28 72 65 61 64 2d 62 69 6e 61 72 79 2d 75 69 (read-binary-ui
2310: 6e 74 33 32 2d 62 65 20 69 6e 29 0a 20 20 28 6c nt32-be in). (l
2320: 65 74 2a 20 28 28 62 31 20 28 72 65 61 64 2d 62 et* ((b1 (read-b
2330: 79 74 65 20 69 6e 29 29 0a 20 20 20 20 20 20 20 yte in)).
2340: 20 20 28 62 32 20 28 72 65 61 64 2d 62 79 74 65 (b2 (read-byte
2350: 20 69 6e 29 29 0a 20 20 20 20 20 20 20 20 20 28 in)). (
2360: 62 33 20 28 72 65 61 64 2d 62 79 74 65 20 69 6e b3 (read-byte in
2370: 29 29 0a 20 20 20 20 20 20 20 20 20 28 62 34 20 )). (b4
2380: 28 72 65 61 64 2d 62 79 74 65 20 69 6e 29 29 29 (read-byte in)))
2390: 0a 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 . (if (eof-ob
23a0: 6a 65 63 74 3f 20 62 34 29 0a 20 20 20 20 20 20 ject? b4).
23b0: 20 20 62 34 0a 20 20 20 20 20 20 20 20 28 2b 20 b4. (+
23c0: 28 61 72 69 74 68 6d 65 74 69 63 2d 73 68 69 66 (arithmetic-shif
23d0: 74 20 62 31 20 32 34 29 0a 20 20 20 20 20 20 20 t b1 24).
23e0: 20 20 20 20 28 61 72 69 74 68 6d 65 74 69 63 2d (arithmetic-
23f0: 73 68 69 66 74 20 62 32 20 31 36 29 0a 20 20 20 shift b2 16).
2400: 20 20 20 20 20 20 20 20 28 61 72 69 74 68 6d 65 (arithme
2410: 74 69 63 2d 73 68 69 66 74 20 62 33 20 38 29 0a tic-shift b3 8).
2420: 20 20 20 20 20 20 20 20 20 20 20 62 34 29 29 29 b4)))
2430: 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b )..;;;;;;;;;;;;;
2440: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2450: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2460: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2470: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 20 43 ;;;;;;;;;;;.;; C
2480: 75 73 74 6f 6d 69 7a 65 20 74 68 69 73 20 74 6f ustomize this to
2490: 20 74 68 65 20 61 70 70 72 6f 70 72 69 61 74 65 the appropriate
24a0: 20 76 61 6c 75 65 20 66 6f 72 20 79 6f 75 72 20 value for your
24b0: 73 79 73 74 65 6d 3a 0a 0a 3b 28 64 65 66 69 6e system:..;(defin
24c0: 65 20 6d 65 73 73 61 67 65 2d 70 61 74 68 20 28 e message-path (
24d0: 6c 69 73 74 20 28 6d 61 6b 65 2d 70 61 74 68 6e list (make-pathn
24e0: 61 6d 65 20 28 72 65 70 6f 73 69 74 6f 72 79 2d ame (repository-
24f0: 70 61 74 68 29 20 22 6c 6f 63 61 6c 65 22 29 29 path) "locale"))
2500: 29 0a 28 64 65 66 69 6e 65 20 6d 65 73 73 61 67 ).(define messag
2510: 65 2d 70 61 74 68 20 28 6d 61 6b 65 2d 70 61 72 e-path (make-par
2520: 61 6d 65 74 65 72 20 28 6c 69 73 74 20 22 2f 75 ameter (list "/u
2530: 73 72 2f 73 68 61 72 65 2f 6c 6f 63 61 6c 65 22 sr/share/locale"
2540: 29 29 29 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ))).;;;;;;;;;;;;
2550: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2560: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2570: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2580: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 20 ;;;;;;;;;;;;.;;
2590: 73 74 6f 72 65 20 6d 65 74 61 20 69 6e 66 6f 20 store meta info
25a0: 66 6f 72 20 67 65 74 74 65 78 74 20 66 69 6c 65 for gettext file
25b0: 73 0a 0a 28 64 65 66 69 6e 65 2d 72 65 63 6f 72 s..(define-recor
25c0: 64 2d 74 79 70 65 20 28 67 66 69 6c 65 20 25 6d d-type (gfile %m
25d0: 61 6b 65 2d 67 66 69 6c 65 20 67 66 69 6c 65 3f ake-gfile gfile?
25e0: 29 0a 20 20 28 66 69 65 6c 64 73 0a 20 20 20 28 ). (fields. (
25f0: 69 6d 6d 75 74 61 62 6c 65 20 66 69 6c 65 6e 61 immutable filena
2600: 6d 65 20 67 66 69 6c 65 2d 66 69 6c 65 6e 61 6d me gfile-filenam
2610: 65 29 0a 20 20 20 28 69 6d 6d 75 74 61 62 6c 65 e). (immutable
2620: 20 6c 6f 63 61 6c 65 20 67 66 69 6c 65 2d 6c 6f locale gfile-lo
2630: 63 61 6c 65 29 0a 20 20 20 28 69 6d 6d 75 74 61 cale). (immuta
2640: 62 6c 65 20 65 6e 63 6f 64 69 6e 67 20 67 66 69 ble encoding gfi
2650: 6c 65 2d 65 6e 63 6f 64 69 6e 67 29 0a 20 20 20 le-encoding).
2660: 28 69 6d 6d 75 74 61 62 6c 65 20 70 72 6f 70 65 (immutable prope
2670: 72 74 69 65 73 20 67 66 69 6c 65 2d 70 72 6f 70 rties gfile-prop
2680: 65 72 74 69 65 73 29 0a 20 20 20 28 69 6d 6d 75 erties). (immu
2690: 74 61 62 6c 65 20 74 79 70 65 20 67 66 69 6c 65 table type gfile
26a0: 2d 74 79 70 65 29 0a 20 20 20 28 69 6d 6d 75 74 -type). (immut
26b0: 61 62 6c 65 20 70 6c 75 72 61 6c 2d 69 6e 64 65 able plural-inde
26c0: 78 20 67 66 69 6c 65 2d 70 6c 75 72 61 6c 2d 69 x gfile-plural-i
26d0: 6e 64 65 78 29 29 29 0a 0a 28 64 65 66 69 6e 65 ndex)))..(define
26e0: 20 28 6d 61 6b 65 2d 67 65 74 74 65 78 74 2d 66 (make-gettext-f
26f0: 69 6c 65 20 66 69 6c 65 6e 61 6d 65 20 6c 6f 63 ile filename loc
2700: 61 6c 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 ale). (let* ((f
2710: 69 6c 65 2d 74 79 70 65 20 28 69 66 20 28 73 74 ile-type (if (st
2720: 72 69 6e 67 2d 73 75 66 66 69 78 3f 20 22 2e 6d ring-suffix? ".m
2730: 6f 22 20 66 69 6c 65 6e 61 6d 65 29 20 27 6d 6f o" filename) 'mo
2740: 20 27 70 6f 29 29 0a 20 20 20 20 20 20 20 20 20 'po)).
2750: 28 70 72 6f 70 65 72 74 79 2d 6d 73 67 20 28 6c (property-msg (l
2760: 6f 6f 6b 75 70 2d 6d 65 73 73 61 67 65 20 66 69 ookup-message fi
2770: 6c 65 6e 61 6d 65 20 22 22 20 22 75 74 66 38 22 lename "" "utf8"
2780: 29 29 0a 20 20 20 20 20 20 20 20 20 28 70 72 6f )). (pro
2790: 70 65 72 74 69 65 73 20 28 69 66 20 70 72 6f 70 perties (if prop
27a0: 65 72 74 79 2d 6d 73 67 0a 20 20 20 20 20 20 20 erty-msg.
27b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27c0: 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d 69 6e 70 (call-with-inp
27d0: 75 74 2d 73 74 72 69 6e 67 20 70 72 6f 70 65 72 ut-string proper
27e0: 74 79 2d 6d 73 67 0a 20 20 20 20 20 20 20 20 20 ty-msg.
27f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2800: 20 20 72 66 63 38 32 32 2d 72 65 61 64 2d 68 65 rfc822-read-he
2810: 61 64 65 72 73 29 0a 20 20 20 20 20 20 20 20 20 aders).
2820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2830: 27 28 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 '())). (
2840: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 0a 20 20 20 content-type.
2850: 20 20 20 20 20 20 20 28 6d 69 6d 65 2d 70 61 72 (mime-par
2860: 73 65 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 0a se-content-type.
2870: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 (cond
2880: 20 28 28 61 73 73 6f 63 20 22 63 6f 6e 74 65 6e ((assoc "conten
2890: 74 2d 74 79 70 65 22 20 70 72 6f 70 65 72 74 69 t-type" properti
28a0: 65 73 29 20 3d 3e 20 63 61 64 72 29 0a 20 20 20 es) => cadr).
28b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
28c0: 6c 73 65 20 22 22 29 29 29 29 0a 20 20 20 20 20 lse "")))).
28d0: 20 20 20 20 28 65 6e 63 6f 64 69 6e 67 0a 20 20 (encoding.
28e0: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 20 28 28 (cond ((
28f0: 61 73 73 6f 63 20 22 63 68 61 72 73 65 74 22 20 assoc "charset"
2900: 63 6f 6e 74 65 6e 74 2d 74 79 70 65 29 20 3d 3e content-type) =>
2910: 20 63 64 72 29 0a 20 20 20 20 20 20 20 20 20 20 cdr).
2920: 20 20 20 20 20 20 28 65 6c 73 65 20 22 75 74 66 (else "utf
2930: 38 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 8"))). (
2940: 70 6c 75 72 61 6c 2d 69 6e 64 65 78 0a 20 20 20 plural-index.
2950: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 (cond.
2960: 20 20 20 20 20 20 20 20 20 28 28 61 73 73 6f 63 ((assoc
2970: 20 22 70 6c 75 72 61 6c 2d 66 6f 72 6d 73 22 20 "plural-forms"
2980: 70 72 6f 70 65 72 74 69 65 73 29 0a 20 20 20 20 properties).
2990: 20 20 20 20 20 20 20 20 20 3d 3e 20 28 6c 61 6d => (lam
29a0: 62 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 bda (x).
29b0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
29c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29d0: 20 20 20 20 28 28 61 73 73 6f 63 20 22 70 6c 75 ((assoc "plu
29e0: 72 61 6c 22 20 28 6d 69 6d 65 2d 70 61 72 73 65 ral" (mime-parse
29f0: 2d 63 6f 6e 74 65 6e 74 2d 74 79 70 65 20 28 63 -content-type (c
2a00: 61 64 72 20 78 29 29 29 0a 20 20 20 20 20 20 20 adr x))).
2a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3d 3e =>
2a20: 20 28 6c 61 6d 62 64 61 20 28 78 29 20 28 43 2d (lambda (x) (C-
2a30: 3e 53 63 68 65 6d 65 20 28 63 64 72 20 78 29 29 >Scheme (cdr x))
2a40: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2a50: 20 20 20 20 20 20 20 28 65 6c 73 65 20 28 6c 61 (else (la
2a60: 6d 62 64 61 20 28 6e 29 20 30 29 29 29 29 29 0a mbda (n) 0))))).
2a70: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
2a80: 65 20 28 6c 61 6d 62 64 61 20 28 6e 29 20 30 29 e (lambda (n) 0)
2a90: 29 29 29 29 0a 20 20 20 20 28 25 6d 61 6b 65 2d )))). (%make-
2aa0: 67 66 69 6c 65 20 66 69 6c 65 6e 61 6d 65 20 6c gfile filename l
2ab0: 6f 63 61 6c 65 20 65 6e 63 6f 64 69 6e 67 20 70 ocale encoding p
2ac0: 72 6f 70 65 72 74 69 65 73 20 66 69 6c 65 2d 74 roperties file-t
2ad0: 79 70 65 20 70 6c 75 72 61 6c 2d 69 6e 64 65 78 ype plural-index
2ae0: 29 29 29 0a 0a 3b 3b 20 74 61 6b 65 20 61 20 6c )))..;; take a l
2af0: 69 73 74 20 6f 72 20 61 20 73 69 6e 67 6c 65 20 ist or a single
2b00: 61 72 67 75 6d 65 6e 74 20 77 68 69 63 68 20 69 argument which i
2b10: 73 20 69 6e 74 65 72 70 72 65 74 74 65 64 20 61 s interpretted a
2b20: 73 20 61 20 6f 6e 65 0a 3b 3b 20 65 6c 65 6d 65 s a one.;; eleme
2b30: 6e 74 20 6c 69 73 74 0a 28 64 65 66 69 6e 65 20 nt list.(define
2b40: 28 6c 69 73 74 69 66 79 20 61 72 67 29 0a 20 20 (listify arg).
2b50: 28 69 66 20 28 6f 72 20 28 70 61 69 72 3f 20 61 (if (or (pair? a
2b60: 72 67 29 20 28 6e 75 6c 6c 3f 20 61 72 67 29 29 rg) (null? arg))
2b70: 20 61 72 67 20 28 6c 69 73 74 20 61 72 67 29 29 arg (list arg))
2b80: 29 0a 0a 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b )..;;;;;;;;;;;;;
2b90: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2ba0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2bb0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
2bc0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 0a 3b 3b 20 74 ;;;;;;;;;;;.;; t
2bd0: 68 65 20 64 65 66 61 75 6c 74 20 67 65 74 74 65 he default gette
2be0: 78 74 20 6c 6f 6f 6b 75 70 0a 0a 28 64 65 66 69 xt lookup..(defi
2bf0: 6e 65 20 64 6f 6d 61 69 6e 2d 6d 65 73 73 61 67 ne domain-messag
2c00: 65 2d 70 61 74 68 73 20 28 6d 61 6b 65 2d 68 61 e-paths (make-ha
2c10: 73 68 2d 74 61 62 6c 65 29 29 0a 0a 28 64 65 66 sh-table))..(def
2c20: 69 6e 65 20 64 65 66 61 75 6c 74 2d 67 65 74 74 ine default-gett
2c30: 65 78 74 2d 6c 6f 6f 6b 75 70 20 28 6d 61 6b 65 ext-lookup (make
2c40: 2d 70 61 72 61 6d 65 74 65 72 20 23 66 29 29 0a -parameter #f)).
2c50: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 74 65 78 .(define (gettex
2c60: 74 2d 6c 6f 6f 6b 75 70 29 0a 20 20 28 69 66 20 t-lookup). (if
2c70: 28 64 65 66 61 75 6c 74 2d 67 65 74 74 65 78 74 (default-gettext
2c80: 2d 6c 6f 6f 6b 75 70 29 0a 20 20 20 20 20 20 28 -lookup). (
2c90: 64 65 66 61 75 6c 74 2d 67 65 74 74 65 78 74 2d default-gettext-
2ca0: 6c 6f 6f 6b 75 70 29 0a 20 20 20 20 20 20 28 65 lookup). (e
2cb0: 72 72 6f 72 66 20 27 67 65 74 74 65 78 74 2d 6c rrorf 'gettext-l
2cc0: 6f 6f 6b 75 70 20 22 64 65 66 61 75 6c 74 2d 67 ookup "default-g
2cd0: 65 74 74 65 78 74 2d 6c 6f 6f 6b 75 70 20 75 6e ettext-lookup un
2ce0: 64 65 66 69 6e 65 64 21 20 79 6f 75 20 73 68 6f defined! you sho
2cf0: 75 6c 64 20 63 61 6c 6c 20 74 65 78 74 64 6f 6d uld call textdom
2d00: 61 69 6e 20 66 69 72 73 74 21 22 29 29 29 0a 0a ain first!")))..
2d10: 28 64 65 66 69 6e 65 20 28 67 65 74 74 65 78 74 (define (gettext
2d20: 20 6d 73 67 69 64 29 0a 20 20 28 28 67 65 74 74 msgid). ((gett
2d30: 65 78 74 2d 6c 6f 6f 6b 75 70 29 20 27 67 65 74 ext-lookup) 'get
2d40: 20 6d 73 67 69 64 29 29 0a 28 64 65 66 69 6e 65 msgid)).(define
2d50: 20 28 64 67 65 74 74 65 78 74 20 64 6f 6d 61 69 (dgettext domai
2d60: 6e 20 6d 73 67 69 64 29 0a 20 20 28 28 6d 61 6b n msgid). ((mak
2d70: 65 2d 67 65 74 74 65 78 74 20 64 6f 6d 61 69 6e e-gettext domain
2d80: 29 20 27 67 65 74 20 6d 73 67 69 64 29 29 0a 28 ) 'get msgid)).(
2d90: 64 65 66 69 6e 65 20 28 64 63 67 65 74 74 65 78 define (dcgettex
2da0: 74 20 64 6f 6d 61 69 6e 20 6d 73 67 69 64 20 6c t domain msgid l
2db0: 6f 63 61 6c 65 29 0a 20 20 28 28 6d 61 6b 65 2d ocale). ((make-
2dc0: 67 65 74 74 65 78 74 20 64 6f 6d 61 69 6e 20 28 gettext domain (
2dd0: 6c 69 73 74 20 6c 6f 63 61 6c 65 29 29 20 27 67 list locale)) 'g
2de0: 65 74 20 6d 73 67 69 64 29 29 0a 0a 3b 3b 20 70 et msgid))..;; p
2df0: 6c 75 72 61 6c 20 66 6f 72 6d 73 0a 28 64 65 66 lural forms.(def
2e00: 69 6e 65 20 28 6e 67 65 74 74 65 78 74 20 2e 20 ine (ngettext .
2e10: 6f 70 74 29 0a 20 20 28 61 70 70 6c 79 20 28 67 opt). (apply (g
2e20: 65 74 74 65 78 74 2d 6c 6f 6f 6b 75 70 29 20 27 ettext-lookup) '
2e30: 6e 67 65 74 20 6f 70 74 29 29 0a 28 64 65 66 69 nget opt)).(defi
2e40: 6e 65 20 28 64 6e 67 65 74 74 65 78 74 20 64 6f ne (dngettext do
2e50: 6d 61 69 6e 20 2e 20 6f 70 74 29 0a 20 20 28 61 main . opt). (a
2e60: 70 70 6c 79 20 28 6d 61 6b 65 2d 67 65 74 74 65 pply (make-gette
2e70: 78 74 20 64 6f 6d 61 69 6e 29 20 27 6e 67 65 74 xt domain) 'nget
2e80: 20 6f 70 74 29 29 0a 28 64 65 66 69 6e 65 20 28 opt)).(define (
2e90: 64 63 6e 67 65 74 74 65 78 74 20 64 6f 6d 61 69 dcngettext domai
2ea0: 6e 20 6d 73 67 69 64 20 6c 6f 63 61 6c 65 20 2e n msgid locale .
2eb0: 20 6f 70 74 29 0a 20 20 28 61 70 70 6c 79 20 28 opt). (apply (
2ec0: 6d 61 6b 65 2d 67 65 74 74 65 78 74 20 64 6f 6d make-gettext dom
2ed0: 61 69 6e 20 28 6c 69 73 74 20 6c 6f 63 61 6c 65 ain (list locale
2ee0: 29 29 20 27 6e 67 65 74 20 6d 73 67 69 64 20 6f )) 'nget msgid o
2ef0: 70 74 29 29 0a 0a 3b 3b 20 62 69 6e 64 20 74 68 pt))..;; bind th
2f00: 65 20 64 65 66 61 75 6c 74 20 64 6f 6d 61 69 6e e default domain
2f10: 0a 28 64 65 66 69 6e 65 20 28 74 65 78 74 64 6f .(define (textdo
2f20: 6d 61 69 6e 20 2e 20 6f 70 74 29 0a 20 20 28 69 main . opt). (i
2f30: 66 20 28 70 61 69 72 3f 20 6f 70 74 29 0a 20 20 f (pair? opt).
2f40: 20 20 28 6c 65 74 20 28 28 61 63 63 65 73 73 6f (let ((accesso
2f50: 72 20 28 61 70 70 6c 79 20 6d 61 6b 65 2d 67 65 r (apply make-ge
2f60: 74 74 65 78 74 20 6f 70 74 29 29 29 0a 20 20 20 ttext opt))).
2f70: 20 20 20 28 64 65 66 61 75 6c 74 2d 67 65 74 74 (default-gett
2f80: 65 78 74 2d 6c 6f 6f 6b 75 70 20 61 63 63 65 73 ext-lookup acces
2f90: 73 6f 72 29 0a 20 20 20 20 20 20 61 63 63 65 73 sor). acces
2fa0: 73 6f 72 29 0a 20 20 20 20 28 28 67 65 74 74 65 sor). ((gette
2fb0: 78 74 2d 6c 6f 6f 6b 75 70 29 20 27 64 6f 6d 61 xt-lookup) 'doma
2fc0: 69 6e 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 in)))..(define (
2fd0: 62 69 6e 64 74 65 78 74 64 6f 6d 61 69 6e 20 64 bindtextdomain d
2fe0: 6f 6d 61 69 6e 20 64 69 72 73 29 0a 20 20 28 68 omain dirs). (h
2ff0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 64 ash-table-set! d
3000: 6f 6d 61 69 6e 2d 6d 65 73 73 61 67 65 2d 70 61 omain-message-pa
3010: 74 68 73 20 64 6f 6d 61 69 6e 20 28 6c 69 73 74 ths domain (list
3020: 69 66 79 20 64 69 72 73 29 29 29 0a 0a 3b 3b 3b ify dirs)))..;;;
3030: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3040: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3050: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3060: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3070: 3b 3b 3b 3b 3b 0a 3b 3b 20 54 68 65 20 67 65 74 ;;;;;.;; The get
3080: 74 65 78 74 20 2e 70 6f 20 70 61 72 73 65 72 2e text .po parser.
3090: 0a 3b 3b 20 20 20 57 65 20 73 65 71 75 65 6e 74 .;; We sequent
30a0: 69 61 6c 6c 79 20 73 63 61 6e 20 61 6c 6c 20 74 ially scan all t
30b0: 68 65 20 2e 70 6f 20 6d 73 67 73 74 72 20 65 6e he .po msgstr en
30c0: 74 72 69 65 73 20 75 6e 74 69 6c 20 74 68 65 20 tries until the
30d0: 6f 6e 65 0a 3b 3b 20 20 20 6d 61 74 63 68 69 6e one.;; matchin
30e0: 67 20 74 68 65 20 6d 73 67 20 73 74 72 69 6e 67 g the msg string
30f0: 20 69 73 20 66 6f 75 6e 64 2e 20 20 54 68 69 73 is found. This
3100: 20 69 73 20 73 6c 6f 77 20 62 75 74 20 6f 6e 6c is slow but onl
3110: 79 20 6d 65 61 6e 74 0a 3b 3b 20 20 20 66 6f 72 y meant.;; for
3120: 20 64 65 76 65 6c 6f 70 6d 65 6e 74 2c 20 73 6f development, so
3130: 20 74 68 61 74 20 79 6f 75 20 63 61 6e 20 71 75 that you can qu
3140: 69 63 6b 6c 79 20 74 65 73 74 20 79 6f 75 72 20 ickly test your
3150: 6d 65 73 73 61 67 65 0a 3b 3b 20 20 20 66 69 6c message.;; fil
3160: 65 73 20 77 69 74 68 6f 75 74 20 63 6f 6d 70 69 es without compi
3170: 6c 69 6e 67 20 74 68 65 6d 20 74 6f 20 2e 6d 6f ling them to .mo
3180: 20 66 69 6c 65 73 2e 0a 0a 28 64 65 66 69 6e 65 files...(define
3190: 20 28 6c 6f 6f 6b 75 70 2d 70 6f 2d 6d 65 73 73 (lookup-po-mess
31a0: 61 67 65 20 66 69 6c 65 20 6d 73 67 20 6d 73 67 age file msg msg
31b0: 32 20 65 6e 63 6f 64 69 6e 67 29 0a 20 20 3b 3b 2 encoding). ;;
31c0: 20 72 65 73 69 73 74 69 6e 67 20 6a 6f 6b 65 73 resisting jokes
31d0: 20 61 62 6f 75 74 20 69 6e 64 69 67 65 6e 74 20 about indigent
31e0: 6d 65 73 73 61 67 65 73 2e 2e 2e 0a 0a 20 20 3b messages..... ;
31f0: 3b 20 67 72 61 62 20 74 68 65 20 32 6e 64 20 73 ; grab the 2nd s
3200: 63 68 65 6d 65 20 6f 62 6a 65 63 74 20 69 6e 20 cheme object in
3210: 61 20 73 74 72 69 6e 67 0a 20 20 28 64 65 66 69 a string. (defi
3220: 6e 65 20 28 74 61 69 6c 2d 73 74 72 20 73 74 72 ne (tail-str str
3230: 29 0a 20 20 20 20 28 63 61 6c 6c 2d 77 69 74 68 ). (call-with
3240: 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 73 74 -input-string st
3250: 72 20 28 6c 61 6d 62 64 61 20 28 70 29 20 28 72 r (lambda (p) (r
3260: 65 61 64 20 70 29 20 28 72 65 61 64 20 70 29 29 ead p) (read p))
3270: 29 29 0a 0a 20 20 3b 3b 20 72 65 61 64 20 61 20 )).. ;; read a
3280: 73 65 71 75 65 6e 63 65 20 6f 66 20 6c 69 6e 65 sequence of line
3290: 73 20 69 6e 20 22 22 20 73 74 61 72 74 69 6e 67 s in "" starting
32a0: 20 77 2f 20 61 6e 20 69 6e 69 74 69 61 6c 20 73 w/ an initial s
32b0: 74 72 69 6e 67 2e 0a 20 20 3b 3b 20 64 6f 65 73 tring.. ;; does
32c0: 6e 27 74 20 61 66 66 65 63 74 20 74 72 61 69 6c n't affect trail
32d0: 69 6e 67 20 6c 69 6e 65 73 2e 0a 20 20 28 64 65 ing lines.. (de
32e0: 66 69 6e 65 20 28 72 65 61 64 2d 73 74 72 20 64 fine (read-str d
32f0: 65 66 61 75 6c 74 29 0a 20 20 20 20 28 6c 65 74 efault). (let
3300: 20 72 65 61 64 65 72 20 28 28 72 65 73 20 28 6c reader ((res (l
3310: 69 73 74 20 64 65 66 61 75 6c 74 29 29 29 0a 20 ist default))).
3320: 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 (cond.
3330: 20 20 20 28 28 61 6e 64 2d 6c 65 74 2a 20 28 28 ((and-let* ((
3340: 63 68 20 28 70 65 65 6b 2d 63 68 61 72 29 29 0a ch (peek-char)).
3350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3360: 20 20 20 20 28 28 65 71 76 3f 20 63 68 20 23 5c ((eqv? ch #\
3370: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
3380: 20 20 20 20 20 20 20 20 28 6c 69 6e 65 20 28 73 (line (s
3390: 74 72 69 6e 67 2d 74 72 69 6d 2d 62 6f 74 68 20 tring-trim-both
33a0: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 20 20 (read-line))).
33b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33c0: 20 20 28 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c (len (string-l
33d0: 65 6e 67 74 68 20 6c 69 6e 65 29 29 0a 20 20 20 ength line)).
33e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
33f0: 20 28 28 61 6e 64 20 28 3e 3d 20 6c 65 6e 20 32 ((and (>= len 2
3400: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3410: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 71 76 (eqv
3420: 3f 20 23 5c 22 20 28 73 74 72 69 6e 67 2d 72 65 ? #\" (string-re
3430: 66 20 6c 69 6e 65 20 30 29 29 0a 20 20 20 20 20 f line 0)).
3440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3450: 20 20 20 20 20 28 65 71 76 3f 20 23 5c 22 20 28 (eqv? #\" (
3460: 73 74 72 69 6e 67 2d 72 65 66 20 6c 69 6e 65 20 string-ref line
3470: 28 2d 20 6c 65 6e 20 31 29 29 29 29 29 29 0a 20 (- len 1)))))).
3480: 20 20 20 20 20 20 20 20 20 20 28 63 61 6c 6c 2d (call-
3490: 77 69 74 68 2d 69 6e 70 75 74 2d 73 74 72 69 6e with-input-strin
34a0: 67 20 6c 69 6e 65 20 72 65 61 64 29 29 0a 20 20 g line read)).
34b0: 20 20 20 20 20 20 20 3d 3e 20 28 6c 61 6d 62 64 => (lambd
34c0: 61 20 28 73 74 72 29 20 28 72 65 61 64 65 72 20 a (str) (reader
34d0: 28 63 6f 6e 73 20 73 74 72 20 72 65 73 29 29 29 (cons str res)))
34e0: 29 0a 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 ). (else
34f0: 28 73 74 72 69 6e 67 2d 63 6f 6e 63 61 74 65 6e (string-concaten
3500: 61 74 65 2d 72 65 76 65 72 73 65 20 72 65 73 29 ate-reverse res)
3510: 29 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 )))).. (define
3520: 28 72 65 61 64 2d 70 6c 75 72 61 6c 20 64 65 66 (read-plural def
3530: 61 75 6c 74 29 0a 20 20 20 20 28 6c 65 74 20 72 ault). (let r
3540: 65 61 64 65 72 20 28 28 72 65 73 20 28 6c 69 73 eader ((res (lis
3550: 74 20 64 65 66 61 75 6c 74 29 29 29 0a 20 20 20 t default))).
3560: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 (cond.
3570: 20 28 28 61 6e 64 2d 6c 65 74 2a 20 28 28 28 65 ((and-let* (((e
3580: 71 76 3f 20 28 70 65 65 6b 2d 63 68 61 72 29 20 qv? (peek-char)
3590: 23 5c 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 #\m)).
35a0: 20 20 20 20 20 20 20 20 20 20 28 6c 69 6e 65 20 (line
35b0: 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 20 20 20 (read-line)).
35c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
35d0: 20 28 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 (len (string-le
35e0: 6e 67 74 68 20 6c 69 6e 65 29 29 0a 20 20 20 20 ngth line)).
35f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3600: 28 28 3e 3d 20 6c 65 6e 20 31 30 29 29 0a 20 20 ((>= len 10)).
3610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3620: 20 20 28 28 73 74 72 69 6e 67 2d 70 72 65 66 69 ((string-prefi
3630: 78 3f 20 22 6d 73 67 73 74 72 5b 22 20 6c 69 6e x? "msgstr[" lin
3640: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
3650: 20 20 20 20 20 20 20 20 28 69 20 28 73 74 72 69 (i (stri
3660: 6e 67 2d 69 6e 64 65 78 20 6c 69 6e 65 20 23 5c ng-index line #\
3670: 5d 20 37 29 29 0a 20 20 20 20 20 20 20 20 20 20 ] 7)).
3680: 20 20 20 20 20 20 20 20 20 20 28 6e 20 28 73 74 (n (st
3690: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 73 75 ring->number (su
36a0: 62 73 74 72 69 6e 67 20 6c 69 6e 65 20 37 20 69 bstring line 7 i
36b0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
36c0: 20 20 20 20 20 20 20 20 28 73 74 72 20 28 63 61 (str (ca
36d0: 6c 6c 2d 77 69 74 68 2d 69 6e 70 75 74 2d 73 74 ll-with-input-st
36e0: 72 69 6e 67 0a 20 20 20 20 20 20 20 20 20 20 20 ring.
36f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3700: 20 20 28 73 75 62 73 74 72 69 6e 67 2f 73 68 61 (substring/sha
3710: 72 65 64 20 6c 69 6e 65 20 28 2b 20 69 20 31 29 red line (+ i 1)
3720: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3730: 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 61 rea
3740: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d)).
3750: 20 20 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 ((string
3760: 3f 20 73 74 72 29 29 29 0a 20 20 20 20 20 20 20 ? str))).
3770: 20 20 20 20 28 63 6f 6e 73 20 6e 20 28 72 65 61 (cons n (rea
3780: 64 2d 73 74 72 20 73 74 72 29 29 29 0a 20 20 20 d-str str))).
3790: 20 20 20 20 20 20 3d 3e 20 28 6c 61 6d 62 64 61 => (lambda
37a0: 20 28 78 29 20 28 72 65 61 64 65 72 20 28 63 6f (x) (reader (co
37b0: 6e 73 20 78 20 72 65 73 29 29 29 29 0a 20 20 20 ns x res)))).
37c0: 20 20 20 20 20 28 65 6c 73 65 20 28 72 65 76 65 (else (reve
37d0: 72 73 65 20 72 65 73 29 29 29 29 29 0a 0a 20 20 rse res)))))..
37e0: 3b 3b 20 72 65 61 64 20 66 72 6f 6d 20 74 68 65 ;; read from the
37f0: 20 66 69 6c 65 20 69 66 20 69 74 20 65 78 69 73 file if it exis
3800: 74 73 0a 20 20 28 61 6e 64 0a 20 20 20 28 66 69 ts. (and. (fi
3810: 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 le-read-access?
3820: 66 69 6c 65 29 0a 20 20 20 28 67 75 61 72 64 0a file). (guard.
3830: 20 20 20 20 28 65 78 6e 20 5b 65 6c 73 65 20 28 (exn [else (
3840: 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 print-error-mess
3850: 61 67 65 20 65 78 6e 20 28 63 75 72 72 65 6e 74 age exn (current
3860: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 0a 09 09 09 -error-port)....
3870: 09 20 20 20 20 22 57 61 72 6e 69 6e 67 3a 20 6c . "Warning: l
3880: 6f 6f 6b 75 70 2d 70 6f 2d 6d 65 73 73 61 67 65 ookup-po-message
3890: 22 20 29 0a 09 20 20 20 20 20 20 20 23 66 5d 29 " ).. #f])
38a0: 0a 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 . (with-input
38b0: 2d 66 72 6f 6d 2d 65 6e 63 6f 64 65 64 2d 66 69 -from-encoded-fi
38c0: 6c 65 0a 20 20 20 20 20 66 69 6c 65 20 65 6e 63 le. file enc
38d0: 6f 64 69 6e 67 0a 20 20 20 20 20 28 6c 61 6d 62 oding. (lamb
38e0: 64 61 20 28 29 0a 20 20 20 20 20 20 20 28 6c 65 da (). (le
38f0: 74 20 73 65 61 72 63 68 20 28 28 6c 69 6e 65 20 t search ((line
3900: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 20 (read-line)))..
3910: 28 63 6f 6e 64 20 28 28 65 6f 66 2d 6f 62 6a 65 (cond ((eof-obje
3920: 63 74 3f 20 6c 69 6e 65 29 20 23 66 29 0a 09 20 ct? line) #f)..
3930: 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 2d 70 ((string-p
3940: 72 65 66 69 78 3f 20 22 6d 73 67 69 64 20 22 20 refix? "msgid "
3950: 6c 69 6e 65 29 0a 09 09 28 6c 65 74 20 28 28 6d line)...(let ((m
3960: 73 67 69 64 20 28 72 65 61 64 2d 73 74 72 20 28 sgid (read-str (
3970: 74 61 69 6c 2d 73 74 72 20 6c 69 6e 65 29 29 29 tail-str line)))
3980: 29 0a 09 09 20 20 28 63 6f 6e 64 20 28 28 73 74 )... (cond ((st
3990: 72 69 6e 67 3d 3f 20 6d 73 67 69 64 20 6d 73 67 ring=? msgid msg
39a0: 29 0a 09 09 09 20 28 6c 65 74 20 6c 70 20 28 28 ).... (let lp ((
39b0: 6c 69 6e 65 20 28 72 65 61 64 2d 6c 69 6e 65 29 line (read-line)
39c0: 29 29 0a 09 09 09 20 20 20 28 63 6f 6e 64 20 28 )).... (cond (
39d0: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 69 6e (eof-object? lin
39e0: 65 29 20 23 66 29 0a 09 09 09 09 20 28 28 73 74 e) #f)..... ((st
39f0: 72 69 6e 67 2d 70 72 65 66 69 78 3f 20 22 6d 73 ring-prefix? "ms
3a00: 67 69 64 5f 70 6c 75 72 61 6c 20 22 20 6c 69 6e gid_plural " lin
3a10: 65 29 0a 09 09 09 09 20 20 28 72 65 61 64 2d 70 e)..... (read-p
3a20: 6c 75 72 61 6c 20 28 72 65 61 64 2d 73 74 72 20 lural (read-str
3a30: 28 74 61 69 6c 2d 73 74 72 20 6c 69 6e 65 29 29 (tail-str line))
3a40: 29 29 0a 09 09 09 09 20 28 28 73 74 72 69 6e 67 ))..... ((string
3a50: 2d 70 72 65 66 69 78 3f 20 22 6d 73 67 73 74 72 -prefix? "msgstr
3a60: 20 22 20 6c 69 6e 65 29 0a 09 09 09 09 20 20 28 " line)..... (
3a70: 72 65 61 64 2d 73 74 72 20 28 74 61 69 6c 2d 73 read-str (tail-s
3a80: 74 72 20 6c 69 6e 65 29 29 29 0a 09 09 09 09 20 tr line))).....
3a90: 28 65 6c 73 65 20 28 6c 70 20 28 72 65 61 64 2d (else (lp (read-
3aa0: 6c 69 6e 65 29 29 29 29 29 29 0a 09 09 09 28 65 line))))))....(e
3ab0: 6c 73 65 20 28 73 65 61 72 63 68 20 28 72 65 61 lse (search (rea
3ac0: 64 2d 6c 69 6e 65 29 29 29 29 29 29 0a 09 20 20 d-line))))))..
3ad0: 20 20 20 20 20 28 65 6c 73 65 20 28 73 65 61 72 (else (sear
3ae0: 63 68 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 ch (read-line)))
3af0: 29 29 29 29 29 29 29 0a 0a 0a 3b 3b 3b 3b 3b 3b )))))))...;;;;;;
3b00: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3b10: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3b20: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3b30: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
3b40: 3b 3b 0a 3b 3b 20 54 68 65 20 67 65 74 74 65 78 ;;.;; The gettex
3b50: 74 20 62 69 6e 61 72 79 20 2e 6d 6f 20 66 69 6c t binary .mo fil
3b60: 65 20 70 61 72 73 65 72 2e 0a 3b 3b 20 20 20 54 e parser..;; T
3b70: 68 65 20 66 6f 72 6d 61 74 20 69 73 20 77 65 6c he format is wel
3b80: 6c 20 64 65 73 63 72 69 62 65 64 20 69 6e 20 74 l described in t
3b90: 68 65 20 47 4e 55 20 67 65 74 74 65 78 74 20 64 he GNU gettext d
3ba0: 6f 63 75 6d 65 6e 74 61 74 69 6f 6e 2e 0a 3b 3b ocumentation..;;
3bb0: 20 20 20 45 73 73 65 6e 74 69 61 6c 6c 79 20 69 Essentially i
3bc0: 74 27 73 20 61 6e 20 69 6e 64 65 78 20 6f 66 20 t's an index of
3bd0: 73 6f 75 72 63 65 20 73 74 72 69 6e 67 73 20 77 source strings w
3be0: 69 74 68 20 6f 66 66 73 65 74 73 20 74 6f 20 74 ith offsets to t
3bf0: 68 65 69 72 0a 3b 3b 20 20 20 74 72 61 6e 73 6c heir.;; transl
3c00: 61 74 69 6f 6e 20 73 74 72 69 6e 67 2c 20 61 6e ation string, an
3c10: 64 20 77 65 20 62 69 6e 61 72 79 20 73 65 61 72 d we binary sear
3c20: 63 68 20 74 68 65 20 69 6e 64 65 78 2e 0a 0a 28 ch the index...(
3c30: 64 65 66 69 6e 65 20 28 6c 6f 6f 6b 75 70 2d 6d define (lookup-m
3c40: 6f 2d 6d 65 73 73 61 67 65 20 66 69 6c 65 20 6d o-message file m
3c50: 73 67 20 6d 73 67 32 20 65 6e 63 6f 64 69 6e 67 sg msg2 encoding
3c60: 29 0a 20 20 28 61 6e 64 0a 20 20 20 28 66 69 6c ). (and. (fil
3c70: 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 66 e-read-access? f
3c80: 69 6c 65 29 0a 20 20 20 28 67 75 61 72 64 0a 20 ile). (guard.
3c90: 20 20 20 28 65 78 6e 20 5b 65 6c 73 65 20 28 70 (exn [else (p
3ca0: 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 rint-error-messa
3cb0: 67 65 20 65 78 6e 20 28 63 75 72 72 65 6e 74 2d ge exn (current-
3cc0: 65 72 72 6f 72 2d 70 6f 72 74 29 0a 09 09 09 09 error-port).....
3cd0: 20 20 20 20 22 57 61 72 6e 69 6e 67 3a 20 6c 6f "Warning: lo
3ce0: 6f 6b 75 70 2d 6d 6f 2d 6d 65 73 73 61 67 65 22 okup-mo-message"
3cf0: 29 0a 09 20 20 20 20 20 20 20 23 66 5d 29 0a 20 ).. #f]).
3d00: 20 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d 70 6f (call-with-po
3d10: 72 74 20 28 6f 70 65 6e 2d 66 69 6c 65 2d 69 6e rt (open-file-in
3d20: 70 75 74 2d 70 6f 72 74 20 66 69 6c 65 29 20 3b put-port file) ;
3d30: 3b 20 6f 70 65 6e 20 69 6e 20 62 69 6e 61 72 79 ; open in binary
3d40: 20 6d 6f 64 65 0a 09 09 20 20 20 20 28 6c 61 6d mode... (lam
3d50: 62 64 61 20 28 70 29 0a 09 09 20 20 20 20 20 20 bda (p)...
3d60: 28 64 65 66 69 6e 65 20 74 63 20 28 73 65 6c 65 (define tc (sele
3d70: 63 74 2d 74 72 61 6e 73 63 6f 64 65 72 20 65 6e ct-transcoder en
3d80: 63 6f 64 69 6e 67 29 29 0a 09 09 20 20 20 20 20 coding))...
3d90: 20 28 64 65 66 69 6e 65 20 28 73 65 61 72 63 68 (define (search
3da0: 20 72 65 61 64 2d 69 6e 74 29 0a 09 09 09 20 28 read-int).... (
3db0: 6c 65 74 2a 20 28 28 6b 65 79 20 28 69 66 20 6d let* ((key (if m
3dc0: 73 67 32 20 28 73 74 72 69 6e 67 2d 61 70 70 65 sg2 (string-appe
3dd0: 6e 64 20 6d 73 67 20 6e 75 6c 6c 2d 73 74 72 20 nd msg null-str
3de0: 6d 73 67 32 29 20 6d 73 67 29 29 0a 09 09 09 09 msg2) msg)).....
3df0: 28 66 6f 72 6d 61 74 20 28 72 65 61 64 2d 69 6e (format (read-in
3e00: 74 20 70 29 29 0a 09 09 09 09 28 63 6f 75 6e 74 t p)).....(count
3e10: 20 28 72 65 61 64 2d 69 6e 74 20 70 29 29 0a 09 (read-int p))..
3e20: 09 09 09 28 73 72 63 2d 6f 66 66 73 65 74 20 28 ...(src-offset (
3e30: 72 65 61 64 2d 69 6e 74 20 70 29 29 0a 09 09 09 read-int p))....
3e40: 09 28 74 72 61 6e 73 2d 6f 66 66 73 65 74 20 28 .(trans-offset (
3e50: 72 65 61 64 2d 69 6e 74 20 70 29 29 0a 09 09 09 read-int p))....
3e60: 09 28 68 61 73 68 2d 73 69 7a 65 20 28 72 65 61 .(hash-size (rea
3e70: 64 2d 69 6e 74 20 70 29 29 0a 09 09 09 09 28 68 d-int p)).....(h
3e80: 61 73 68 2d 6f 66 66 73 65 74 20 28 72 65 61 64 ash-offset (read
3e90: 2d 69 6e 74 20 70 29 29 0a 09 09 09 09 28 64 69 -int p)).....(di
3ea0: 66 66 20 28 2d 20 74 72 61 6e 73 2d 6f 66 66 73 ff (- trans-offs
3eb0: 65 74 20 73 72 63 2d 6f 66 66 73 65 74 29 29 0a et src-offset)).
3ec0: 09 09 09 09 28 65 6e 64 20 28 2b 20 73 72 63 2d ....(end (+ src-
3ed0: 6f 66 66 73 65 74 20 28 2a 20 28 2d 20 63 6f 75 offset (* (- cou
3ee0: 6e 74 20 31 29 20 38 29 29 29 29 0a 09 09 09 20 nt 1) 8))))....
3ef0: 20 20 28 64 65 66 69 6e 65 20 28 73 74 72 69 6e (define (strin
3f00: 67 2d 61 74 20 70 6f 73 29 0a 09 09 09 20 20 20 g-at pos)....
3f10: 20 20 28 66 69 6c 65 2d 70 6f 73 69 74 69 6f 6e (file-position
3f20: 20 70 20 70 6f 73 29 0a 09 09 09 20 20 20 20 20 p pos)....
3f30: 28 6c 65 74 2a 20 28 28 6c 65 6e 20 28 72 65 61 (let* ((len (rea
3f40: 64 2d 69 6e 74 20 70 29 29 0a 09 09 09 09 20 20 d-int p)).....
3f50: 20 20 28 6f 66 66 20 28 72 65 61 64 2d 69 6e 74 (off (read-int
3f60: 20 70 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 p)))....
3f70: 28 66 69 6c 65 2d 70 6f 73 69 74 69 6f 6e 20 70 (file-position p
3f80: 20 6f 66 66 29 0a 09 09 09 20 20 20 20 20 20 20 off)....
3f90: 28 62 79 74 65 76 65 63 74 6f 72 2d 3e 73 74 72 (bytevector->str
3fa0: 69 6e 67 20 28 67 65 74 2d 62 79 74 65 76 65 63 ing (get-bytevec
3fb0: 74 6f 72 2d 6e 20 70 20 6c 65 6e 29 20 74 63 29 tor-n p len) tc)
3fc0: 29 29 0a 09 09 09 20 20 20 28 63 6f 6e 64 20 3b )).... (cond ;
3fd0: 3b 20 63 68 65 63 6b 20 65 6e 64 70 6f 69 6e 74 ; check endpoint
3fe0: 73 0a 09 09 09 20 20 20 20 28 28 73 74 72 69 6e s.... ((strin
3ff0: 67 3d 3f 20 6b 65 79 20 28 73 74 72 69 6e 67 2d g=? key (string-
4000: 61 74 20 73 72 63 2d 6f 66 66 73 65 74 29 29 0a at src-offset)).
4010: 09 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d ... (string-
4020: 61 74 20 28 2b 20 73 72 63 2d 6f 66 66 73 65 74 at (+ src-offset
4030: 20 64 69 66 66 29 29 29 0a 09 09 09 20 20 20 20 diff)))....
4040: 28 28 61 6e 64 20 28 3e 20 65 6e 64 20 73 72 63 ((and (> end src
4050: 2d 6f 66 66 73 65 74 29 20 28 73 74 72 69 6e 67 -offset) (string
4060: 3d 3f 20 6b 65 79 20 28 73 74 72 69 6e 67 2d 61 =? key (string-a
4070: 74 20 65 6e 64 29 29 29 0a 09 09 09 20 20 20 20 t end)))....
4080: 20 28 73 74 72 69 6e 67 2d 61 74 20 28 2b 20 65 (string-at (+ e
4090: 6e 64 20 64 69 66 66 29 29 29 0a 09 09 09 20 20 nd diff)))....
40a0: 20 20 28 65 6c 73 65 20 3b 3b 20 62 69 6e 61 72 (else ;; binar
40b0: 79 20 73 65 61 72 63 68 0a 09 09 09 20 20 20 20 y search....
40c0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 6f 20 (let loop ((lo
40d0: 30 29 20 28 68 69 20 28 2d 20 63 6f 75 6e 74 20 0) (hi (- count
40e0: 31 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 1))).... (
40f0: 69 66 20 28 3e 3d 20 6c 6f 20 68 69 29 0a 09 09 if (>= lo hi)...
4100: 09 09 20 20 20 23 66 0a 09 09 09 09 20 20 20 28 .. #f..... (
4110: 6c 65 74 2a 20 28 28 6d 69 64 20 28 2b 20 6c 6f let* ((mid (+ lo
4120: 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 68 69 (quotient (- hi
4130: 20 6c 6f 29 20 32 29 29 29 0a 09 09 09 09 09 20 lo) 2)))......
4140: 20 28 70 6f 73 20 28 2b 20 73 72 63 2d 6f 66 66 (pos (+ src-off
4150: 73 65 74 20 28 2a 20 6d 69 64 20 38 29 29 29 0a set (* mid 8))).
4160: 09 09 09 09 09 20 20 28 73 74 72 20 28 73 74 72 ..... (str (str
4170: 69 6e 67 2d 61 74 20 70 6f 73 29 29 29 0a 09 09 ing-at pos)))...
4180: 09 09 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 .. (cond....
4190: 09 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3c . ((string<
41a0: 3f 20 6b 65 79 20 73 74 72 29 0a 09 09 09 09 20 ? key str).....
41b0: 20 20 20 20 20 20 28 69 66 20 28 3e 3d 20 6d 69 (if (>= mi
41c0: 64 20 68 69 29 20 23 66 20 28 6c 6f 6f 70 20 6c d hi) #f (loop l
41d0: 6f 20 6d 69 64 29 29 29 0a 09 09 09 09 20 20 20 o mid))).....
41e0: 20 20 20 28 28 73 74 72 69 6e 67 3e 3f 20 6b 65 ((string>? ke
41f0: 79 20 73 74 72 29 0a 09 09 09 09 20 20 20 20 20 y str).....
4200: 20 20 28 69 66 20 28 3c 3d 20 6d 69 64 20 6c 6f (if (<= mid lo
4210: 29 20 23 66 20 28 6c 6f 6f 70 20 6d 69 64 20 68 ) #f (loop mid h
4220: 69 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 i)))..... (
4230: 65 6c 73 65 20 3b 3b 20 6d 61 74 63 68 0a 09 09 else ;; match...
4240: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
4250: 2d 61 74 20 28 2b 20 70 6f 73 20 64 69 66 66 29 -at (+ pos diff)
4260: 29 29 29 29 29 29 29 29 29 29 0a 09 09 20 20 20 ))))))))))...
4270: 20 20 20 20 28 6c 65 74 2a 20 28 28 62 31 20 28 (let* ((b1 (
4280: 72 65 61 64 2d 62 79 74 65 20 70 29 29 0a 09 09 read-byte p))...
4290: 09 20 20 20 20 20 20 28 62 32 20 28 72 65 61 64 . (b2 (read
42a0: 2d 62 79 74 65 20 70 29 29 0a 09 09 09 20 20 20 -byte p))....
42b0: 20 20 20 28 62 33 20 28 72 65 61 64 2d 62 79 74 (b3 (read-byt
42c0: 65 20 70 29 29 0a 09 09 09 20 20 20 20 20 20 28 e p)).... (
42d0: 62 34 20 28 72 65 61 64 2d 62 79 74 65 20 70 29 b4 (read-byte p)
42e0: 29 0a 09 09 09 20 20 20 20 20 20 28 6d 61 67 69 ).... (magi
42f0: 63 20 28 6c 69 73 74 20 62 31 20 62 32 20 62 33 c (list b1 b2 b3
4300: 20 62 34 29 29 29 0a 09 09 09 20 28 63 6f 6e 64 b4))).... (cond
4310: 0a 09 09 09 20 20 28 28 65 71 75 61 6c 3f 20 6d .... ((equal? m
4320: 61 67 69 63 20 27 28 23 78 64 65 20 23 78 31 32 agic '(#xde #x12
4330: 20 23 78 30 34 20 23 78 39 35 29 29 0a 09 09 09 #x04 #x95))....
4340: 20 20 20 28 73 65 61 72 63 68 20 72 65 61 64 2d (search read-
4350: 62 69 6e 61 72 79 2d 75 69 6e 74 33 32 2d 6c 65 binary-uint32-le
4360: 29 29 0a 09 09 09 20 20 28 28 65 71 75 61 6c 3f )).... ((equal?
4370: 20 6d 61 67 69 63 20 27 28 23 78 39 35 20 23 78 magic '(#x95 #x
4380: 30 34 20 23 78 31 32 20 23 78 64 65 29 29 0a 09 04 #x12 #xde))..
4390: 09 09 20 20 20 28 73 65 61 72 63 68 20 72 65 61 .. (search rea
43a0: 64 2d 62 69 6e 61 72 79 2d 75 69 6e 74 33 32 2d d-binary-uint32-
43b0: 62 65 29 29 0a 09 09 09 20 20 28 65 6c 73 65 0a be)).... (else.
43c0: 09 09 09 20 20 20 28 77 61 72 6e 69 6e 67 20 22 ... (warning "
43d0: 69 6e 76 61 6c 69 64 20 2e 6d 6f 20 66 69 6c 65 invalid .mo file
43e0: 20 6d 61 67 69 63 22 20 6d 61 67 69 63 29 0a 09 magic" magic)..
43f0: 09 09 20 20 20 23 66 29 29 29 29 29 29 29 29 0a .. #f)))))))).
4400: 0a 28 64 65 66 69 6e 65 20 28 6c 6f 6f 6b 75 70 .(define (lookup
4410: 2d 6d 65 73 73 61 67 65 20 67 66 69 6c 65 20 6d -message gfile m
4420: 73 67 20 6d 73 67 32 20 2e 20 6f 70 74 29 0a 20 sg msg2 . opt).
4430: 20 28 69 66 20 28 67 66 69 6c 65 3f 20 67 66 69 (if (gfile? gfi
4440: 6c 65 29 0a 20 20 20 20 20 20 28 28 69 66 20 28 le). ((if (
4450: 65 71 3f 20 28 67 66 69 6c 65 2d 74 79 70 65 20 eq? (gfile-type
4460: 67 66 69 6c 65 29 20 27 6d 6f 29 20 6c 6f 6f 6b gfile) 'mo) look
4470: 75 70 2d 6d 6f 2d 6d 65 73 73 61 67 65 20 6c 6f up-mo-message lo
4480: 6f 6b 75 70 2d 70 6f 2d 6d 65 73 73 61 67 65 29 okup-po-message)
4490: 0a 20 20 20 20 20 20 20 28 67 66 69 6c 65 2d 66 . (gfile-f
44a0: 69 6c 65 6e 61 6d 65 20 67 66 69 6c 65 29 0a 20 ilename gfile).
44b0: 20 20 20 20 20 20 6d 73 67 0a 20 20 20 20 20 20 msg.
44c0: 20 6d 73 67 32 0a 20 20 20 20 20 20 20 28 69 66 msg2. (if
44d0: 20 28 70 61 69 72 3f 20 6f 70 74 29 20 28 63 61 (pair? opt) (ca
44e0: 72 20 6f 70 74 29 20 28 67 66 69 6c 65 2d 65 6e r opt) (gfile-en
44f0: 63 6f 64 69 6e 67 20 67 66 69 6c 65 29 29 29 0a coding gfile))).
4500: 20 20 20 20 20 20 28 28 69 66 20 28 73 74 72 69 ((if (stri
4510: 6e 67 2d 73 75 66 66 69 78 3f 20 22 2e 6d 6f 22 ng-suffix? ".mo"
4520: 20 67 66 69 6c 65 29 20 6c 6f 6f 6b 75 70 2d 6d gfile) lookup-m
4530: 6f 2d 6d 65 73 73 61 67 65 20 6c 6f 6f 6b 75 70 o-message lookup
4540: 2d 70 6f 2d 6d 65 73 73 61 67 65 29 0a 20 20 20 -po-message).
4550: 20 20 20 20 67 66 69 6c 65 20 6d 73 67 20 6d 73 gfile msg ms
4560: 67 32 20 28 69 66 20 28 70 61 69 72 3f 20 6f 70 g2 (if (pair? op
4570: 74 29 20 28 63 61 72 20 6f 70 74 29 20 22 75 74 t) (car opt) "ut
4580: 66 38 22 29 29 29 29 0a 0a 3b 3b 3b 3b 3b 3b 3b f8"))))..;;;;;;;
4590: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
45a0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
45b0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
45c0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
45d0: 3b 0a 3b 3b 20 74 68 65 20 73 75 62 73 65 74 20 ;.;; the subset
45e0: 43 20 70 61 72 73 65 72 20 66 6f 72 20 6e 67 65 C parser for nge
45f0: 74 74 65 78 74 20 70 6c 75 72 61 6c 20 66 6f 72 ttext plural for
4600: 6d 73 0a 0a 28 64 65 66 69 6e 65 20 28 43 2d 3e ms..(define (C->
4610: 53 63 68 65 6d 65 20 73 74 72 29 0a 20 20 28 64 Scheme str). (d
4620: 65 66 69 6e 65 20 28 72 65 61 64 2d 6e 75 6d 62 efine (read-numb
4630: 65 72 20 63 29 0a 20 20 20 20 28 6c 65 74 20 6c er c). (let l
4640: 6f 6f 70 20 28 28 6c 73 20 28 6c 69 73 74 20 63 oop ((ls (list c
4650: 29 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 ))). (let (
4660: 28 63 32 20 28 70 65 65 6b 2d 63 68 61 72 29 29 (c2 (peek-char))
4670: 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e 64 20 ). (cond
4680: 28 28 61 6e 64 20 28 6e 6f 74 20 28 65 6f 66 2d ((and (not (eof-
4690: 6f 62 6a 65 63 74 3f 20 63 32 29 29 20 28 63 68 object? c2)) (ch
46a0: 61 72 2d 6e 75 6d 65 72 69 63 3f 20 63 32 29 29 ar-numeric? c2))
46b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
46c0: 28 72 65 61 64 2d 63 68 61 72 29 20 28 6c 6f 6f (read-char) (loo
46d0: 70 20 28 63 6f 6e 73 20 63 32 20 6c 73 29 29 29 p (cons c2 ls)))
46e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
46f0: 65 6c 73 65 20 28 73 74 72 69 6e 67 2d 3e 6e 75 else (string->nu
4700: 6d 62 65 72 20 28 6c 69 73 74 2d 3e 73 74 72 69 mber (list->stri
4710: 6e 67 20 28 72 65 76 65 72 73 65 20 6c 73 29 29 ng (reverse ls))
4720: 29 29 29 29 29 29 0a 20 20 28 64 65 66 69 6e 65 )))))). (define
4730: 20 28 72 65 61 64 2d 63 6f 6d 6d 65 6e 74 29 0a (read-comment).
4740: 20 20 20 20 28 72 65 61 64 2d 63 68 61 72 29 0a (read-char).
4750: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
4760: 63 20 28 72 65 61 64 2d 63 68 61 72 29 29 29 0a c (read-char))).
4770: 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f (if (eof-o
4780: 62 6a 65 63 74 3f 20 63 29 0a 20 20 20 20 20 20 bject? c).
4790: 20 20 20 20 63 20 3b 3b 20 6d 61 79 62 65 20 73 c ;; maybe s
47a0: 69 67 6e 61 6c 20 65 72 72 6f 72 0a 20 20 20 20 ignal error.
47b0: 20 20 20 20 20 20 28 69 66 20 28 65 71 76 3f 20 (if (eqv?
47c0: 63 20 23 5c 2a 29 0a 20 20 20 20 20 20 20 20 20 c #\*).
47d0: 20 20 20 20 20 28 6c 65 74 20 28 28 63 32 20 28 (let ((c2 (
47e0: 72 65 61 64 2d 63 68 61 72 29 29 29 0a 20 20 20 read-char))).
47f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
4800: 20 28 65 71 76 3f 20 63 32 20 23 5c 2f 29 20 23 (eqv? c2 #\/) #
4810: 66 20 28 6c 6f 6f 70 20 63 32 29 29 29 0a 20 20 f (loop c2))).
4820: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
4830: 70 20 28 72 65 61 64 2d 63 68 61 72 29 29 29 29 p (read-char))))
4840: 29 29 0a 20 20 28 64 65 66 69 6e 65 20 28 6e 65 )). (define (ne
4850: 78 74 2d 74 6f 6b 65 6e 29 0a 20 20 20 20 28 6c xt-token). (l
4860: 65 74 20 28 28 63 20 28 72 65 61 64 2d 63 68 61 et ((c (read-cha
4870: 72 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 r))). (if (
4880: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 29 0a 20 eof-object? c).
4890: 20 20 20 20 20 20 20 20 20 63 0a 20 20 20 20 20 c.
48a0: 20 20 20 20 20 28 63 61 73 65 20 63 0a 20 20 20 (case c.
48b0: 20 20 20 20 20 20 20 20 20 28 28 23 5c 28 29 20 ((#\()
48c0: 27 6f 70 65 6e 29 0a 20 20 20 20 20 20 20 20 20 'open).
48d0: 20 20 20 28 28 23 5c 29 29 20 27 63 6c 6f 73 65 ((#\)) 'close
48e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ). ((
48f0: 23 5c 2f 29 20 28 69 66 20 28 65 71 76 3f 20 28 #\/) (if (eqv? (
4900: 70 65 65 6b 2d 63 68 61 72 29 20 23 5c 2a 29 20 peek-char) #\*)
4910: 28 72 65 61 64 2d 63 6f 6d 6d 65 6e 74 29 20 27 (read-comment) '
4920: 2f 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 /)).
4930: 28 28 23 5c 2d 20 23 5c 2b 20 23 5c 2a 20 23 5c ((#\- #\+ #\* #\
4940: 25 20 23 5c 3f 20 23 5c 3a 29 0a 20 20 20 20 20 % #\? #\:).
4950: 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d (string-
4960: 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 20 >symbol (string
4970: 63 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 c))).
4980: 20 28 28 23 5c 26 29 20 28 69 66 20 28 65 71 76 ((#\&) (if (eqv
4990: 3f 20 28 70 65 65 6b 2d 63 68 61 72 29 20 63 29 ? (peek-char) c)
49a0: 20 28 62 65 67 69 6e 20 28 72 65 61 64 2d 63 68 (begin (read-ch
49b0: 61 72 29 20 27 61 6e 64 29 20 27 6c 6f 67 61 6e ar) 'and) 'logan
49c0: 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d)).
49d0: 28 28 23 5c 7c 29 20 28 69 66 20 28 65 71 76 3f ((#\|) (if (eqv?
49e0: 20 28 70 65 65 6b 2d 63 68 61 72 29 20 63 29 20 (peek-char) c)
49f0: 28 62 65 67 69 6e 20 28 72 65 61 64 2d 63 68 61 (begin (read-cha
4a00: 72 29 20 27 6f 72 29 20 27 6c 6f 67 69 6f 72 29 r) 'or) 'logior)
4a10: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ). ((
4a20: 23 5c 21 20 23 5c 3e 20 23 5c 3c 29 0a 20 20 20 #\! #\> #\<).
4a30: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 20 (cond
4a40: 28 28 65 71 76 3f 20 28 70 65 65 6b 2d 63 68 61 ((eqv? (peek-cha
4a50: 72 29 20 23 5c 3d 29 0a 20 20 20 20 20 20 20 20 r) #\=).
4a60: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 61 (rea
4a70: 64 2d 63 68 61 72 29 20 28 73 74 72 69 6e 67 2d d-char) (string-
4a80: 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 20 >symbol (string
4a90: 63 20 23 5c 3d 29 29 29 0a 20 20 20 20 20 20 20 c #\=))).
4aa0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
4ab0: 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f e (string->symbo
4ac0: 6c 20 28 73 74 72 69 6e 67 20 63 29 29 29 29 29 l (string c)))))
4ad0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 28 23 . ((#
4ae0: 5c 3d 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 \=).
4af0: 20 28 63 6f 6e 64 20 28 28 65 71 76 3f 20 28 70 (cond ((eqv? (p
4b00: 65 65 6b 2d 63 68 61 72 29 20 23 5c 3d 29 20 28 eek-char) #\=) (
4b10: 72 65 61 64 2d 63 68 61 72 29 20 27 3d 3d 29 0a read-char) '==).
4b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b30: 20 20 20 28 65 6c 73 65 20 28 77 61 72 6e 69 6e (else (warnin
4b40: 67 20 27 43 2d 3e 53 63 68 65 6d 65 3a 6e 65 78 g 'C->Scheme:nex
4b50: 74 2d 74 6f 6b 65 6e 20 22 69 6e 76 61 6c 69 64 t-token "invalid
4b60: 20 61 73 73 69 67 6e 6d 65 6e 74 20 69 6e 20 43 assignment in C
4b70: 20 63 6f 64 65 22 29 20 23 66 29 29 29 0a 20 20 code") #f))).
4b80: 20 20 20 20 20 20 20 20 20 20 28 28 23 5c 30 20 ((#\0
4b90: 23 5c 31 20 23 5c 32 20 23 5c 33 20 23 5c 34 20 #\1 #\2 #\3 #\4
4ba0: 23 5c 35 20 23 5c 36 20 23 5c 37 20 23 5c 38 20 #\5 #\6 #\7 #\8
4bb0: 23 5c 39 29 0a 20 20 20 20 20 20 20 20 20 20 20 #\9).
4bc0: 20 20 28 72 65 61 64 2d 6e 75 6d 62 65 72 20 63 (read-number c
4bd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
4be0: 28 23 5c 6e 29 20 27 6e 29 0a 20 20 20 20 20 20 (#\n) 'n).
4bf0: 20 20 20 20 20 20 28 28 23 5c 73 70 61 63 65 20 ((#\space
4c00: 23 5c 6e 65 77 6c 69 6e 65 29 20 28 6e 65 78 74 #\newline) (next
4c10: 2d 74 6f 6b 65 6e 29 29 0a 20 20 20 20 20 20 20 -token)).
4c20: 20 20 20 20 20 28 65 6c 73 65 20 28 77 61 72 6e (else (warn
4c30: 69 6e 67 20 27 43 2d 3e 53 63 68 65 6d 65 3a 6e ing 'C->Scheme:n
4c40: 65 78 74 2d 74 6f 6b 65 6e 20 22 69 6e 76 61 6c ext-token "inval
4c50: 69 64 20 63 68 61 72 61 63 74 65 72 20 69 6e 20 id character in
4c60: 43 20 63 6f 64 65 3a 20 7e 53 22 20 63 29 20 23 C code: ~S" c) #
4c70: 66 29 29 29 29 29 0a 20 20 28 64 65 66 69 6e 65 f))))). (define
4c80: 20 28 43 2d 70 61 72 73 65 20 73 74 72 29 0a 20 (C-parse str).
4c90: 20 20 20 28 64 65 66 69 6e 65 20 28 70 72 65 63 (define (prec
4ca0: 65 64 65 6e 63 65 20 78 29 20 3b 3b 20 6c 6f 77 edence x) ;; low
4cb0: 65 72 20 76 61 6c 75 65 20 69 73 20 68 69 67 68 er value is high
4cc0: 65 72 20 70 72 65 63 65 64 65 6e 63 65 0a 20 20 er precedence.
4cd0: 20 20 20 20 28 63 61 73 65 20 78 0a 20 20 20 20 (case x.
4ce0: 20 20 20 20 28 28 2a 2a 29 20 31 30 29 20 20 20 ((**) 10)
4cf0: 20 20 20 20 20 20 20 20 28 28 26 29 20 37 30 29 ((&) 70)
4d00: 0a 20 20 20 20 20 20 20 20 28 28 21 20 7e 29 20 . ((! ~)
4d10: 32 30 29 20 20 20 20 20 20 20 20 20 20 28 28 5e 20) ((^
4d20: 20 6c 6f 67 61 6e 64 20 6c 6f 67 69 6f 72 29 20 logand logior)
4d30: 38 30 29 0a 20 20 20 20 20 20 20 20 28 28 2a 20 80). ((*
4d40: 2f 20 25 29 20 33 30 29 20 20 20 20 20 20 20 20 / %) 30)
4d50: 28 28 61 6e 64 29 20 39 30 29 0a 20 20 20 20 20 ((and) 90).
4d60: 20 20 20 28 28 2b 20 2d 29 20 34 30 29 20 20 20 ((+ -) 40)
4d70: 20 20 20 20 20 20 20 28 28 6f 72 29 20 31 30 30 ((or) 100
4d80: 29 0a 20 20 20 20 20 20 20 20 28 28 3c 20 3e 20 ). ((< >
4d90: 3c 3d 20 3e 3d 29 20 35 30 29 20 20 20 20 28 28 <= >=) 50) ((
4da0: 3f 29 20 31 31 30 29 0a 20 20 20 20 20 20 20 20 ?) 110).
4db0: 28 28 3d 3d 20 21 3d 20 3c 3d 3e 29 20 36 30 29 ((== != <=>) 60)
4dc0: 20 20 20 20 28 65 6c 73 65 20 31 32 30 29 29 29 (else 120)))
4dd0: 0a 20 20 20 20 28 64 65 66 69 6e 65 20 28 70 61 . (define (pa
4de0: 72 73 65 31 29 0a 20 20 20 20 20 20 28 6c 65 74 rse1). (let
4df0: 20 28 28 78 20 28 6e 65 78 74 2d 74 6f 6b 65 6e ((x (next-token
4e00: 29 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6e ))). (con
4e10: 64 20 28 28 6e 6f 74 20 78 29 20 28 70 61 72 73 d ((not x) (pars
4e20: 65 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 e1)).
4e30: 20 20 20 28 28 65 6f 66 2d 6f 62 6a 65 63 74 3f ((eof-object?
4e40: 20 78 29 20 27 65 6f 66 29 0a 20 20 20 20 20 20 x) 'eof).
4e50: 20 20 20 20 20 20 20 20 28 28 65 71 3f 20 78 20 ((eq? x
4e60: 27 6f 70 65 6e 29 20 28 70 61 72 73 65 2d 75 6e 'open) (parse-un
4e70: 74 69 6c 20 27 63 6c 6f 73 65 29 29 0a 20 20 20 til 'close)).
4e80: 20 20 20 20 20 20 20 20 20 20 20 28 28 6d 65 6d ((mem
4e90: 71 20 78 20 27 28 21 20 7e 29 29 20 60 28 2c 78 q x '(! ~)) `(,x
4ea0: 20 2c 28 70 61 72 73 65 31 29 29 29 0a 20 20 20 ,(parse1))).
4eb0: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
4ec0: 20 78 29 29 29 29 0a 20 20 20 20 28 64 65 66 69 x)))). (defi
4ed0: 6e 65 20 28 70 61 72 73 65 2d 75 6e 74 69 6c 20 ne (parse-until
4ee0: 65 6e 64 29 0a 20 20 20 20 20 20 28 64 65 66 69 end). (defi
4ef0: 6e 65 20 28 67 72 6f 75 70 20 6f 70 20 6c 65 66 ne (group op lef
4f00: 74 20 72 69 67 68 74 29 0a 20 20 20 20 20 20 20 t right).
4f10: 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 (cond.
4f20: 28 28 6f 72 20 28 65 71 3f 20 72 69 67 68 74 20 ((or (eq? right
4f30: 65 6e 64 29 20 28 65 71 3f 20 72 69 67 68 74 20 end) (eq? right
4f40: 27 65 6f 66 29 29 0a 20 20 20 20 20 20 20 20 20 'eof)).
4f50: 20 28 77 61 72 6e 69 6e 67 20 27 43 2d 70 61 72 (warning 'C-par
4f60: 73 65 20 22 65 78 70 65 63 74 65 64 20 32 6e 64 se "expected 2nd
4f70: 20 61 72 67 75 6d 65 6e 74 20 74 6f 22 20 6f 70 argument to" op
4f80: 29 0a 20 20 20 20 20 20 20 20 20 20 60 28 6f 70 ). `(op
4f90: 20 2c 6c 65 66 74 29 29 0a 20 20 20 20 20 20 20 ,left)).
4fa0: 20 20 28 28 65 71 3f 20 6f 70 20 27 61 6e 64 29 ((eq? op 'and)
4fb0: 0a 20 20 20 20 20 20 20 20 20 20 60 28 69 66 20 . `(if
4fc0: 28 7a 65 72 6f 3f 20 2c 6c 65 66 74 29 20 30 20 (zero? ,left) 0
4fd0: 2c 72 69 67 68 74 29 29 0a 20 20 20 20 20 20 20 ,right)).
4fe0: 20 20 28 28 65 71 3f 20 6f 70 20 27 6f 72 29 0a ((eq? op 'or).
4ff0: 20 20 20 20 20 20 20 20 20 20 60 28 69 66 20 28 `(if (
5000: 7a 65 72 6f 3f 20 2c 6c 65 66 74 29 20 2c 72 69 zero? ,left) ,ri
5010: 67 68 74 20 31 29 29 0a 20 20 20 20 20 20 20 20 ght 1)).
5020: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 (else.
5030: 20 60 28 2c 6f 70 20 2c 6c 65 66 74 20 2c 72 69 `(,op ,left ,ri
5040: 67 68 74 29 29 29 29 0a 20 20 20 20 20 20 28 64 ght)))). (d
5050: 65 66 69 6e 65 20 28 6a 6f 69 6e 20 78 20 73 74 efine (join x st
5060: 61 63 6b 29 0a 20 20 20 20 20 20 20 20 28 69 66 ack). (if
5070: 20 28 6e 75 6c 6c 3f 20 73 74 61 63 6b 29 0a 20 (null? stack).
5080: 20 20 20 20 20 20 20 20 20 20 20 78 0a 20 20 20 x.
5090: 20 20 20 20 20 20 20 20 20 28 6a 6f 69 6e 20 28 (join (
50a0: 67 72 6f 75 70 20 28 63 61 72 20 73 74 61 63 6b group (car stack
50b0: 29 20 28 63 61 64 72 20 73 74 61 63 6b 29 20 78 ) (cadr stack) x
50c0: 29 20 28 63 64 64 72 20 73 74 61 63 6b 29 29 29 ) (cddr stack)))
50d0: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 69 ). (let ((i
50e0: 6e 69 74 20 28 70 61 72 73 65 31 29 29 29 0a 20 nit (parse1))).
50f0: 20 20 20 20 20 20 20 28 69 66 20 28 65 71 75 61 (if (equa
5100: 6c 3f 20 69 6e 69 74 20 65 6e 64 29 0a 20 20 20 l? init end).
5110: 20 20 20 20 20 20 20 20 20 27 28 29 0a 20 20 20 '().
5120: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 70 61 (let pa
5130: 72 73 65 20 28 28 6c 65 66 74 20 69 6e 69 74 29 rse ((left init)
5140: 20 28 6f 70 20 28 70 61 72 73 65 31 29 29 20 28 (op (parse1)) (
5150: 73 74 61 63 6b 20 27 28 29 29 29 0a 20 20 20 20 stack '())).
5160: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
5170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5180: 28 65 71 3f 20 6f 70 20 65 6e 64 29 20 28 6a 6f (eq? op end) (jo
5190: 69 6e 20 6c 65 66 74 20 73 74 61 63 6b 29 29 0a in left stack)).
51a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
51b0: 28 65 71 3f 20 6f 70 20 27 65 6f 66 29 0a 20 20 (eq? op 'eof).
51c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 (w
51d0: 61 72 6e 69 6e 67 20 27 43 2d 70 61 72 73 65 3a arning 'C-parse:
51e0: 70 61 72 73 65 2d 75 6e 74 69 6c 20 22 75 6e 65 parse-until "une
51f0: 78 70 65 63 74 65 64 20 23 3c 65 6f 66 3e 22 29 xpected #<eof>")
5200: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5210: 20 28 6a 6f 69 6e 20 6c 65 66 74 20 73 74 61 63 (join left stac
5220: 6b 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 k)).
5230: 20 20 20 28 28 65 71 3f 20 6f 70 20 27 3f 29 20 ((eq? op '?)
5240: 3b 3b 20 74 72 69 6e 61 72 79 20 3f 20 3a 20 28 ;; trinary ? : (
5250: 72 69 67 68 74 2d 61 73 73 6f 63 29 0a 20 20 20 right-assoc).
5260: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
5270: 74 2a 20 28 28 70 61 73 73 20 28 70 61 72 73 65 t* ((pass (parse
5280: 2d 75 6e 74 69 6c 20 27 3a 29 29 0a 20 20 20 20 -until ':)).
5290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52a0: 20 20 20 28 66 61 69 6c 20 28 70 61 72 73 65 31 (fail (parse1
52b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
52c0: 20 20 20 20 20 20 20 20 20 20 28 6f 70 32 20 28 (op2 (
52d0: 70 61 72 73 65 31 29 29 29 0a 20 20 20 20 20 20 parse1))).
52e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
52f0: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
5300: 20 20 20 20 20 28 28 6f 72 20 28 65 71 3f 20 6f ((or (eq? o
5310: 70 32 20 65 6e 64 29 20 28 65 71 3f 20 6f 70 32 p2 end) (eq? op2
5320: 20 27 65 6f 66 29 29 0a 20 20 20 20 20 20 20 20 'eof)).
5330: 20 20 20 20 20 20 20 20 20 20 20 20 60 28 69 66 `(if
5340: 20 28 7a 65 72 6f 3f 20 2c 6c 65 66 74 29 20 2c (zero? ,left) ,
5350: 66 61 69 6c 20 2c 70 61 73 73 29 29 0a 20 20 20 fail ,pass)).
5360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5370: 28 28 3c 20 28 70 72 65 63 65 64 65 6e 63 65 20 ((< (precedence
5380: 6f 70 29 20 28 70 72 65 63 65 64 65 6e 63 65 20 op) (precedence
5390: 6f 70 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 op2)).
53a0: 20 20 20 20 20 20 20 20 20 20 28 70 61 72 73 65 (parse
53b0: 20 60 28 69 66 20 28 7a 65 72 6f 3f 20 2c 6c 65 `(if (zero? ,le
53c0: 66 74 29 20 2c 66 61 69 6c 20 2c 70 61 73 73 29 ft) ,fail ,pass)
53d0: 20 6f 70 32 20 73 74 61 63 6b 29 29 0a 20 20 20 op2 stack)).
53e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
53f0: 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 (else.
5400: 20 20 20 20 20 20 20 20 20 20 28 6a 6f 69 6e 20 (join
5410: 60 28 69 66 20 28 7a 65 72 6f 3f 20 2c 6c 65 66 `(if (zero? ,lef
5420: 74 29 20 2c 28 70 61 72 73 65 20 66 61 69 6c 20 t) ,(parse fail
5430: 6f 70 32 20 27 28 29 29 20 2c 70 61 73 73 29 0a op2 '()) ,pass).
5440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5450: 20 20 20 20 20 20 20 20 20 20 73 74 61 63 6b 29 stack)
5460: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
5470: 20 20 20 20 28 65 6c 73 65 20 3b 3b 20 61 73 73 (else ;; ass
5480: 75 6d 65 20 61 20 28 6c 65 66 74 2d 61 73 73 6f ume a (left-asso
5490: 63 29 20 62 69 6e 61 72 79 20 6f 70 65 72 61 74 c) binary operat
54a0: 6f 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 or.
54b0: 20 20 20 28 6c 65 74 2a 20 28 28 72 69 67 68 74 (let* ((right
54c0: 20 28 70 61 72 73 65 31 29 29 0a 20 20 20 20 20 (parse1)).
54d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
54e0: 20 20 28 6f 70 32 20 28 70 61 72 73 65 31 29 29 (op2 (parse1))
54f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5500: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 (cond.
5510: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6f ((o
5520: 72 20 28 65 71 3f 20 6f 70 32 20 65 6e 64 29 20 r (eq? op2 end)
5530: 28 65 71 3f 20 6f 70 32 20 27 65 6f 66 29 29 0a (eq? op2 'eof)).
5540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5550: 20 20 20 20 28 6a 6f 69 6e 20 28 67 72 6f 75 70 (join (group
5560: 20 6f 70 20 6c 65 66 74 20 72 69 67 68 74 29 20 op left right)
5570: 73 74 61 63 6b 29 29 0a 20 20 20 20 20 20 20 20 stack)).
5580: 20 20 20 20 20 20 20 20 20 20 20 28 28 3c 3d 20 ((<=
5590: 28 70 72 65 63 65 64 65 6e 63 65 20 6f 70 29 20 (precedence op)
55a0: 28 70 72 65 63 65 64 65 6e 63 65 20 6f 70 32 29 (precedence op2)
55b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
55c0: 20 20 20 20 20 20 3b 3b 20 6f 70 32 20 68 61 73 ;; op2 has
55d0: 20 6c 65 73 73 20 74 68 61 6e 20 6f 72 20 65 71 less than or eq
55e0: 75 61 6c 20 70 72 65 63 65 64 65 6e 63 65 2c 20 ual precedence,
55f0: 67 72 6f 75 70 0a 20 20 20 20 20 20 20 20 20 20 group.
5600: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c (let l
5610: 6f 6f 70 32 20 28 28 78 20 28 67 72 6f 75 70 20 oop2 ((x (group
5620: 6f 70 20 6c 65 66 74 20 72 69 67 68 74 29 29 20 op left right))
5630: 28 73 20 73 74 61 63 6b 29 29 0a 20 20 20 20 20 (s stack)).
5640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5650: 20 28 69 66 20 28 61 6e 64 20 28 70 61 69 72 3f (if (and (pair?
5660: 20 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s).
5670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5680: 20 20 20 28 3c 20 28 70 72 65 63 65 64 65 6e 63 (< (precedenc
5690: 65 20 28 63 61 72 20 73 29 29 20 28 70 72 65 63 e (car s)) (prec
56a0: 65 64 65 6e 63 65 20 6f 70 32 29 29 29 0a 20 20 edence op2))).
56b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56c0: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 32 20 28 (loop2 (
56d0: 67 72 6f 75 70 20 28 63 61 72 20 73 29 20 28 63 group (car s) (c
56e0: 61 64 72 20 73 29 20 78 29 20 28 63 64 64 72 20 adr s) x) (cddr
56f0: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
5700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
5710: 61 72 73 65 20 78 20 6f 70 32 20 73 29 29 29 29 arse x op2 s))))
5720: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5730: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
5740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
5750: 20 6f 70 32 20 68 61 73 20 68 69 67 68 65 72 20 op2 has higher
5760: 70 72 65 63 65 64 65 6e 63 65 2c 20 70 75 73 68 precedence, push
5770: 20 6f 6e 20 74 68 65 20 73 74 61 63 6b 0a 20 20 on the stack.
5780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5790: 20 20 28 70 61 72 73 65 20 72 69 67 68 74 20 6f (parse right o
57a0: 70 32 20 28 63 6f 6e 73 20 6f 70 20 28 63 6f 6e p2 (cons op (con
57b0: 73 20 6c 65 66 74 20 73 74 61 63 6b 29 29 29 29 s left stack))))
57c0: 29 29 29 29 29 29 29 29 0a 20 20 20 20 28 77 69 )))))))). (wi
57d0: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 73 74 th-input-from-st
57e0: 72 69 6e 67 20 73 74 72 0a 20 20 20 20 20 20 28 ring str. (
57f0: 6c 61 6d 62 64 61 20 28 29 20 28 70 61 72 73 65 lambda () (parse
5800: 2d 75 6e 74 69 6c 20 27 65 6f 66 29 29 29 29 0a -until 'eof)))).
5810: 20 20 28 64 65 66 69 6e 65 20 28 6d 61 70 2d 43 (define (map-C
5820: 2d 6e 61 6d 65 73 20 78 29 0a 20 20 20 20 28 63 -names x). (c
5830: 6f 6e 64 0a 20 20 20 20 20 28 28 73 79 6d 62 6f ond. ((symbo
5840: 6c 3f 20 78 29 0a 20 20 20 20 20 20 28 63 61 73 l? x). (cas
5850: 65 20 78 0a 20 20 20 20 20 20 20 20 28 28 2f 29 e x. ((/)
5860: 20 27 71 75 6f 74 69 65 6e 74 29 20 28 28 25 29 'quotient) ((%)
5870: 20 27 6d 6f 64 75 6c 6f 29 20 28 28 2a 2a 29 20 'modulo) ((**)
5880: 27 65 78 70 74 29 0a 20 20 20 20 20 20 20 20 28 'expt). (
5890: 28 7e 29 20 27 6c 6f 67 6e 6f 74 29 20 20 20 28 (~) 'lognot) (
58a0: 28 5e 29 20 27 6c 6f 67 78 6f 72 29 20 28 28 3c (^) 'logxor) ((<
58b0: 3c 29 20 27 61 72 69 74 68 6d 65 74 69 63 2d 73 <) 'arithmetic-s
58c0: 68 69 66 74 29 0a 20 20 20 20 20 20 20 20 3b 3b hift). ;;
58d0: 20 43 20 63 6f 6e 66 6c 61 74 65 73 20 62 6f 6f C conflates boo
58e0: 6c 65 61 6e 73 20 77 69 74 68 20 69 6e 74 65 67 leans with integ
58f0: 65 72 73 0a 20 20 20 20 20 20 20 20 28 28 21 29 ers. ((!)
5900: 20 27 28 6c 61 6d 62 64 61 20 28 61 29 20 28 69 '(lambda (a) (i
5910: 66 20 28 7a 65 72 6f 3f 20 61 29 20 31 20 30 29 f (zero? a) 1 0)
5920: 29 29 0a 20 20 20 20 20 20 20 20 28 28 3e 3e 29 )). ((>>)
5930: 20 27 28 6c 61 6d 62 64 61 20 28 61 20 62 29 20 '(lambda (a b)
5940: 28 61 72 69 74 68 6d 65 74 69 63 2d 73 68 69 66 (arithmetic-shif
5950: 74 20 61 20 28 2d 20 62 29 29 29 29 0a 20 20 20 t a (- b)))).
5960: 20 20 20 20 20 28 28 3d 3d 29 20 27 28 6c 61 6d ((==) '(lam
5970: 62 64 61 20 28 61 20 62 29 20 28 69 66 20 28 65 bda (a b) (if (e
5980: 71 76 3f 20 61 20 62 29 20 31 20 30 29 29 29 0a qv? a b) 1 0))).
5990: 20 20 20 20 20 20 20 20 28 28 21 3d 29 20 27 28 ((!=) '(
59a0: 6c 61 6d 62 64 61 20 28 61 20 62 29 20 28 69 66 lambda (a b) (if
59b0: 20 28 65 71 76 3f 20 61 20 62 29 20 30 20 31 29 (eqv? a b) 0 1)
59c0: 29 29 0a 20 20 20 20 20 20 20 20 28 28 3e 29 20 )). ((>)
59d0: 27 28 6c 61 6d 62 64 61 20 28 61 20 62 29 20 20 '(lambda (a b)
59e0: 28 69 66 20 28 3e 20 61 20 62 29 20 31 20 30 29 (if (> a b) 1 0)
59f0: 29 29 0a 20 20 20 20 20 20 20 20 28 28 3c 29 20 )). ((<)
5a00: 27 28 6c 61 6d 62 64 61 20 28 61 20 62 29 20 20 '(lambda (a b)
5a10: 28 69 66 20 28 3c 20 61 20 62 29 20 31 20 30 29 (if (< a b) 1 0)
5a20: 29 29 0a 20 20 20 20 20 20 20 20 28 28 3e 3d 29 )). ((>=)
5a30: 20 27 28 6c 61 6d 62 64 61 20 28 61 20 62 29 20 '(lambda (a b)
5a40: 28 69 66 20 28 3e 3d 20 61 20 62 29 20 31 20 30 (if (>= a b) 1 0
5a50: 29 29 29 0a 20 20 20 20 20 20 20 20 28 28 3c 3d ))). ((<=
5a60: 29 20 27 28 6c 61 6d 62 64 61 20 28 61 20 62 29 ) '(lambda (a b)
5a70: 20 28 69 66 20 28 3c 3d 20 61 20 62 29 20 31 20 (if (<= a b) 1
5a80: 30 29 29 29 0a 20 20 20 20 20 20 20 20 28 65 6c 0))). (el
5a90: 73 65 20 78 29 29 29 0a 20 20 20 20 20 28 28 70 se x))). ((p
5aa0: 61 69 72 3f 20 78 29 0a 20 20 20 20 20 20 28 63 air? x). (c
5ab0: 6f 6e 73 20 28 6d 61 70 2d 43 2d 6e 61 6d 65 73 ons (map-C-names
5ac0: 20 28 63 61 72 20 78 29 29 20 28 6d 61 70 2d 43 (car x)) (map-C
5ad0: 2d 6e 61 6d 65 73 20 28 63 64 72 20 78 29 29 29 -names (cdr x)))
5ae0: 29 0a 20 20 20 20 20 28 65 6c 73 65 20 78 29 29 ). (else x))
5af0: 29 0a 20 20 28 6c 65 74 20 28 28 62 6f 64 79 20 ). (let ((body
5b00: 28 6d 61 70 2d 43 2d 6e 61 6d 65 73 20 28 43 2d (map-C-names (C-
5b10: 70 61 72 73 65 20 73 74 72 29 29 29 29 0a 20 20 parse str)))).
5b20: 20 20 3b 3b 20 63 6f 75 6c 64 20 62 75 69 6c 64 ;; could build
5b30: 20 66 72 6f 6d 20 63 68 61 69 6e 65 64 20 63 6c from chained cl
5b40: 6f 73 75 72 65 73 20 77 2f 6f 20 75 73 69 6e 67 osures w/o using
5b50: 20 65 76 61 6c 20 62 75 74 20 74 68 69 73 20 69 eval but this i
5b60: 73 0a 20 20 20 20 3b 3b 20 66 61 73 74 65 72 20 s. ;; faster
5b70: 61 74 20 72 75 6e 74 69 6d 65 0a 20 20 20 20 28 at runtime. (
5b80: 65 76 61 6c 20 60 28 6c 61 6d 62 64 61 20 28 6e eval `(lambda (n
5b90: 29 20 2c 62 6f 64 79 29 20 28 73 63 68 65 6d 65 ) ,body) (scheme
5ba0: 2d 72 65 70 6f 72 74 2d 65 6e 76 69 72 6f 6e 6d -report-environm
5bb0: 65 6e 74 20 35 29 29 29 29 0a 0a 3b 3b 3b 3b 3b ent 5))))..;;;;;
5bc0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
5bd0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
5be0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
5bf0: 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b 3b ;;;;;;;;;;;;;;;;
5c00: 3b 3b 3b 0a 3b 3b 20 69 6e 74 65 72 6e 61 6c 20 ;;;.;; internal
5c10: 72 6f 75 74 69 6e 65 73 20 66 6f 72 20 62 75 69 routines for bui
5c20: 6c 64 69 6e 67 2f 63 61 63 68 69 6e 67 20 66 69 lding/caching fi
5c30: 6c 65 73 20 61 6e 64 20 6c 6f 6f 6b 75 70 73 0a les and lookups.
5c40: 0a 28 64 65 66 69 6e 65 20 28 73 70 6c 69 74 2d .(define (split-
5c50: 6c 61 6e 67 73 20 6c 61 6e 67 29 0a 20 20 28 64 langs lang). (d
5c60: 65 66 69 6e 65 20 28 73 70 6c 69 74 2d 61 74 20 efine (split-at
5c70: 63 68 29 0a 20 20 20 20 28 63 6f 6e 64 20 28 28 ch). (cond ((
5c80: 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 6c 61 6e string-index lan
5c90: 67 20 63 68 29 0a 20 20 20 20 20 20 20 20 20 20 g ch).
5ca0: 20 3d 3e 20 28 6c 61 6d 62 64 61 20 28 69 29 20 => (lambda (i)
5cb0: 28 6c 69 73 74 20 28 73 75 62 73 74 72 69 6e 67 (list (substring
5cc0: 20 6c 61 6e 67 20 30 20 69 29 29 29 29 0a 20 20 lang 0 i)))).
5cd0: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 27 28 (else '(
5ce0: 29 29 29 29 0a 20 20 28 63 6f 6e 73 20 6c 61 6e )))). (cons lan
5cf0: 67 20 28 61 70 70 65 6e 64 20 28 73 70 6c 69 74 g (append (split
5d00: 2d 61 74 20 23 5c 2e 29 20 28 73 70 6c 69 74 2d -at #\.) (split-
5d10: 61 74 20 23 5c 5f 29 29 29 29 0a 0a 28 64 65 66 at #\_))))..(def
5d20: 69 6e 65 20 28 6d 61 6b 65 2d 67 65 74 74 65 78 ine (make-gettex
5d30: 74 2d 69 6e 74 65 72 6e 61 6c 20 64 6f 6d 61 69 t-internal domai
5d40: 6e 20 6c 6f 63 61 6c 65 20 64 69 72 73 20 63 64 n locale dirs cd
5d50: 69 72 20 63 61 63 68 65 64 3f 29 0a 0a 20 20 28 ir cached?).. (
5d60: 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 63 61 63 define (make-cac
5d70: 68 65 29 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 he) (make-hash-t
5d80: 61 62 6c 65 29 29 0a 0a 20 20 28 64 65 66 69 6e able)).. (defin
5d90: 65 20 28 6d 61 6b 65 2d 66 69 6c 65 2d 6c 69 73 e (make-file-lis
5da0: 74 29 0a 20 20 20 20 28 64 65 66 69 6e 65 20 73 t). (define s
5db0: 75 66 66 69 78 65 73 20 27 28 22 2e 6d 6f 22 20 uffixes '(".mo"
5dc0: 22 2e 70 6f 22 29 29 0a 20 20 20 20 28 72 65 76 ".po")). (rev
5dd0: 65 72 73 65 0a 20 20 20 20 20 28 66 6f 6c 64 2d erse. (fold-
5de0: 72 69 67 68 74 0a 20 20 20 20 20 20 28 6c 61 6d right. (lam
5df0: 62 64 61 20 28 78 20 72 65 73 29 0a 20 20 20 20 bda (x res).
5e00: 20 20 20 20 28 6c 65 74 20 28 28 70 61 74 68 0a (let ((path.
5e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5e20: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 0a 20 20 string-append.
5e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
5e40: 61 64 64 72 20 78 29 20 22 2f 22 20 28 63 61 72 addr x) "/" (car
5e50: 20 78 29 20 22 2f 22 20 63 64 69 72 20 22 2f 22 x) "/" cdir "/"
5e60: 20 28 63 61 64 72 20 78 29 20 28 63 61 64 64 64 (cadr x) (caddd
5e70: 72 20 78 29 29 29 29 0a 20 20 20 20 20 20 20 20 r x)))).
5e80: 20 20 28 69 66 20 28 66 69 6c 65 2d 72 65 61 64 (if (file-read
5e90: 2d 61 63 63 65 73 73 3f 20 70 61 74 68 29 0a 20 -access? path).
5ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
5eb0: 6e 73 20 28 6d 61 6b 65 2d 67 65 74 74 65 78 74 ns (make-gettext
5ec0: 2d 66 69 6c 65 20 70 61 74 68 20 28 63 61 72 20 -file path (car
5ed0: 78 29 29 20 72 65 73 29 0a 20 20 20 20 20 20 20 x)) res).
5ee0: 20 20 20 20 20 20 20 72 65 73 29 29 29 0a 20 20 res))).
5ef0: 20 20 20 20 27 28 29 0a 20 20 20 20 20 20 28 63 '(). (c
5f00: 61 72 74 65 73 69 61 6e 2d 70 72 6f 64 75 63 74 artesian-product
5f10: 20 28 6c 69 73 74 20 28 61 70 70 65 6e 64 2d 6d (list (append-m
5f20: 61 70 20 73 70 6c 69 74 2d 6c 61 6e 67 73 20 6c ap split-langs l
5f30: 6f 63 61 6c 65 29 0a 20 20 20 20 20 20 20 20 20 ocale).
5f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f50: 20 20 20 20 20 20 64 6f 6d 61 69 6e 0a 20 20 20 domain.
5f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f70: 20 20 20 20 20 20 20 20 20 20 20 20 64 69 72 73 dirs
5f80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fa0: 73 75 66 66 69 78 65 73 29 29 29 29 29 0a 0a 20 suffixes)))))..
5fb0: 20 28 6c 65 74 20 28 28 66 69 6c 65 73 20 28 6d (let ((files (m
5fc0: 61 6b 65 2d 66 69 6c 65 2d 6c 69 73 74 29 29 0a ake-file-list)).
5fd0: 20 20 20 20 20 20 20 20 28 63 61 63 68 65 20 28 (cache (
5fe0: 6d 61 6b 65 2d 63 61 63 68 65 29 29 29 0a 0a 20 make-cache)))..
5ff0: 20 20 20 28 64 65 66 69 6e 65 20 28 73 65 61 72 (define (sear
6000: 63 68 20 6d 73 67 20 2e 20 6f 70 74 29 0a 20 20 ch msg . opt).
6010: 20 20 20 20 28 69 66 20 28 61 6e 64 20 63 61 63 (if (and cac
6020: 68 65 64 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 hed? (hash-table
6030: 2d 65 78 69 73 74 73 3f 20 63 61 63 68 65 20 6d -exists? cache m
6040: 73 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 sg)). (
6050: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
6060: 65 66 61 75 6c 74 20 63 61 63 68 65 20 6d 73 67 efault cache msg
6070: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 28 #f). (
6080: 6c 65 74 2d 6f 70 74 69 6f 6e 61 6c 73 2a 20 6f let-optionals* o
6090: 70 74 20 28 28 6d 73 67 32 20 23 66 29 20 28 6e pt ((msg2 #f) (n
60a0: 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f)).
60b0: 20 20 28 6c 65 74 20 28 28 73 70 6c 69 74 3f 20 (let ((split?
60c0: 28 6e 75 6d 62 65 72 3f 20 6e 29 29 29 0a 20 20 (number? n))).
60d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 79 (any
60e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
60f0: 28 6c 61 6d 62 64 61 20 28 67 66 29 0a 20 20 20 (lambda (gf).
6100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
6110: 6e 64 2d 6c 65 74 2a 20 28 28 78 30 20 28 6c 6f nd-let* ((x0 (lo
6120: 6f 6b 75 70 2d 6d 65 73 73 61 67 65 20 67 66 20 okup-message gf
6130: 6d 73 67 20 6d 73 67 32 29 29 0a 20 20 20 20 20 msg msg2)).
6140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6150: 20 20 20 20 20 20 20 28 78 20 28 69 66 20 28 61 (x (if (a
6160: 6e 64 20 73 70 6c 69 74 3f 20 28 65 71 3f 20 28 nd split? (eq? (
6170: 67 66 69 6c 65 2d 74 79 70 65 20 67 66 29 20 27 gfile-type gf) '
6180: 6d 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 mo)).
6190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
61a0: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 28 6f (cons (o
61b0: 72 20 6d 73 67 32 20 6d 73 67 29 0a 20 20 20 20 r msg2 msg).
61c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
61d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
61e0: 20 20 20 20 20 28 6c 65 74 20 28 28 6c 20 28 73 (let ((l (s
61f0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 78 30 20 6e tring-split x0 n
6200: 75 6c 6c 2d 73 74 72 29 29 29 0a 20 20 20 20 20 ull-str))).
6210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6230: 20 20 20 20 20 20 28 6d 61 70 20 63 6f 6e 73 20 (map cons
6240: 28 69 6f 74 61 20 28 6c 65 6e 67 74 68 20 6c 29 (iota (length l)
6250: 29 20 6c 29 29 29 0a 20 20 20 20 20 20 20 20 20 ) l))).
6260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6270: 20 20 20 20 20 20 20 20 20 20 78 30 29 29 0a 20 x0)).
6280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6290: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 20 (res
62a0: 28 63 6f 6e 73 20 78 20 67 66 29 29 29 0a 20 20 (cons x gf))).
62b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
62c0: 20 28 69 66 20 63 61 63 68 65 64 3f 20 28 68 61 (if cached? (ha
62d0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 61 sh-table-set! ca
62e0: 63 68 65 20 6d 73 67 20 72 65 73 29 29 0a 20 20 che msg res)).
62f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6300: 20 72 65 73 29 29 0a 20 20 20 20 20 20 20 20 20 res)).
6310: 20 20 20 20 20 20 66 69 6c 65 73 29 29 29 29 29 files)))))
6320: 0a 0a 20 20 20 20 28 64 65 66 69 6e 65 20 28 67 .. (define (g
6330: 65 74 20 6d 73 67 29 0a 20 20 20 20 20 20 28 6c et msg). (l
6340: 65 74 20 28 28 72 65 73 20 28 73 65 61 72 63 68 et ((res (search
6350: 20 6d 73 67 29 29 29 0a 20 20 20 20 20 20 20 20 msg))).
6360: 28 69 66 20 72 65 73 20 28 69 66 20 28 70 61 69 (if res (if (pai
6370: 72 3f 20 28 63 61 72 20 72 65 73 29 29 20 28 63 r? (car res)) (c
6380: 61 61 72 20 72 65 73 29 20 28 63 61 72 20 72 65 aar res) (car re
6390: 73 29 29 20 6d 73 67 29 29 29 0a 0a 20 20 20 20 s)) msg)))..
63a0: 28 64 65 66 69 6e 65 20 28 6e 67 65 74 20 6d 73 (define (nget ms
63b0: 67 20 2e 20 6f 70 74 29 20 3b 3b 20 5b 6d 73 67 g . opt) ;; [msg
63c0: 32 5d 20 5b 6e 5d 0a 20 20 20 20 20 20 28 6c 65 2] [n]. (le
63d0: 74 20 28 28 6d 73 67 32 20 23 66 29 20 28 6e 20 t ((msg2 #f) (n
63e0: 23 66 29 29 0a 20 20 20 20 20 20 20 20 3b 3b 20 #f)). ;;
63f0: 6f 70 74 69 6f 6e 20 70 61 72 73 69 6e 67 2c 20 option parsing,
6400: 62 6f 74 68 20 6f 70 74 69 6f 6e 61 6c 0a 20 20 both optional.
6410: 20 20 20 20 20 20 28 77 68 65 6e 20 28 70 61 69 (when (pai
6420: 72 3f 20 6f 70 74 29 0a 20 20 20 20 20 20 20 20 r? opt).
6430: 20 20 28 6c 65 74 20 28 28 78 20 28 63 61 72 20 (let ((x (car
6440: 6f 70 74 29 29 29 20 28 69 66 20 28 6e 75 6d 62 opt))) (if (numb
6450: 65 72 3f 20 78 29 20 28 73 65 74 21 20 6e 20 78 er? x) (set! n x
6460: 29 20 28 73 65 74 21 20 6d 73 67 32 20 78 29 29 ) (set! msg2 x))
6470: 29 0a 20 20 20 20 20 20 20 20 20 20 28 77 68 65 ). (whe
6480: 6e 20 28 70 61 69 72 3f 20 28 63 64 72 20 6f 70 n (pair? (cdr op
6490: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t)).
64a0: 28 6c 65 74 20 28 28 78 20 28 63 61 64 72 20 6f (let ((x (cadr o
64b0: 70 74 29 29 29 20 28 69 66 20 28 6e 75 6d 62 65 pt))) (if (numbe
64c0: 72 3f 20 78 29 20 28 73 65 74 21 20 6e 20 78 29 r? x) (set! n x)
64d0: 20 28 73 65 74 21 20 6d 73 67 32 20 78 29 29 29 (set! msg2 x)))
64e0: 29 29 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 )). (let
64f0: 28 28 72 65 73 20 28 73 65 61 72 63 68 20 6d 73 ((res (search ms
6500: 67 20 6d 73 67 32 20 6e 29 29 29 0a 20 20 20 20 g msg2 n))).
6510: 20 20 20 20 20 20 28 69 66 20 28 70 61 69 72 3f (if (pair?
6520: 20 72 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 res).
6530: 20 20 20 20 28 6c 65 74 20 28 28 70 6c 75 72 61 (let ((plura
6540: 6c 2d 69 6e 64 65 78 20 28 67 66 69 6c 65 2d 70 l-index (gfile-p
6550: 6c 75 72 61 6c 2d 69 6e 64 65 78 20 28 63 64 72 lural-index (cdr
6560: 20 72 65 73 29 29 29 29 0a 20 20 20 20 20 20 20 res)))).
6570: 20 20 20 20 20 20 20 20 20 28 6f 72 20 28 61 6e (or (an
6580: 64 20 28 70 72 6f 63 65 64 75 72 65 3f 20 70 6c d (procedure? pl
6590: 75 72 61 6c 2d 69 6e 64 65 78 29 0a 20 20 20 20 ural-index).
65a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65b0: 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 (cond.
65c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65d0: 20 20 20 20 20 28 28 61 73 73 76 20 28 70 6c 75 ((assv (plu
65e0: 72 61 6c 2d 69 6e 64 65 78 20 28 6f 72 20 6e 20 ral-index (or n
65f0: 31 29 29 20 28 63 64 61 72 20 72 65 73 29 29 20 1)) (cdar res))
6600: 3d 3e 20 63 64 72 29 0a 20 20 20 20 20 20 20 20 => cdr).
6610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6620: 20 20 28 65 6c 73 65 20 23 66 29 29 29 0a 20 20 (else #f))).
6630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6640: 20 20 28 69 66 20 28 65 71 76 3f 20 6e 20 31 29 (if (eqv? n 1)
6650: 20 6d 73 67 20 28 63 61 61 72 20 72 65 73 29 29 msg (caar res))
6660: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
6670: 20 28 69 66 20 28 6f 72 20 28 65 71 76 3f 20 6e (if (or (eqv? n
6680: 20 31 29 20 28 6e 6f 74 20 6d 73 67 32 29 29 20 1) (not msg2))
6690: 6d 73 67 20 6d 73 67 32 29 29 29 29 29 0a 0a 20 msg msg2)))))..
66a0: 20 20 20 28 64 65 66 69 6e 65 20 28 73 65 74 20 (define (set
66b0: 6d 73 67 20 76 61 6c 29 20 28 68 61 73 68 2d 74 msg val) (hash-t
66c0: 61 62 6c 65 2d 73 65 74 21 20 63 61 63 68 65 20 able-set! cache
66d0: 6d 73 67 20 76 61 6c 29 29 0a 0a 20 20 20 20 28 msg val)).. (
66e0: 64 65 66 69 6e 65 20 28 72 65 73 65 74 21 29 0a define (reset!).
66f0: 20 20 20 20 20 20 28 73 65 74 21 20 66 69 6c 65 (set! file
6700: 73 20 28 6d 61 6b 65 2d 66 69 6c 65 2d 6c 69 73 s (make-file-lis
6710: 74 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 t)). (set!
6720: 63 61 63 68 65 20 28 6d 61 6b 65 2d 63 61 63 68 cache (make-cach
6730: 65 29 29 29 0a 0a 20 20 20 20 3b 3b 20 72 65 74 e))).. ;; ret
6740: 75 72 6e 20 74 68 65 20 64 69 73 70 61 74 63 68 urn the dispatch
6750: 65 72 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 er. (lambda (
6760: 64 69 73 70 61 74 63 68 20 2e 20 61 72 67 73 29 dispatch . args)
6770: 0a 20 20 20 20 20 20 28 63 61 73 65 20 64 69 73 . (case dis
6780: 70 61 74 63 68 0a 20 20 20 20 20 20 20 20 28 28 patch. ((
6790: 73 65 61 72 63 68 65 72 29 20 73 65 61 72 63 68 searcher) search
67a0: 29 0a 20 20 20 20 20 20 20 20 28 28 67 65 74 74 ). ((gett
67b0: 65 72 29 20 67 65 74 29 0a 20 20 20 20 20 20 20 er) get).
67c0: 20 28 28 6e 67 65 74 74 65 72 29 20 6e 67 65 74 ((ngetter) nget
67d0: 29 0a 20 20 20 20 20 20 20 20 28 28 73 65 74 74 ). ((sett
67e0: 65 72 29 20 73 65 74 29 0a 20 20 20 20 20 20 20 er) set).
67f0: 20 28 28 73 65 61 72 63 68 29 20 28 61 70 70 6c ((search) (appl
6800: 79 20 73 65 61 72 63 68 20 61 72 67 73 29 29 0a y search args)).
6810: 20 20 20 20 20 20 20 20 28 28 67 65 74 29 20 28 ((get) (
6820: 61 70 70 6c 79 20 67 65 74 20 61 72 67 73 29 29 apply get args))
6830: 0a 20 20 20 20 20 20 20 20 28 28 6e 67 65 74 29 . ((nget)
6840: 20 28 61 70 70 6c 79 20 6e 67 65 74 20 61 72 67 (apply nget arg
6850: 73 29 29 0a 20 20 20 20 20 20 20 20 28 28 73 65 s)). ((se
6860: 74 21 29 20 28 61 70 70 6c 79 20 73 65 74 20 61 t!) (apply set a
6870: 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 28 28 rgs)). ((
6880: 6c 6f 63 61 6c 65 29 20 6c 6f 63 61 6c 65 29 0a locale) locale).
6890: 20 20 20 20 20 20 20 20 28 28 64 6f 6d 61 69 6e ((domain
68a0: 29 20 64 6f 6d 61 69 6e 29 0a 20 20 20 20 20 20 ) domain).
68b0: 20 20 28 28 64 69 72 73 29 20 64 69 72 73 29 0a ((dirs) dirs).
68c0: 20 20 20 20 20 20 20 20 28 28 66 69 6c 65 73 29 ((files)
68d0: 20 66 69 6c 65 73 29 0a 20 20 20 20 20 20 20 20 files).
68e0: 28 28 73 65 74 2d 6c 6f 63 61 6c 65 21 29 20 28 ((set-locale!) (
68f0: 73 65 74 21 20 6c 6f 63 61 6c 65 20 28 6c 69 73 set! locale (lis
6900: 74 69 66 79 20 28 63 61 72 20 61 72 67 73 29 29 tify (car args))
6910: 29 20 28 72 65 73 65 74 21 29 29 0a 20 20 20 20 ) (reset!)).
6920: 20 20 20 20 28 28 73 65 74 2d 64 6f 6d 61 69 6e ((set-domain
6930: 21 29 20 28 73 65 74 21 20 64 6f 6d 61 69 6e 20 !) (set! domain
6940: 28 6c 69 73 74 69 66 79 20 28 63 61 72 20 61 72 (listify (car ar
6950: 67 73 29 29 29 20 28 72 65 73 65 74 21 29 29 0a gs))) (reset!)).
6960: 20 20 20 20 20 20 20 20 28 28 73 65 74 2d 64 69 ((set-di
6970: 72 73 21 29 20 28 73 65 74 21 20 64 69 72 73 20 rs!) (set! dirs
6980: 28 6c 69 73 74 69 66 79 20 28 63 61 72 20 61 72 (listify (car ar
6990: 67 73 29 29 29 20 28 72 65 73 65 74 21 29 29 0a gs))) (reset!)).
69a0: 20 20 20 20 20 20 20 20 28 28 75 73 65 2d 63 61 ((use-ca
69b0: 63 68 65 29 20 28 73 65 74 21 20 63 61 63 68 65 che) (set! cache
69c0: 64 3f 20 28 63 61 72 20 61 72 67 73 29 29 29 0a d? (car args))).
69d0: 20 20 20 20 20 20 20 20 28 28 63 6c 65 61 72 29 ((clear)
69e0: 20 28 73 65 74 21 20 63 61 63 68 65 20 28 6d 61 (set! cache (ma
69f0: 6b 65 2d 63 61 63 68 65 29 29 29 0a 20 20 20 20 ke-cache))).
6a00: 20 20 20 20 29 29 29 29 0a 0a 3b 3b 20 63 61 63 ))))..;; cac
6a10: 68 65 20 74 68 65 20 6c 6f 6f 6b 75 70 73 20 61 he the lookups a
6a20: 6e 64 20 70 72 6f 76 69 64 65 20 61 20 6d 6f 72 nd provide a mor
6a30: 65 20 66 72 69 65 6e 64 6c 79 20 69 6e 74 65 72 e friendly inter
6a40: 66 61 63 65 2e 20 20 73 68 6f 75 6c 64 20 74 68 face. should th
6a50: 69 73 0a 3b 3b 20 74 61 6b 65 20 6b 65 79 77 6f is.;; take keywo
6a60: 72 64 20 61 72 67 75 6d 65 6e 74 73 3f 0a 3b 3b rd arguments?.;;
6a70: 20 28 6d 61 6b 65 2d 67 65 74 74 65 78 74 20 64 (make-gettext d
6a80: 6f 6d 61 69 6e 20 6c 6f 63 61 6c 65 20 64 69 72 omain locale dir
6a90: 73 20 63 64 69 72 20 67 65 74 74 65 78 74 2d 63 s cdir gettext-c
6aa0: 61 63 68 65 64 3f 20 6c 6f 6f 6b 75 70 2d 63 61 ached? lookup-ca
6ab0: 63 68 65 64 3f 29 0a 28 64 65 66 69 6e 65 20 6d ched?).(define m
6ac0: 61 6b 65 2d 67 65 74 74 65 78 74 0a 20 20 28 6c ake-gettext. (l
6ad0: 65 74 20 28 28 67 65 74 74 65 78 74 2d 6c 6f 6f et ((gettext-loo
6ae0: 6b 75 70 2d 63 61 63 68 65 20 28 6d 61 6b 65 2d kup-cache (make-
6af0: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 hash-table))).
6b00: 20 20 28 6c 61 6d 62 64 61 20 6f 70 74 0a 20 20 (lambda opt.
6b10: 20 20 20 20 28 6c 65 74 2d 6f 70 74 69 6f 6e 61 (let-optiona
6b20: 6c 73 2a 20 6f 70 74 0a 20 20 20 20 20 20 20 20 ls* opt.
6b30: 20 20 28 28 64 6f 6d 61 69 6e 30 20 27 28 22 64 ((domain0 '("d
6b40: 65 66 61 75 6c 74 22 29 29 0a 20 20 20 20 20 20 efault")).
6b50: 20 20 20 20 20 28 6c 6f 63 61 6c 65 30 20 23 66 (locale0 #f
6b60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 64 69 ). (di
6b70: 72 73 30 20 23 66 29 0a 20 20 20 20 20 20 20 20 rs0 #f).
6b80: 20 20 20 28 63 64 69 72 30 20 23 66 29 0a 20 20 (cdir0 #f).
6b90: 20 20 20 20 20 20 20 20 20 28 67 65 74 74 65 78 (gettex
6ba0: 74 2d 63 61 63 68 65 64 3f 20 23 74 29 0a 20 20 t-cached? #t).
6bb0: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 6b 75 70 (lookup
6bc0: 2d 63 61 63 68 65 64 3f 20 23 74 29 29 0a 20 20 -cached? #t)).
6bd0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 6f (let* ((do
6be0: 6d 61 69 6e 20 28 6c 69 73 74 69 66 79 20 64 6f main (listify do
6bf0: 6d 61 69 6e 30 29 29 0a 20 20 20 20 20 20 20 20 main0)).
6c00: 20 20 20 20 20 20 20 28 6c 6f 63 61 6c 65 20 28 (locale (
6c10: 6c 69 73 74 69 66 79 20 28 6f 72 20 6c 6f 63 61 listify (or loca
6c20: 6c 65 30 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e le0 (get-environ
6c30: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4c ment-variable "L
6c40: 41 4e 47 22 29 0a 20 20 20 20 20 20 20 20 20 20 ANG").
6c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c60: 20 20 20 20 20 20 20 20 20 20 28 67 65 74 2d 65 (get-e
6c70: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
6c80: 62 6c 65 20 22 4c 43 5f 41 4c 4c 22 29 20 22 43 ble "LC_ALL") "C
6c90: 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 "))).
6ca0: 20 20 20 20 28 64 69 72 73 31 20 28 6c 69 73 74 (dirs1 (list
6cb0: 69 66 79 0a 20 20 20 20 20 20 20 20 20 20 20 20 ify.
6cc0: 20 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 64 (or d
6cd0: 69 72 73 30 20 28 63 6f 6e 64 20 28 28 67 65 74 irs0 (cond ((get
6ce0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
6cf0: 69 61 62 6c 65 20 22 47 45 54 54 45 58 54 5f 50 iable "GETTEXT_P
6d00: 41 54 48 22 29 0a 20 20 20 20 20 20 20 20 20 20 ATH").
6d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3d 3e =>
6d30: 20 28 63 75 74 20 73 74 72 69 6e 67 2d 73 70 6c (cut string-spl
6d40: 69 74 20 3c 3e 20 22 3a 22 29 29 0a 20 20 20 20 it <> ":")).
6d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6d70: 20 20 20 28 65 6c 73 65 20 27 28 29 29 29 29 29 (else '()))))
6d80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6d90: 20 3b 3b 20 70 72 65 70 65 6e 64 20 64 65 66 61 ;; prepend defa
6da0: 75 6c 74 20 64 69 72 73 20 62 61 73 65 64 20 6f ult dirs based o
6db0: 6e 20 64 6f 6d 61 69 6e 0a 20 20 20 20 20 20 20 n domain.
6dc0: 20 20 20 20 20 20 20 20 28 64 69 72 73 20 28 61 (dirs (a
6dd0: 70 70 65 6e 64 20 28 68 61 73 68 2d 74 61 62 6c ppend (hash-tabl
6de0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 0a 20 20 e-ref/default.
6df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e00: 20 20 20 20 20 20 20 20 20 20 20 20 64 6f 6d 61 doma
6e10: 69 6e 2d 6d 65 73 73 61 67 65 2d 70 61 74 68 73 in-message-paths
6e20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 64 d
6e40: 6f 6d 61 69 6e 0a 20 20 20 20 20 20 20 20 20 20 omain.
6e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e60: 20 20 20 20 28 6d 65 73 73 61 67 65 2d 70 61 74 (message-pat
6e70: 68 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h)).
6e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e90: 20 64 69 72 73 31 29 29 0a 20 20 20 20 20 20 20 dirs1)).
6ea0: 20 20 20 20 20 20 20 20 28 63 64 69 72 20 28 6f (cdir (o
6eb0: 72 20 63 64 69 72 30 0a 20 20 20 20 20 20 20 20 r cdir0.
6ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ed0: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
6ee0: 74 2d 76 61 72 69 61 62 6c 65 20 22 4c 43 5f 43 t-variable "LC_C
6ef0: 41 54 45 47 4f 52 59 22 29 0a 20 20 20 20 20 20 ATEGORY").
6f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f10: 20 20 20 22 4c 43 5f 4d 45 53 53 41 47 45 53 22 "LC_MESSAGES"
6f20: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 3b 3b ))). ;;
6f30: 20 6f 70 74 69 6f 6e 61 6c 6c 79 20 6c 6f 6f 6b optionally look
6f40: 75 70 20 66 72 6f 6d 20 63 61 63 68 65 0a 20 20 up from cache.
6f50: 20 20 20 20 20 20 20 20 28 69 66 20 6c 6f 6f 6b (if look
6f60: 75 70 2d 63 61 63 68 65 64 3f 0a 20 20 20 20 20 up-cached?.
6f70: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6b (let* ((k
6f80: 65 79 20 28 6c 69 73 74 20 64 6f 6d 61 69 6e 20 ey (list domain
6f90: 6c 6f 63 61 6c 65 20 64 69 72 73 20 63 64 69 72 locale dirs cdir
6fa0: 20 67 65 74 74 65 78 74 2d 63 61 63 68 65 64 3f gettext-cached?
6fb0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
6fc0: 20 20 20 20 20 20 28 6c 6f 6f 6b 75 70 0a 20 20 (lookup.
6fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fe0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
6ff0: 66 2f 64 65 66 61 75 6c 74 20 67 65 74 74 65 78 f/default gettex
7000: 74 2d 6c 6f 6f 6b 75 70 2d 63 61 63 68 65 20 6b t-lookup-cache k
7010: 65 79 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 ey #f))).
7020: 20 20 20 20 20 20 20 28 75 6e 6c 65 73 73 20 6c (unless l
7030: 6f 6f 6b 75 70 0a 20 20 20 20 20 20 20 20 20 20 ookup.
7040: 20 20 20 20 20 20 28 73 65 74 21 20 6c 6f 6f 6b (set! look
7050: 75 70 20 28 6d 61 6b 65 2d 67 65 74 74 65 78 74 up (make-gettext
7060: 2d 69 6e 74 65 72 6e 61 6c 20 64 6f 6d 61 69 6e -internal domain
7070: 20 6c 6f 63 61 6c 65 20 64 69 72 73 0a 20 20 20 locale dirs.
7080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70b0: 20 63 64 69 72 20 67 65 74 74 65 78 74 2d 63 61 cdir gettext-ca
70c0: 63 68 65 64 3f 29 29 0a 20 20 20 20 20 20 20 20 ched?)).
70d0: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
70e0: 62 6c 65 2d 73 65 74 21 20 67 65 74 74 65 78 74 ble-set! gettext
70f0: 2d 6c 6f 6f 6b 75 70 2d 63 61 63 68 65 20 6b 65 -lookup-cache ke
7100: 79 20 6c 6f 6f 6b 75 70 29 29 0a 20 20 20 20 20 y lookup)).
7110: 20 20 20 20 20 20 20 20 20 6c 6f 6f 6b 75 70 29 lookup)
7120: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 . (ma
7130: 6b 65 2d 67 65 74 74 65 78 74 2d 69 6e 74 65 72 ke-gettext-inter
7140: 6e 61 6c 0a 20 20 20 20 20 20 20 20 20 20 20 20 nal.
7150: 20 64 6f 6d 61 69 6e 20 6c 6f 63 61 6c 65 20 64 domain locale d
7160: 69 72 73 20 63 64 69 72 20 67 65 74 74 65 78 74 irs cdir gettext
7170: 2d 63 61 63 68 65 64 3f 29 29 29 29 29 29 29 0a -cached?))))))).
7180: 0a 29 0a .).