Return to i18n.fs CVS log

Up to [gforth] / gforth

Annotation of gforth/i18n.fs, revision 1.1

1.1     ! pazsan      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]