---

fhp -ml

Código fuente

CR .( fhp-ml  )

\ Copyright (C) 2006,2007,2014 Marcos Cruz (programandala.net)

\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp.html).
\ This module provides the multilingual tools.

\ fhp is free software; you can redistribute it and/or modify
\ it under the terms of the GNU General Public License as published by
\ the Free Software Foundation; either version 2 of the License, or
\ (at your option) any later version.
\
\ fhp is distributed in the hope that it will be useful, but
\ WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
\ General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with fhp; if not, see <http://gnu.org/licenses>.

\ fhp is written in the Forth language
\ with Gforth (http://gnu.org/software/gforth/).

\ .............................................................
\ To do

\ -finish every-ndup
\ -fix the order commands in 2execute/lang

\ .............................................................
\ History (in reversed order)

\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2014-04-07: '((+extension))' factored out from '(+extension)';
\ needed by ForthCMS2Fendo.
\
\ 2007-10-03: DUP/LANG renamed to EVERY-DUP .  2DUP/LANG renamed to
\ EVERY-2DUP .  Kernel words defered to make possible page language
\ control in forthCMS.
\
\ 2007-06-19: 'ISO-CODE renamed to ''ISO-CODE .
\
\ 2007-06-18: New value DEFINED-LANGS to keep the original LANGS value
\ when changing between debug and normal modes.  This was needed to
\ implement DEBUG-MODE and NORMAL-MODE in the forthCMS layer (formerly
\ they were defined in every application, where the number of defined
\ languages is known).
\
\ 2007-04-12: CURRENT-PAGE variable and CURRENT-PAGE? word deprecated.
\ A new word in the forthcms-pagestruct module,  CURRENT-PAGE-FILE? ,
\ will do the job of the CURRENT-PAGE?
\
\ 2007-04-10: More flexible and configurable language creation system.
\ New words: MAX-LANGS , ''ISO-CODES , 'ISO-CODE and ISO-CODE .
\ >ISO-LANG is deleted. Now its job is done by ISO-CODE .
\
\ 2007-04-08: Added EVERY-CMS-TITLE-LINK .  +EVERY-LANG renamed to
\ 2EXECUTE/LANG .
\
\ 2007-04-07: Added [EVERY] and (EVERY) . EVERY is not immediate any
\ more (there was no need for that).  The old EVERY-LANG is needed no
\ more. It made the function (EVERY) does now. It is clearer to use
\ [EVERY] and EVERY .  The word MULTILINGUAL: is renamed as
\ ML-SCONSTANT to be parallel with ML-SVARIABLE .
\
\ 2007-03-30: Added DUP/LANG , needed when implementing page-id% as
\ parameter for CREATE-PAGES instead of the page file.
\
\ 2007-02-07: +".HTML" is moved to the fhp-path module, so it can be
\ used also in monolingual sites.  +EXTENSION is moved to the fhp-path
\ module and defered, so it can be used also in monolingual sites. By
\ default it executes +".HTML" .  +EXTENSION-ML is the new name for
\ the old +EXTENSION and also its defered code for multiligual sites.
\
\ 2006-11-22: New variable (ML-PAGE-TITLE) .
\
\ 2006-11-20: +"_LANG" modified and renamed to +".LANG" .  Now it uses
\ a dot, the standard in language negotiation, instead of an
\ underscore.
\
\ 2006-10-04: New words 'LANG-EXTENSION? and LANG-EXTENSION? to
\ control which language needs language file extension. Formerly, all
\ languages had it but the first one.
\
\ 2006-08-24: New words LANG-COMMON-KEYWORDS and (COMMON-KEYWORDS-ML)
\ .
\
\ 2006-08-08: New variable CURRENT-PAGE , taken from a fhp
\ application. Is stores the base filename of the current HTML,
\ without language and filename extensions.  Bug fixed: CURRENT-PAGE?
\ now does not call CURRENT-HTML?  New word PARAMETERS/LANG and
\ related variables: #PARAMETERS and #PARAMETERS-1 .
\
\ 2006-06-26: New word 2DUP/LANG , taken from the application that
\ creates my site alinome.net/bici.
\
\ 2006-06-24: The word MULTILINGUAL: is improved. Now it works with
\ any number of languages.
\
\ 2006-03: First working version.

\ .............................................................
\ Init

MARKER fhp-ml

\ .............................................................
\ Languages

3 CONSTANT max-langs  \ maximum number of languages *APP_CONFIGURATION_IS_POSSIBLE*
0 VALUE defined-langs  \ number of languages defined
0 VALUE langs  \ number of languages used
VARIABLE lang  \ current language

-1 CONSTANT all  \ dummy "language code" that means "all languages"

CREATE ''iso-codes max-langs CELLS ALLOT  \ space for the addresses of the ISO codes

: ''iso-code  ( u -- addr )

  \ u = language code
  \ addr = address of the address of the ISO code

  CELLS ''iso-codes +

  ;

: iso-code  ( u1 -- c-addr u2 )

  \ u1 = language code
  \ c-addr u2 = language ISO code

  ''iso-code @ COUNT

  ;

false [IF]  \ old version of LANGUAGE:

: language:  ( c-addr u "<spaces>name" -- )

  \ Create a new language identifier

  \ c-addr u = language official ISO code
  \ name = language id

  \ 2007-04-07
  \ 2007-04-10 Rewritten.
  \ 2007-06-18 The new value DEFINED-LANGS is the main counter, while LANGS is updated at the end.

  HERE >R s,  R> defined-langs ''iso-code !  \ compile the string and keep its address
  defined-langs CONSTANT  \ make the identifier
  defined-langs 1+ DUP
  TO defined-langs
  TO langs

  ;

\ Obsolete examples:
\ The user app must create its own list of languages, like in this example:
\ S" es" language: es  \ Castellano / Español
\ S" eo" language: eo  \ Esperanto
\ S" en" language: en  \ English

[THEN]

: language:  ( "<spaces>name" -- )

  \ Create a new language identifier

  \ name = language id, usually the ISO language code

  \ 2007-06-19 New smarter version.

  BL WORD COUNT
  DUP 0= ABORT" Input stream exhausted in LANGUAGE:"

  HERE >R 2DUP s,  R> defined-langs ''iso-code !  \ compile the string and keep its address

  S" defined-langs CONSTANT " 2SWAP str+ EVALUATE  \ create the constant identifier
  defined-langs 1+ DUP  TO defined-langs  TO langs  \ update the counters

  ;

\ *APP_CONFIGURATION_IS_MANDATORY*
\ The user app must create its own list of languages, like in this example:
\ language: es  \ Castellano / Español
\ language: eo  \ Esperanto
\ language: en  \ English
\ And then some syntactic sugar to make the source code easier (as explained later in this file):
\ : :es es :lang ;
\ : :eo eo :lang ;
\ : :en en :lang ;

: iso-lang  ( -- c-addr u )

  \ Return the ISO code of the current language.

  \ c-addr u = ISO code

  \ 2006-09-09 Factored out to >ISO-LANG
  \ 2007-04-10 Modified.

  lang @ iso-code

  ;

CREATE page-fids  max-langs CELLS ALLOT  \ file id of every language version

: +lang  ( a-addr1 -- a-addr2 )

  \ Change an address depending on the current language.

  \ a-addr1 = base address.
  \ a-addr2 = address offsetted for the current language.

  \ 2008-07-19 Factored from ML-CONSTANT@ and LANG-FID .

  lang @ CELLS +

  ;

: lang-fid  ( -- a-addr )

  \ 2006-03-14

  \ Calculate the current language address in page-fids .

  page-fids +lang

  ;

: save-html-fid  ( -- )

  \ 2006-03-14

  html-fid @ lang-fid !

  ;

: restore-html-fid  ( -- )

  \ 2006-03-14

  lang-fid @ html-fid !

  ;

: lang>html  iso-lang >>html  ;

\ .............................................................
\ Language selection

0 VALUE '(>>all-html)  \ later calculated
: monolingual-mode ['] (>>html) is >>html ;
: multilingual-mode '(>>all-html) is >>html ;
: :lang  ( u -- )  lang ! restore-html-fid monolingual-mode ;

: :all  multilingual-mode  all lang ! ; \ activate all pages

\ *APP_CONFIGURATION_IS_MANDATORY*
\ Language selection words like these must be defined by the user app, after defining the languages:
\ : :es  es :lang ;  \ activate the Spanish page
\ : :eo  eo :lang ;  \ activate the Esperanto page
\ They will be used in the source that builds the XTHML.

VARIABLE saved-lang

: save-lang  ( -- )

  \ Save the current language.

  lang @ saved-lang !

  ;

: restore-lang  ( -- )

  \ Restore de language saved by SAVE-LANG .

  saved-lang @ DUP all =
  IF   DROP :all
  ELSE :lang
  THEN

  ;

\ .............................................................
\ Stack parameters duplication

\ These words duplicate parameters in the stack as many times as the number of languages used.
\ That is needed before executing code for every language with EVERY , [EVERY] or 2EXECUTE/LANG (see later).
\ The defered core words are re-vectored in the source file forthcms-ml.f, to make possible the page language control,
\ that is, not every language are efective in the loop, but just the languages the actual page has versions in.

2VARIABLE every-2parameter  \ to keep the cell that EVERY-2DUP must duplicate

defer (every-2dup)

: default-(every-2dup) ( u -- x1 x2 )

  \ u = language id

  DROP every-2parameter 2@

  ;

' default-(every-2dup) is (every-2dup)

: every-2dup  ( c-addr1 u1 -- c-addr1 u1 | c-addr1 u1 ... c-addr-n u-n )

  \ Duplicate the string on the stack for every language other than the main one.

  \ 2006-06-26

  \ First version, when ?DO was not yet implemented in Forth 5mx:
\  langs
\  BEGIN  1- DUP
\  WHILE  >R 2DUP R>
\  REPEAT  DROP

  \ 2007-10-01 Factored out with the defered word (2DUP/LANG) , to make possible the page language control.
  \ 2007-10-02 Loop first limit changed from 1 to 0.

  every-2parameter 2!
  langs 0 ?DO  I (every-2dup)  LOOP

  ;

' every-2dup alias 2dup/lang  \ x!!! old name

VARIABLE every-parameter  \ to keep the cell that EVERY-DUP must duplicate

defer (every-dup)

: default-(every-dup)  ( u -- x )

  \ u = language id
  \ x = content of the variable PARAMETER

  DROP every-parameter @

  ;

' default-(every-dup) is (every-dup)

: every-dup  ( u -- u | u ... u-n )

  \ Duplicate the cell on the stack for every language other than the main one.

  \ 2007-03-30
  \ 2007-10-01 Factored out with the defered word (DUP/LANG) , to make possible the page language control.
  \ 2007-10-02 Loop first limit changed from 1 to 0.

  every-parameter !
  langs 0 ?DO  I (every-dup)  LOOP

  ;

' every-dup alias dup/lang  \ x!!! old name

false [IF]  \ obsolete!!!

VARIABLE #parameters
0 VALUE #parameters-1

: parameters/lang  ( i*x n -- i*x ... i*x )

  \ Duplicate n stack cells for every language other than the main one.

  \ 2006-08-08
  \ 2006-12-24 Bug fixed: now n can be 0 ( with ?DO instead of DO ).

  \ :!!! this has to be adapted to page language control

  DUP #parameters !
  1- TO #parameters-1
  langs
  BEGIN
      1- DUP
  WHILE
    >R
    #parameters @ 0  ?DO
      #parameters-1 PICK
    LOOP
    R>
  REPEAT  DROP

  ;

[THEN]

\ :!!!
\ New (unfinished) version of parameteres/lang :

0 VALUE #parameters  \ number of parameters
0 VALUE 'parameters  \ address of the temporal store space
0 VALUE 'last-parameter  \ adderss of the lasta parameter in the temporal store space

: !parameters  ( x1 ... xn --  )

  \ Store the parameters into the temporal store space.
  \ This could be done faster with MOVE and SP :!!!

  \ 2007-10-03
  \ 2007-10-08 Bug fixed: CELLS added.

  'parameters #parameters 1- CELLS + TO 'last-parameter
  #parameters 0  DO
    'last-parameter I CELLS - !
  LOOP

  ;

: every-ndup-init  ( x1 ... xn n -- x1 ... xn )

  \ Init the values needed by EVERY-NDUP .

  \ 2007-10-03

  TO #parameters
  HERE TO 'parameters  \ temporal store address
  !parameters

  ;

defer (every-ndup)

: default-(every-ndup)  ( u -- )

  \ Put on the stack a copy of all the parameters.

  \ u = language id

  \ 2007-10-03
  \ 2007-10-08 Bug fixed: CELLS added.

  DROP  \ language id is useless in this version, without page language control
  #parameters 0  DO
    'parameters I CELLS + @
  LOOP

  ;

' default-(every-ndup) is (every-ndup)

: every-ndup  ( x1...xn n -- x1...xn | x1...xn1 ... x1...xnn )

  \ Put on the stack the upper n stack cells as many times as languages versions the current page has.

  \ 2007-10-03

  every-ndup-init
  langs 0 DO  I (every-ndup)  LOOP

  ;

' every-ndup alias parameters/lang  \ x!!! old name

: every-n2dup  ( x1 x1'...xn xn' n -- x1 x1' ... xn xn' | x1 x1'...xn xn' ... x1 x1'...xnn xnn' )

  \ Put on the stack the upper n stack double cells as many times as languages versions the current page has.

  \ 2008-01-27

  2* every-ndup

  ;

\ .............................................................
\ Code execution for every language

VARIABLE xt/lang  \ used to keep the stack clean

defer ((every))

: default-((every))  ( u -- )

  \ Default inner commands of (EVERY) .

  \ u = language id

  \ 2007-10-01

  :lang  xt/lang @ EXECUTE

  ;

' default-((every)) is ((every))  \ this is changed in the source file forthcms-pagestruct.f to implement page language control

: (every)  ( i*x xt -- j*x )

  \ Execute xt for every language.
  \ The parameteres have to be repeated for all languages.

  \ 2006-03-13
  \ 2007-04-07 Renamed (formerly EVERY-LANG ).
  \ 2007-10-01 Factored out to the defered ((EVERY)) to make possible the page language control at an upper layer.

  xt/lang !  save-lang
  langs 0  DO  I ((every))  LOOP
  restore-lang

  ;

: [every]  ( i*x "<spaces>name" -- j*x )

  \ Compile the xt of next word in the stream to call (EVERY) later.
  \ Compile mode only.

  \ 2007-04-07

  POSTPONE [']  POSTPONE (every)

  ;  IMMEDIATE

: every  ( i*x "<spaces>name" -- j*x )

  \ Execute the next word in the stream for every language.

  \ 2006-05-07

  ' (every)

  ;

: 2execute/lang  ( xt1 xt2 -- )

  \ Execute xt1 for every language, and then xt2 also for every language.

  \ xt1 = execution token that creates the needed parameters for xt2 (usually a multilingual constant or variable)
  \ xt2 = execution token of main code to be executed for every language

  \ 2006-05-06
  \ 2007-04-08 Renamed (formerly +EVERY-LANG ).

  >R (every)  \ create the language versions of the text
\  2SWAP 2ROT  \ sort them 3 :!!! this should sort any number of strings!!!
  R> (every)

  ;

\ .............................................................
\ Multilingual print

: (>>all-html)  ( c-addr u -- )

  \ Print a string (into the HTML file) for every language.

  \ This word is used to vector the print core functions while in multilingual mode.

  \ 2006-03-16

  save-lang
  langs 0  DO
    I :lang 2DUP (>>html)
  LOOP
  2DROP  restore-lang

  ;

' (>>all-html) TO '(>>all-html)

\ .............................................................
\ File names and file name extensions

svariable lang-separator  S" ." lang-separator place

: +lang-separator  ( c-addr1 u1 -- c-addr2 u2 )

        \ 2006-12-04

        lang-separator COUNT str+

        ;

: (+".lang")  ( c-addr1 u1 u3 -- c-addr2 u2 )

        \ c-addr1 u1 = file name without extension
        \ u3 = language code
        \ c-addr2 u2 = file name with language extension

        \ 2006-12-04

        >R +lang-separator R> iso-code str+

  ;

: +".lang"  ( c-addr1 u1 -- c-addr2 u2 )

        \ c-addr1 u1 = file name without extension
        \ c-addr2 u2 = file name with current language extension

  \ 2006-03-14
        \ 2006-11-26 improved with LANG-SEPARATOR

        +lang-separator iso-lang str+

  ;

CREATE 'lang-extension? max-langs CELLS ALLOT  \ one cell flag for every language

: lang-extensions!  ( flag -- )

  \ Fill all language extensions flags with a flag.

  'lang-extension? max-langs CELLS ROT FILL

  ;

true lang-extensions!  \ by default, all languages have its extension activated

: lang-extension?  ( u -- addr )

  \ u = language code
  \ addr = language flag variable

  \ 2006-10-04
  \ 2006-10-26 bug fixed: CELLS added!

  CELLS 'lang-extension? +

  ;

: ((+extension))  ( c-addr1 u1 u3 -- c-addr2 u2 )
  \ 2014-04-07 Factored out from '(+extension)', needed by
  \ ForthCMS2Fendo.
  DUP lang-extension? @
  IF  (+".lang")  ELSE  DROP  THEN  +".html"
  ;

: (+extension)  ( c-addr1 u1 u3 -- c-addr2 u2 )

  \ Add a extension (both language and file type) to a file name.

  \ CONFIGURATION!!! This can be changed by the user if other format is prefered.

  \ c-addr1 u1 = "filename" without extensions
  \ u3 = language id
  \ c-addr2 u2 =  "filename.lang.html" where "lang" is the language code, if that language is configured so.

  \ 2006-04-29
  \ 2006-10-04 Improved with LANG-EXTENSION? Now the programmer can control, which language needs language file extension. Formerly, all languages had it but the first one.
    \ 2006-12-04 Bug fixed. The word +".LANG" did not use the parameter but the current language! New word (+".LANG") used.
  \ 2010-10-08 Support for Simplilo's format output.
  \ 2012-07-31 Fendo support.

  simplilo? fendo? OR  IF
    iso-code +lang-separator 2SWAP str+
  ELSE  ((+extension))  THEN

  ;

: +extension-ml  ( c-addr1 u1 -- c-addr2 u2 )

  \ 2006-03-14
  \ 2006-11-20 Documented
  \ 2007-02-07 Renamed from +EXTENSION to defer the translated +EXTENSION

  \ Añade a un nombre de archivo el indicador de la lengua actual y la extensión.

  \ c-addr1 u1 = "filename" without extensions
  \ c-addr2 u2 =  "filename.lang.html" where "lang" is the language code, if that language is configured so.

  lang @  (+extension)

  ;

' +extension-ml is +extension

\ .............................................................
\ Multilingual constants and variables

\ Note:
\ Multilingual constants and variables
\ should not be executed while the current language is the dummy "all".
\ In that case, the execution will return an unpredictable result that may hang the system.
\ Use the words EVERY , [EVERY] and related to call code that uses multilingual string constant or variables.

: (ml-constant)  ( x1 ... x-n -- )

  \ Store the values of a multilingual constant.

  \ Note: This word depends on LANGS and therefore can not be used until the languages are defined by the user application.

  \ x1 = value for the last language used
  \ x-n = value for the first language used

  \ 2008-07-19 Adapted from (ML-SCONSTANT) .

  langs 0 DO  ,  LOOP

  ;

: ml-constant@  ( a-addr -- x )

  \ Return the content of a multilingual constant.

  \ a-addr = address of the value cells.

  \ 2008-07-19 Adapted from ML-SCONSTANT@ .

  +lang  @

  ;

: ml-constant   ( x1 ... x-n "<spaces>name" -- )

  \ Create a word that, when executed,
  \ will return one of several cells,
  \ the one for the current language.

  \ Note: This word depends on LANGS and therefore can not be used until the languages are defined by the user application.

  \ x1 = cell for in the last language used
  \ x-n = cell for the first language used

  \ 2008-07-19 Adapted from ml-sconstant .

  CREATE
    (ml-constant)  \ store all the cells "here"
  DOES>  ( pfa -- x )
    ml-constant@  \ return the right cell

  ;

\ Usage:
\ 10  \ English
\ 20  \ Esperanto
\ 20  \ Castellano
\ ml-constant number

VARIABLE 'ml-constants  \ :!!! needed in the Win32Forth versions

: :ml-constant   ( x1 ... x-n -- xt )

  \ Create a multilingual constant with no name:
  \ Return an xt that, when executed, will
  \ return one of the values, the one
  \ for the current language.

  \ This word was written to make it easier to store multilingual values
  \ into the fields of a forthCMS page structure.
  \ This word makes it unnecessary to define multilingual constants just to
  \ store their xt into the record to be created.
  \ See the file forthCMS-pagestruct.f for more info.

  \ Note: This word depends on LANGS
  \ and therefore can not be used
  \ until the languages are defined by the user application.

  \ x1 = value for the last language used
  \ x-n = value for the first language used
  \ xt = execution token to do the job of a multilingual constant

  \ 2008-07-19 Adapted from :ML-SCONSTANT .

  \ Second version.

  HERE 'ml-constants !  (ml-constant)
  S" :NONAME  ( Compilation time: -- xt )  ( Run time: -- c-addr u ) [ 'ml-constants @ ] LITERAL ml-constant@  ;"
  EVALUATE  \ create the new headerless word and leave its xt on the stack

  ;

0 [IF] \ :!!! unfinished

VARIABLE 'ml-constant  \ :!!! needed in the Win32Forth versions

: :constant   ( x -- xt )

  \ Create a constant with no name.
  \ Return an xt that, when executed, will
  \ return the value.

  \ x = value
  \ xt = execution token to do the job of a constant

  \ 2008-07-19 Adapted from :SCONSTANT .

  HERE 'constant ! s,
  S" :NONAME  ( Compilation time: -- xt )  ( Run time: -- c-addr u )  [ 'constant @ ] LITERAL  ;"
  EVALUATE  \ create the new headerless word and leave its xt on the stack

  ;

[THEN]

: ml-variable  ( "<spaces>name" -- )

  \ Create a word that works as a normal variable,
  \ but depends on the current language.
  \ The multilingual variable keeps several values,
  \ one for every language used.
  \ The working is transparent to the user.

  CREATE
    HERE   max-langs CELLS
    DUP ALLOT ALIGN  ERASE
  DOES>  ( pfa -- a-addr )
    +lang

  ;



\ .............................................................
\ Multilingual string constants and variables

\ Note:
\ Multilingual string constants and variables
\ should not be executed while the current language is the dummy "all".
\ In that case, the execution will return an unpredictable result that may hang the system.
\ Use the words EVERY , [EVERY] and related to call code that uses multilingual string constant or variables.

: s,!  ( c-addr1 u1 a-addr u -- )

  \ Compile a string and keep its new address
  \ into the a-addr address plus the u offset.

  \ c-addr1 u1 = string
  \ a-addr = base address
  \ u = offset

  \ 2006-03-12

  CELLS + HERE SWAP !  s,

  ;

VARIABLE multilingual-index

: (ml-sconstant)  ( a-addr1 u1 ... c-addr-n u-n -- )

  \ Store the strings of a multilingual string constant.

  \ Note: This word depends on LANGS and therefore can not be used until the languages are defined by the user application.

  \ c-addr1 u1 = string in the last language used
  \ c-addr-n u-n = string in the first language used

  \ 2007-06-21 Factored from ML-SCONSTANT .

  HERE multilingual-index !

  langs CELLS ALLOT  \ index
  langs 0 DO
    multilingual-index @ I s,!
  LOOP
  ALIGN

  ;

: ml-sconstant@  ( a-addr -- c-addr u )

  \ Return the content of a multilingual string constant.

  \ a-addr = address of the strings index.

  \ 2008-01-19 Factored from ML-SCONSTANT and :ML-SCONSTANT .
  \ 2008-07-19 Factored out with ML-CONSTANT@ .

  ml-constant@  COUNT

  ;

: ml-sconstant   ( a-addr1 u1 ... c-addr-n u-n "<spaces>name" -- )

  \ Create a word that, when executed,
  \ will return one of several texts,
  \ the one in the current language.

  \ Note: This word depends on LANGS and therefore can not be used until the languages are defined by the user application.

  \ c-addr1 u1 = string in the last language used
  \ c-addr-n u-n = string in the first language used

  \ 2006-03-12
  \ 2007-03-12 Little improve: CELL instead of 1 CELLS in the DOES> part.
  \ 2007-04-07 Renamed (formerly MULTILINGUAL: )-
  \ 2007-04-10 Little improve: CELLS instead of CELL * in the DOES> part.
  \ 2007-06-21 Factored to (ML-SCONSTANT) .
  \ 2008-01-19 Factored to ML-SCONSTANT@ .

  CREATE
    (ml-sconstant)  \ store all the strings "here"
  DOES>  ( pfa -- c-addr u )
    ml-sconstant@  \ return the right string

  ;

' ml-sconstant alias multilingual:  \ old name

\ Usage:

\ S" XHTML 1.0 validator"  \ English
\ S" Ekzamenilo de XHTML 1.0"  \ Esperanto
\ S" Verificador de XHTML 1.0"  \ Castellano
\ ml-sconstant "xhtml"

VARIABLE 'ml-sconstants  \ :!!! needed in the Win32Forth versions

: :ml-sconstant   ( a-addr1 u1 ... c-addr-n u-n -- xt )

  \ Create a multilingual string constant with no name:
  \ Return an xt that, when executed, will
  \ return one of the strings, the one
  \ in the current language.

  \ This word was written to make it easier to store multilingual texts
  \ into the fields of a forthCMS page structure.
  \ This word makes it unnecessary to define multilingual string constants just to
  \ store their xt into the record to be created.
  \ See the file forthCMS-pagestruct.f for more info.

  \ Note: This word depends on LANGS
  \ and therefore can not be used
  \ until the languages are defined by the user application.

  \ c-addr1 u1 = string in the last language used
  \ c-addr-n u-n = string in the first language used
  \ xt = execution token to do the job of a multilingual string constant

  \ 2007-06-21
  \ 2007-06-28 Adapted to Win32Forth.

  [ FALSE ] [IF]

    \ First version.
    \ This works in Forth 5mx.
    \ This doesn't work in Win32Forth: it doesn't permit to change the stack while compiling a definition.
    \ This doesn't work in gforth: it halts while evaluating the string with the error "unbalanced".

    HERE >R  (ml-sconstant)  R>
    S" :NONAME  ( Compilation time: a-addr -- xt )  ( Run time: -- c-addr u ) ( a-addr xt -- ) [ SWAP ] LITERAL ml-sconstant@  ;"
    EVALUATE  \ create the new headerless word and leave its xt on the stack

  [THEN]

  [ TRUE ] [IF]

    \ Second version.

    HERE 'ml-sconstants !  (ml-sconstant)
    S" :NONAME  ( Compilation time: -- xt )  ( Run time: -- c-addr u ) [ 'ml-sconstants @ ] LITERAL ml-sconstant@  ;"
    EVALUATE  \ create the new headerless word and leave its xt on the stack

  [THEN]

  [ FALSE ] [IF]

    \ :!!! Experimental unfinished version.

    HERE >R  (ml-sconstant)  R>
    :NONAME  ( a-addr xt -- )
    POSTPONE SWAP
    POSTPONE ml-sconstant@
    POSTPONE ;

  [THEN]

  ;

: :sconstant   ( a-addr1 u1 -- xt )

  \ Create a string constant with no name:
  \ Return an xt that, when executed, will
  \ return the string.

  \ This word was written to make it easier to migrate
  \ from a monolingual website to a multilingual one,
  \ using the same kind of xt field to store the strings
  \ into the forthCMS page structure.
  \ See the file forthCMS-pagestruct.f for more info.

  \ c-addr1 u1 = string
  \ xt = execution token to do the job of a string constant

  \ 2007-06-21

  [ FALSE ] [IF]
    \ First version.
    \ This works in Forth 5mx.
    \ This doesn't work in Win32Forth: it doesn't permit to change the stack while compiling a definition.
    \ This doesn't work in gforth: it halts while evaluating the string with the error "unstructured".
    HERE >R s, R>
    S" :NONAME  ( Compilation time: a-addr -- xt )  ( Run time: -- c-addr u ) ( a-addr xt -- )  [ SWAP ] LITERAL COUNT  ;"
    EVALUATE  \ create the new headerless word and leave its xt on the stack
  [THEN]

  [ TRUE ] [IF]
    \ Second version.
    HERE 'ml-sconstants ! s,
    S" :NONAME  ( Compilation time: -- xt )  ( Run time: -- c-addr u )  [ 'ml-sconstants @ ] LITERAL COUNT  ;"
    EVALUATE  \ create the new headerless word and leave its xt on the stack
  [THEN]

  [ FALSE ] [IF]
    \ :!!! Experimental unfinished version.
    HERE >R s, R>
    :NONAME
    ( Compilation time: a-addr -- xt )
    ( Run time: -- c-addr u )
    ( a-addr xt -- )
    SWAP
    LITERAL
    POSTPONE COUNT
    POSTPONE ;
  [THEN]


  ;

: ml-svariable  ( "<spaces>name" -- )

  \ Create a word that works as a normal string variable,
  \ but depends on the current language.
  \ The multilingual string variable keeps a list
  \ of addresses to strings, one for every language used.
  \ The working is transparent to the user.

  HERE DUP  \ address of the list of addresses
  max-langs CELLS  DUP ALLOT  ERASE

  CREATE ,

  DOES>  ( pfa -- c-addr )

    \ Return the variable content as a counted string, for the current language.

    @  lang @ CELLS  +  \ get the address of the string
    DUP  @ 0=  IF
      \ The string for the current language has no memory space reserved yet.
      HERE 256 2DUP ERASE ALLOT ALIGN  \ make it
      \ :!!! note: 256 should be calculated from the system.
      OVER !  \ keep its address
    THEN  @

  ;


\ .............................................................
\ Misc

: >span-lang?  ( c-addr1 u1 u2 -- c-addr3 u3 )

  \ Mark a text with a language code, if it's not the current language.

  \ c-addr1 u1 = text
  \ u2 = language number
  \ c-addr3 u3 = same or new string

  \ 2006-09-09

  DUP lang @ <>
  IF  iso-code >span-lang
  ELSE  DROP
  THEN

  ;

.(  fhp-ml ok!)