fhp -ml
Descripción del contenido de la página
Módulo del programa fhp que añade capacidad plurilingüe.
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!)