Return to i18n.fs CVS log

Up to [gforth] / gforth

Added i18n wordset (from bigForth)

    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]