Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.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] |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |