1: \ Internationalization and localization
2:
3: \ This implementation keeps everything in memory, LSIDs are linked
4: \ together in lists. Each LSID has also a number, which is used to go
5: \ from native to local LSID.
6:
7: \ LSIDs
8:
9: AVariable lsids
10: 0 Value lsid#
11:
12: : native@ ( lsid -- addr u ) cell+ cell+ dup cell+ swap @ ;
13: : id#@ ( lsid -- n ) cell+ @ ;
14:
15: : search-lsid ( addr u -- lsid ) lsids
16: BEGIN @ dup WHILE >r 2dup r@ native@ str= r> swap UNTIL THEN
17: nip nip ;
18:
19: : append-list ( addr list -- )
20: BEGIN dup @ WHILE @ REPEAT ! ;
21:
22: : sl, ( addr u -- ) dup , here swap dup allot move align ;
23: : l, ( addr u -- )
24: here lsids append-list 0 A, lsid# dup , 1+ to lsid# sl, ;
25: : [l,] ( addr u -- addr ) 2>r
26: postpone AHEAD 2r> align here >r l,
27: [defined] bigFORTH [IF] 0 :r T&P [THEN]
28: postpone THEN r> ;
29:
30: : LLiteral 2dup search-lsid dup IF
31: nip nip
32: ELSE drop [l,] THEN
33: postpone ALiteral ; immediate
34:
35: : L" ( "lsid<">" -- lsid ) '"' parse
36: state @ IF postpone LLiteral
37: ELSE 2dup search-lsid dup IF
38: nip nip
39: ELSE drop align here >r l, r> THEN
40: THEN ; immediate
41:
42: \ deliberately unique string
43: : LU" ( "lsid<">" -- lsid ) '"' parse
44: state @ IF [l,] postpone ALiteral
45: ELSE align here >r l, r>
46: THEN ; immediate
47:
48: : .lsids ( lsids -- ) BEGIN @ dup WHILE dup native@ type cr REPEAT drop ;
49:
50: \ locale@ stuff
51:
52: $3 Constant locale-depth \ lang country variances
53: Variable locale-stack locale-depth 1+ cells allot
54: here 0 , locale-stack cell+ !
55:
56: : >locale ( lsids -- )
57: locale-stack dup cell+ swap @ 1+ cells + ! 1 locale-stack +!
58: locale-stack @ locale-depth u>= abort" locale stack full" ;
59: : locale-drop ( -- ) -1 locale-stack +!
60: locale-stack @ locale-depth u>= abort" locale stack empty" ;
61: : locale' ( -- addr ) locale-stack dup cell+ swap @ cells + @ ;
62:
63: : Locale Create 0 , DOES> locale-stack off >locale ;
64: : Country Create 0 , , DOES> locale-stack off dup cell+ @ >locale >locale ;
65:
66: : set-language ( lang -- ior ) locale-stack off >locale 0 ;
67: : set-country ( country -- ior )
68: dup cell+ @ set-language >locale 0 ;
69:
70: : search-lsid# ( id# lsids -- lsid )
71: BEGIN @ dup WHILE >r dup r@ cell+ @ = r> swap UNTIL THEN
72: nip ;
73:
74: Variable last-namespace
75:
76: : locale@ ( lsid -- addr u ) last-namespace off
77: dup >r id#@
78: locale-stack dup cell+ swap @ cells bounds swap DO
79: dup I @ search-lsid# dup IF
80: I last-namespace !
81: nip native@ unloop rdrop EXIT THEN
82: drop
83: cell -LOOP drop r>
84: native@ ;
85:
86: : lsid@ ( lsid -- addr u ) last-namespace @ IF
87: dup >r id#@
88: last-namespace @ locale-stack cell+ DO
89: dup I @ search-lsid# dup IF
90: nip native@ unloop rdrop EXIT THEN
91: drop
92: cell -LOOP drop r>
93: THEN native@ ;
94:
95: : locale! ( addr u lsid -- ) >r
96: 2dup r@ locale@ str= IF rdrop 2drop EXIT THEN
97: r> id#@ here locale' append-list 0 A, , sl, ;
98:
99: : native-file ( fid -- ) >r
100: BEGIN pad $1000 r@ read-line throw WHILE
101: pad swap l, REPEAT
102: drop r> close-file throw ;
103:
104: : locale-file ( fid -- ) >r lsids
105: BEGIN @ dup WHILE pad $1000 r@ read-line throw
106: IF pad swap 2 pick locale! ELSE drop THEN REPEAT
107: drop r> close-file throw ;
108:
109: : included-locale ( addr u -- ) r/o open-file throw
110: locale-file ;
111:
112: : included-native ( addr u -- ) r/o open-file throw
113: native-file ;
114:
115: [defined] getpathspec 0= [IF]
116: : getpathspec ( -- fd ) parse-name r/o open-file throw ;
117: [THEN]
118:
119: : include-locale ( -- ) getpathspec locale-file ;
120: : include-native ( -- ) getpathspec native-file ;
121:
122: \ easy use
123:
124: : x" state @ IF postpone l" postpone locale@
125: ELSE ['] l" execute locale@ THEN ; immediate
126:
127: l" FORTH" Aconstant forth-lx
128: [defined] gforth [IF] s" Gforth" forth-lx locale! [THEN]
129: [defined] bigforth [IF] s" bigFORTH" forth-lx locale! [THEN]
130: [defined] VFXforth [IF] s" VFX FORTH" forth-lx locale! [THEN]
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>