fhp

Description of the page content

Forth tools to create HTML documents.

Tags:

fhp is a toolkit I wrote in order to build XHTML web pages. It soon became the low-level layer of a more complex program, an actual website engine, called ForthCMS.

I developed and used fhp with my own Forth 5mx written for the Psion 5mx. Some years later I adapted fhp to work also on Gforth.

Source code

fhp.fs

\ fhp.fs
cr .( fhp  )

\ Copyright (C) 2004,2005,2006,2007,2008,2009,2010,2012 Marcos Cruz (programandala.net)

\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This is the main file: it does some general configuration
\ and loads all fhp modules.

\ 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/).

\ .............................................................
\ History

\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2004-12: This project started.  Every fhp module has a a detailed change
\ history in its source.
\
\ 2008-01-20:  The word LOCAL-SLASH is not a constant any more but a value, to
\ make it easier to configure; now it changes depending on the Forth system.
\
\ 2010-10-07: First support for Simplilo's format output: 'simplilo?' flag.
\
\ 2012-07-31: First support for Fendo's format output: 'fendo?' flag.

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

[undefined] from_forth5mx  [IF]  S" from_forth5mx.fs" INCLUDED  [THEN]

\ [undefined] fstr  [IF]  S" fstr.fs" INCLUDED  [THEN]  \ strings toolkit needed
[undefined] ftrac  [IF]
  S" ftrac/ftrac.fs" INCLUDED  \ char translation tool needed
  S" ftrac/ftrac-utf8es.fs" INCLUDED \ translation table for HTML entities
[THEN]

\ [undefined] ftra  [IF]
\  S" ftra/ftra.fs" INCLUDED  \ string translation tool needed when Simplilo's format output is active
\  S" ftra/ftra-simplilo.fs" INCLUDED \ translation table for HTML entities
\ [THEN]
[undefined] fjpg  [IF]  S" fjpg.fs" INCLUDED  [THEN]  \ jpeg tookit needed
[undefined] n>str  [IF]  S" n2str.fs" INCLUDED  [THEN]  \ number to string conversion tool

\ S" ffl/rgx.fs" INCLUDED  \ Regular expressions library of the File Foundation Library (needed when Simplilo's format output is active) deprecated!!!

\ .............................................................
\ Configuration

false VALUE simplilo?  \ flag: Do create Simplilo's WikiCreole pages instead of HTML pages?
\ (implemented in 2010-10 in order to export several websites from fhp+ForthCMS to Simplilo).
false VALUE fendo?  \ flag: Do use the new file names (planned for Simplilo) in order to make it easier to migrate to Fendo (the projected Forth web engine that will substitute fhp+ForthCMS)?
\ (implemented in 2012-07-31).

CHAR \ VALUE local-slash  \ used when joining local paths
gforth? [IF]  CHAR / TO local-slash  [THEN]  \ the word gforth? is defined in the file from_forth5mx.fs

defer trac-default
' trac-utf8es is trac-default

\ .............................................................
\ Load all fhp modules

S" fhp-core.fs" INCLUDED  \ core

S" fhp-paths.fs" INCLUDED  \ local and web paths tools
\ 2007-02-07:
\ The fhp-paths module must be loaded before the fhp-tags module.
\ Otherwise +extension word doesn't work in multilingual mode. I don't understand why.
\ The bug arised after moving the +extension word into the fhp-paths module.
\ It must be caused by the definition order of certain words.
S" fhp-tags.fs" INCLUDED  \ XHTML tags
S" fhp-ml.fs" INCLUDED  \ multilingual core tools
S" fhp-img.fs" INCLUDED  \ image tags
S" fhp-date.fs" INCLUDED  \ date and time tools

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

: fhp-link  ( -- )

  \ Create a promotional fhp link.

  xhtml11
  IF   S" <abbr xml:lang='en' title='Forth HTML Preprocessor'>fhp</abbr>"
  ELSE  S" <abbr xml:lang='en' lang='en' title='Forth HTML Preprocessor'>fhp</abbr>"
  THEN

  \ S" hreflang='es' title='Página de fhp'" S" http://programandala.net/es.programa.fhp"
  \ S" hreflang='eo' title='fhp-retpa&#285;o'" S" http://programandala.net/eo.programo.fhp"
  S" hreflang='en' title='fhp web page'" S" http://programandala.net/en.program.fhp"

  {a/a}

  ;

.(  fhp ok! )

fhp-paths.fs

CR .( fhp-paths )

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

\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This module provides the paths, filenames and file 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/).

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

\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2010-10-07: First support for Simplilo's format output.
\
\ 2007-04-08: Used the new constant LOCAL-SLASH . It is initialized in
\ the fhp loader.
\
\ 2007-01-22: Improved with +ARC-DISK-PATH and +ARC-URL-PATH .
\
\ 2006-08-08: Created with code written for the program alinome-bici.

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

MARKER fhp-paths


\ .............................................................
\ File extensions

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

  \ 2006-03-14
  \ 2007-02-07 Moved from the module fhp-ml.
  \ 2010-10-07 Support for Simplilo's format.

  simplilo? 0=  IF
    S" .html" str+
  THEN

  ;

defer +extension  \ 2007-02-07 Moved from the module fhp-ml and defered, in order to make it accessible also in monolingual webs.

' +".html" is +extension


\ .............................................................
\ Labels

: (+label) ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ Join a file name and a label.

  \ c-addr1 u1 = label
  \ c-addr2 u2 = file name with extension

  \ 2007-04-07

  S" #" str+ 2SWAP str+

  ;

: +label ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ Joins a file name and a label

  \ c-addr1 u1 = file name with extension
  \ c-addr2 u2 = label

  \ 2007-04-06

  2SWAP (+label)

  ;

: file+label  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ Join a file name and a label.

  \ c-addr1 u1 = file name without extension
  \ c-addr2 u2 = label

  \ 2007-04-04 First version

\  2SWAP +extension (+label)

  \ 2007-05-07 Added conditions, to make the word more general

  \ Now it is used by the calculated field >PAGE-FILE#LABEL .

  2SWAP DUP  IF  +extension  THEN
  2 PICK  IF  (+label)  ELSE  2SWAP 2DROP  THEN

  ;


\ .............................................................
\ Paths

\ Image directories:
svariable img-dir  \ image base directory under html-path
svariable img-subdir  0 img-subdir C!  \ optional img subdirectory under img-dir
svariable img-path  \ image local directory while building the site

\ Archive directories for downloadable files:
svariable arc-dir  \ archive base directory under html-path
svariable arc-subdir  0 arc-subdir C!  \ optional archive subdirectory under img-dir
svariable arc-path  \ archive local directory while building the site

: (cpath+)  ( c-addr1 u1 c-addr2 u2 b -- c-addr4 u4 )

  \ Join two file paths (with a join sign between them, if it is not already at the join).

  \ c-addr1 u1 = left string
  \ c-addr2 u2 = right string
  \ b = join char (generally a slash or a back slash)

  \ 2007-06-03 Factored from PATH+ .
  \ 2008-01-19 Renamed (formerly (PATH+) ) because of the gforth word PATH+ .

  >R
  OVER C@ >R  \ first char of the right string
  2SWAP 2DUP 1- + C@  \ last char of the left string
  R> R@ <> SWAP R@ <> AND  \ are both chars different than the join char?
  IF  R> b>str str+ 2SWAP str+
  ELSE  R> DROP 2SWAP str+
  THEN

  ;

: cpath+  ( c-addr1 u1 c-addr2 u2 b -- c-addr4 u4 )

  \ Join two file paths (with a join char between them, if it is not already at the join)
  \ if no string is empty.

  \ c-addr1 u1 = left string
  \ c-addr2 u2 = right string
  \ b = join char (generally a slash or a back slash)

  \ 2006-07-02
  \ 2007-06-03 Improved. Now it controls also if the first string is empty.
  \ That fixes a bug detected when w3c icons files joined their empty subdir:
  \ the result was a file with a slash at the start, what made the final result had two slashes.
  \ That made Forth 5mx (not WinForth) fail when trying to open the local image file to get its measures.
  \ 2008-01-19 Renamed (formerly PATH+ ) because of the gforth word PATH+ .

  OVER  0=
  IF  \ the second string is empty
    DROP 2DROP  \ return the first string
  ELSE
    >R 2SWAP DUP >R 2SWAP R> 0= R> SWAP
    IF  \ the first string is empty
      DROP 2SWAP 2DROP   \ return the second string
    ELSE
      (cpath+)
    THEN
  THEN

  ;

: disk-path+  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ Join two parts of a local path.

  \ 2006-07-02

  local-slash cpath+

  ;

: url-path+  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ Join two parts of a web path.

  \ 2006-07-02

  [CHAR] / cpath+

  ;

: />\  ( c-addr u -- c-addr u )

  \ Change "slashes" into "back slashes".

  2DUP 0 DO
    DUP I + C@ [CHAR] / =
    IF  DUP I + [CHAR] \ SWAP C!  THEN
  LOOP  DROP

  ;

: \>/  ( c-addr u -- c-addr u )

  \ Change "back slashes" into "slashes".

  2DUP 0 DO
    DUP I + C@ [CHAR] \ =
    IF  DUP I + [CHAR] / SWAP C!  THEN
  LOOP  DROP

  ;

: +img-disk-path  ( c-addr1 u1 -- c-addr2 u2 )

  \ Add the whole local path to an image file.

  \ c-addr1 u1 = filename without arc-dir and arc-subdir
  \ c-addr2 u2 = whole local path to the archive

  \ 2006-07-12
  \ 2006-08-10 Modified to use IMG-SUBDIR ; renamed: former name was WHOLE-IMG-PATH .
  \ 2007-03-21 Bug fixed, difficult to find: the word />\ was at the beginning, and that modified the original parameter in the stack,
  \            what made problems with -URL-PATH . Now the slash translation is made at the end, on the result string stored iun the string buffer.
  \ 2008-01-20 Modified. The slash conversion is not done when the OS class is Unix.

  img-path COUNT
  img-subdir COUNT disk-path+
  2SWAP disk-path+
  [ unix? 0= ] [IF]  \ the word unix? is defined in the file from_5mx.f
    />\  \ translate slashes that could be in the original parameter into back slahses
  [THEN]

  ;

: +img-url-path  ( c-addr1 u1 -- c-addr2 u2 )

  \ Add the whole web path to an image file.

  \ c-addr1 u1 = filename without arc-dir and arc-subdir
  \ c-addr2 u2 = whole web path to the archive

  \ 2006-08-10

  \>/  \ because of a possible local directory included
  img-dir COUNT img-subdir COUNT url-path+
  2SWAP url-path+

  ;

: +arc-disk-path  ( c-addr1 u1 -- c-addr2 u2 )

  \ Add the local path to a downloadable file.

  \ c-addr1 u1 = filename without arc-dir and arc-subdir
  \ c-addr2 u2 = whole web path to the archive

  \ 2007-01-22
  \ 2008-01-20 Modified. The slash conversion is not done when the OS class is Unix.

  [ unix? 0= ] [IF]  \ the word unix? is defined in the file from_5mx.f
    />\  \ because of a possible local directory included
  [THEN]
  arc-path COUNT  arc-subdir COUNT disk-path+
  2SWAP disk-path+

  ;

: +arc-url-path  ( c-addr1 u1 -- c-addr2 u2 )

  \ Add the whole web path to a downloadable file.

  \ c-addr1 u1 = filename without arc-dir and arc-subdir
  \ c-addr2 u2 = whole web path to the archive

  \ 2007-01-22

  \>/  \ because of a possible local directory included
  arc-dir COUNT  arc-subdir COUNT url-path+
  2SWAP url-path+

  ;


\ .............................................................
\ Extract from paths

: only-one  ( c-addr1 u1 c-addr2 u2 -- c-addr1 u1 | c-addr2 u2 )

  \ If the top string is not empty, keep it. Otherwise drop it.

  \ 2007-01-16
  \ 2007-03-21 Moved here from the fhp-links module.

  DUP  IF  2SWAP  THEN  2DROP

  ;

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

  \ Take off the file name extension.

  \ c-addr1 u1 = file name with extensions
  \ c-addr2 u2 = file name without extensions

  \ 2007-02-24 Migrated from the aplication alinome-bici

\  [CHAR] . /char-in-str 2SWAP 2DROP

  \ 2007-03-21 Bug fixed. ONLY-ONE used instead of 2SWAP and 2DROP .

  [CHAR] . /last-char-in-str only-one

  ;

: -url-path  ( c-addr1 u1 -- c-addr2 u2 )

  \ Take off the URL-like path (that is, with slashes).

  \ 2007-02-24

  \ c-addr1 u1 = file name with URL-like path
  \ c-addr2 u2 = file name without path

  [CHAR] / /last-char-in-str 2DROP

  ;

: path-only  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = URL
  \ c-addr2 u2 = URL without parameteres

  \ 2007-01-16
  \ 2007-04-05 Moved here from the upper layer, from the forthCMS-links module

  [CHAR] ? /char-in-str only-one

  ;

: domain-only  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = URL
  \ c-addr2 u2 = domain

  \ 2007-01-16
  \ 2007-04-05 Moved here from the upper layer, from the forthCMS-links module

  [CHAR] / /char-in-str only-one

  ;

: (.fhp-path)  ( c-addr1 u1 c-addr2 u2 -- )

  \ Show a path: name, description and content.

  \ c-addr1 u1 = name of the string variable
  \ c-addr2 u2 = description

  \ 2007-12-09

  CR TYPE [CHAR] : EMIT
  2DUP CR TYPE ."  = "
  EVALUATE COUNT TYPE

  ;

: .fhp-paths  ( -- )

  \ Show the current paths.

  \ 2007-12-08

  CR CR ." Current fhp paths:" CR

  S" html-path"
  S" Main path for the HTML pages"
  (.fhp-path)

  CR CR ." Directories for images:" CR

  S" img-dir"
  S" Image base directory under html-path "
  (.fhp-path)
  S" img-subdir"
  S" Optional image subdirectory under img-dir "
  (.fhp-path)
  S" img-path"
  S" Image local directory while building the site (used to read the image properties)"
  (.fhp-path)

  CR CR ." Directories for files (downloadable, media...):" CR

  S" arc-dir"
  S" Archive base directory under html-path "
  (.fhp-path)
  S" arc-subdir"
  S" Optional archive subdirectory under arc-dir "
  (.fhp-path)
  S" arc-path"
  S" Archive local directory while building the site (used to read the file properties)"
  (.fhp-path)

  CR CR

  ;

.(  fhp-paths ok!)

fhp-tags.fs

CR .( fhp-tags )

\ Copyright (C) 2006,2007,2008,2009,2010 Marcos Cruz (programandala.net)

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

\ 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/).

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

\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2010-10-07: First support for Simplilo's format output.
\
\ 2009-10-21: Alias created: ' {tag/tag} alias {tag/}
\
\ 2009-07-30: Added {/TABLE} , {TBODY} and {/TBODY}
\
\ 2009-04-15: Added >REL-ATTRIBUTE and +REL-ATTRIBUTE
\
\ 2009-04-04: Added {div}
\
\ 2008-08-23: Added: {_} {.} {,} {:} {;} {'}
\
\ 2008-04-20: Added {/OBJECT}
\
\ 2008-04-10: Added: {pre} {/pre} {pre/pre} .
\
\ 2007-08-22: Added {/SCRIPT}
\
\ 2007-04-11: >LANG-ATTRIBUTE improved.
\
\ 2007-04-08: Hidden bug found and fixed in the second version of
\ UNTAG .
\
\ 2007-04-06: Links tags are renamed and moved here from the fhp-links
\ module.  Now they will be basic tags. The more elaborated words to
\ build links will be in the the upper forthCMS level.
\
\ 2007-04-05: Added {BODY} , {/BODY} , {HTML} and {/HTML} .  Added
\ {LINK} and {META} .  All other meta-data and meta-link tags are
\ moved to the forthCMS-tags module.
\
\ 2007-04-04: Added {HEAD} and {/HEAD} .
\
\ 2007-02-07: Adedd LOCAL-METALINK and HTTP-METALINK .
\
\ 2007-01-31: Added {/SPAN} and {SPAN/SPAN} .
\
\ 2007-21-22: Added >TYPE-ATTRIBUTE and +TYPE-ATTRIBUTE Added &NBSP;
\
\ 2007-01-04: New words {TR} {/TR} {TD} {/TD} and {TD/TD} .
\
\ 2006-12-04: New words {KBD} {/KBD} and {KBD/KBD} .
\
\ 2006-11-22: New word TITLE and related.
\
\ 2006-10-05: Added {/A} , formerly defined in the module fhp-links.
\
\ 2006-09-14: Added {/SPAN}
\
\ 2006-09-1 Added {OL} an {/OL} .
\
\ 2006-09-09: Added {EM} {/EM} and {EM/EM} .
\
\ 2006-09-05: New fixed, faster and improved version of UNTAG .
\
\ 2006-09-02: New words >LANG-ATTRIBUTE and +LANG-ATTRIBUTE .
\ >SPAN+LANG modified; also renamed to >SPAN-LANG , and so its child
\ words.
\
\ 2006-09-01: New word UNTAG and related.
\
\ 2006-08-24: New words KEYWORDS and COMMON-KEYWORDS .
\
\ 2006-06-27: New word >SPAN+LANG and related.
\
\ 2006-06-25: Spell mistake fixed in accesskey attribute words.
\
\ 2006-06-26: New <strong> tag words.
\
\ 2006-06-24: New words for tags <h4> to <h6>, {P/P} and {TITLE/TITLE}
\ .
\
\ 2006-06-04: Word ANCHOR moved to the new module fhp-links.
\
\ 2006-05-27: Word ANCHOR taken from my application alinome-prg.
\
\ 2006-05-26: Module forked from fhp.  Words that make HTML tags are
\ taken from my application alinome-prg.

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

MARKER fhp-tags


\ .............................................................
\ Pseudo tags

\ Synonyms of some core words:

' space>html alias {_}
' space>html alias {space}
' dot>html alias {.}
' comma>html alias {,}
' colon>html alias {:}
' semicolon>html alias {;}
' tick>html alias {'}
' quote>html alias {"}

\ .............................................................
\ HTML tags

simplilo? [IF]

: {/a}  S" ]]" >>html  ;
: {blockquote}  cr>html {"} {"} cr>html  ;
: {/blockquote}  {blockquote}  ;
: {body}  ;
: {/body}  ;
: {br}  S" \\" >>html  ;
: {div}  S" <<html div />>" >html  ;
: {/div}  S" <<div/>>" >html  ;
: {dd}  space>html  ;
: {/dd}  ;
: {dd/dd}  ( c-addr u -- )  {dd} >html {/dd}  ;
' {dd/dd} alias {dd/}
: {dl}  cr>html  ;
: {/dl}  cr>html  ;
: {dt}  S" * **" >html  ;
: {/dt}  S" **" >>html  ;
: {dt/dt}  ( c-addr u -- )  {dt} >>html {/dt}  ;
' {dt/dt} alias {dt/}
: {em}  S" //" >>html  ;
: {/em}  {em}  ;
: {em/em}  ( c-addr u -- )  {em} >>html {/em}  ;
' {em/em} alias {em/}
: {head}  ;
: {/head}  cr>html cr>html  ;
: {h1}  cr>html S" =" >html  ;
: {/h1}  cr>html  ;
: {h1/h1}  ( c-addr u -- )  {h1} >>html {/h1}  ;
' {h1/h1} alias {h1/}
: {h2}  cr>html S" ==" >html  ;
: {/h2}  cr>html  ;
: {h2/h2}  ( c-addr u -- )  {h2} >>html {/h2}  ;
' {h2/h2} alias {h2/}
: {h3}  cr>html S" ===" >html  ;
: {/h3}  cr>html  ;
: {h3/h3}  ( c-addr u -- )  {h3} >>html {/h3}  ;
' {h3/h3} alias {h3/}
: {h4}  cr>html S" ====" >html  ;
: {/h4}  cr>html  ;
: {h4/h4}  ( c-addr u -- )  {h4} >>html {/h4}  ;
' {h4/h4} alias {h4/}
: {h5}  cr>html S" =====" >html  ;
: {/h5}  cr>html  ;
: {h5/h5}  ( c-addr u -- )  {h5} >>html {/h5}  ;
' {h5/h5} alias {h5/}
: {h6}  cr>html S" ======" >html  ;
: {/h6}  cr>html  ;
: {h6/h6}  ( c-addr u -- )  {h6} >>html {/h6}  ;
' {h6/h6} alias {h6/}
: {hr}  S" ----" >html cr>html  ;
: {html}  ;
: {/html}  ;
: {kbd}  S" <<kbd " >>html  ;
: {/kbd}  S"  />>" >>html  ;
: {kbd/kbd}  ( c-addr u -- )  {kbd} >>html {/kbd}  ;
' {kbd/kbd} alias {kbd/}
: {li}  S" * " >html  ;
: {/li}  ;
: {li/li}  ( c-addr u -- )  {li} >>html {/li}  ;
' {li/li} alias {li/}
: {/object}  S" <<object/>>" >html  ;
: {ol}  S" {* <ol> *}" >html  ;
: {/ol}  cr>html cr>html  ;
: {p}  cr>html cr>html  ;
: {/p}  {p}  ;
: {p/p}  ( c-addr u -- )  {p} >>html {/p}  ;
' {p/p} alias {p/}
: {pre}  S" {{{" >html cr>html  ;
: {/pre}  S" }}}" >html cr>html  ;
: {pre/pre}  ( c-addr u -- )  {pre} >html {/pre}  ;
' {pre/pre} alias {pre/}
: {/script}  S" <<script/>>" >html  ;
: {span}  S" <span>" >>html  ;
: {/span}  S" </span>" >>html  ;
: {span/span}  {span} >>html {/span}  ;
' {span/span} alias {span/}
: {strong}  S" **" >>html  ;
: {/strong}  {strong}  ;
: {strong/strong}  {strong} >>html {/strong}  ;
' {strong/strong} alias {strong/}
: {/table}  s" </table>" >html  ;
: {tr}  S" |" >html  ;
: {/tr}  cr>html  ;
: {tbody}  s" {* <tbody> *}" >html  ;
: {/tbody}  s" </tbody>" >html  ;
: {td}  ;
: {/td}  S" |" >>html  ;
: {td/td}  {td} >>html {/td}  ;
' {td/td} alias {td/}
: {title}  S" title = " >html  ;
: {/title}  ;
: {title/title}  ( c-addr u -- )  {title} >>html {/title}  ;
' {title/title} alias {title/}
: {ul}  S" {* <ul> *}" >html  ;
: {/ul}  cr>html cr>html ;

[ELSE]

: {/a} S" </a>" >>html  ;
: {blockquote}  S" <blockquote>" >html  ;
: {/blockquote}  S" </blockquote>" >html  ;
: {body}  S" <body>" >html  ;
: {/body}  S" </body>" >html  ;
: {br}  S" <br />" >>html  ;
: {div}  S" <div>" >html  ;
: {/div}  S" </div>" >html  ;
: {dd}  S" <dd>" >html  ;
: {/dd}  S" </dd>" >html  ;
: {dd/dd}  ( c-addr u -- )  {dd} >html {/dd}  ;
' {dd/dd} alias {dd/}
: {dl}  S" <dl>" >html  ;
: {/dl} S" </dl>" >html  ;
: {dt}  S" <dt>" >html  ;
: {/dt}  S" </dt>" >>html  ;
: {dt/dt}  ( c-addr u -- )  {dt} >>html {/dt}  ;
' {dt/dt} alias {dt/}
: {em}  S" <em>" >>html  ;
: {/em}  S" </em>" >>html  ;
: {em/em}  ( c-addr u -- )  {em} >>html {/em}  ;
' {em/em} alias {em/}
: {head}  S" <head>" >html  ;
: {/head}  S" </head>" >html  ;
: {h1}  S" <h1>" >html  ;
: {/h1}  S" </h1>" >>html  ;
: {h1/h1}  ( c-addr u -- )  {h1} >>html {/h1}  ;
' {h1/h1} alias {h1/}
: {h2}  S" <h2>" >html  ;
: {/h2}  S" </h2>" >>html  ;
: {h2/h2}  ( c-addr u -- )  {h2} >>html {/h2}  ;
' {h2/h2} alias {h2/}
: {h3}  S" <h3>" >html  ;
: {/h3}  S" </h3>" >>html  ;
: {h3/h3}  ( c-addr u -- )  {h3} >>html {/h3}  ;
' {h3/h3} alias {h3/}
: {h4}  S" <h4>" >html  ;
: {/h4}  S" </h4>" >>html  ;
: {h4/h4}  ( c-addr u -- )  {h4} >>html {/h4}  ;
' {h4/h4} alias {h4/}
: {h5}  S" <h5>" >html  ;
: {/h5}  S" </h5>" >>html  ;
: {h5/h5}  ( c-addr u -- )  {h5} >>html {/h5}  ;
' {h5/h5} alias {h5/}
: {h6}  S" <h6>" >html  ;
: {/h6}  S" </h6>" >>html  ;
: {h6/h6}  ( c-addr u -- )  {h6} >>html {/h6}  ;
' {h6/h6} alias {h6/}
: {hr}  S" <hr />" >html  ;
: {html}  S" <html>" >html  ;
: {/html}  S" </html>" >html  ;
: {kbd}  S" <kbd>" >>html  ;
: {/kbd}  S" </kbd>" >>html  ;
: {kbd/kbd}  ( c-addr u -- )  {kbd} >>html {/kbd}  ;
' {kbd/kbd} alias {kbd/}
: {li}  S" <li>" >html  ;
: {/li}  S" </li>" >>html  ;
: {li/li}  ( c-addr u -- )  {li} >>html {/li}  ;
' {li/li} alias {li/}
: {/object}  S" </object>" >html  ;
: {ol}  S" <ol>" >html  ;
: {/ol}  S" </ol>" >html  ;
: {p}  S" <p>" >html  ;
: {/p}  S" </p>" >>html  ;
: {p/p}  ( c-addr u -- )  {p} >>html {/p}  ;
' {p/p} alias {p/}
: {pre}  S" <pre>" >html  ;
: {/pre}  S" </pre>" >>html  ;
: {pre/pre}  ( c-addr u -- )  {pre} >html {/pre}  ;
' {pre/pre} alias {pre/}
: {/script}  S" </script>" >html  ;
: {span}  S" <span>" >>html  ;
: {/span}  S" </span>" >>html  ;
: {span/span}  {span} >>html {/span}  ;
' {span/span} alias {span/}
: {strong}  S" <strong>" >>html  ;
: {/strong}  S" </strong>" >>html  ;
: {strong/strong}  {strong} >>html {/strong}  ;
' {strong/strong} alias {strong/}
: {/table}  s" </table>" >html  ;
: {tr}  S" <tr>" >html  ;
: {/tr}  S" </tr>" >html  ;
: {tbody}  s" <tbody>" >html  ;
: {/tbody}  s" </tbody>" >html  ;
: {td}  S" <td>" >html  ;
: {/td}  S" </td>" >>html  ;
: {td/td}  {td} >>html {/td}  ;
' {td/td} alias {td/}
: {title}  S" <title>" >html  ;
: {/title}  S" </title>" >>html  ;
: {title/title}  ( c-addr u -- )  {title} >>html {/title}  ;
' {title/title} alias {title/}
: {ul}  S" <ul>" >html  ;
: {/ul}  S" </ul>" >html  ;

[THEN]

\ .............................................................
\ HTML entities

: &nbsp;  S" &nbsp;" >>html  ;

\ .............................................................
\ HTML entities


\ .............................................................
\ Untag tool

false [IF]

\ This first version of UNTAG changes the string it receives.
\ That made it impossible to use the original content later.

VARIABLE untag?  untag? on
VARIABLE untag-lenght
VARIABLE untag-from
VARIABLE untag-to

: untag  ( c-addr1 u1 -- c-addr1 u2 )

  \ Remove all HTML tags of a string.

  \ 2006-09-01

  2DUP untag-lenght !
  DUP untag-from ! untag-to !
  BEGIN
    untag-lenght @
  WHILE
    untag-from @ C@
    CASE
    [CHAR] < OF untag? off ENDOF
    [CHAR] > OF untag? on ENDOF
    untag? @
    IF
      untag-from @ C@ untag-to @ C!
      1 untag-to +!
    THEN
    ENDCASE
    1 untag-from +!
    -1 untag-lenght +!
  REPEAT
  untag-from @ untag-to @ - -

  ;

\ This second version of UNTAG had a bug:
\ it always returned the string in the same address!
\ That made it impossible to use the result later without moving it to a secure place.

VARIABLE untag?  \ state
svariable untagged  \ used only as a allocated space, the string lenght will not be updated
VARIABLE untag-from  \ current char address of the original string
VARIABLE untag-to  \ current char address of the new string

: untag  ( c-addr1 u1 -- c-addr2 u2 )

  \ Remove all HTML tags of a string.

  \ 2006-09-05

  untagged COUNT DROP untag-to !
  SWAP untag-from !
  untag? on
    BEGIN
    DUP
  WHILE
    untag-from @ C@
    CASE
      [CHAR] < OF untag? off ENDOF
      [CHAR] > OF untag? on ENDOF
      untag? @
      IF
        untag-from @ C@ untag-to @ C!
        1 CHARS untag-to +!
      THEN
    ENDCASE
    1 CHARS untag-from +!
    1-  \ counter
  REPEAT
  DROP  \ counter
  untagged COUNT DROP  untag-to @ OVER -

  ;

[THEN]

\ The solution is simple, at last:
\ The first version with an initial call to move the string into the string buffer!

VARIABLE untag?  untag? on
VARIABLE untag-lenght
VARIABLE untag-from
VARIABLE untag-to

: untag  ( c-addr1 u1 -- c-addr1 u2 )

  \ Remove all HTML tags of a string.

  \ 2006-09-01
  \ 2007-04-08

  >sbuffer
  2DUP untag-lenght !
  DUP untag-from ! untag-to !
  BEGIN
    untag-lenght @
  WHILE
    untag-from @ C@
    CASE
    [CHAR] < OF untag? off ENDOF
    [CHAR] > OF untag? on ENDOF
    untag? @
    IF
      untag-from @ C@ untag-to @ C!
      1 untag-to +!
    THEN
    ENDCASE
    1 untag-from +!
    -1 untag-lenght +!
  REPEAT
  untag-from @ untag-to @ - -

  ;

\ .............................................................
\ HTML attributes

: html-attribute  ( c-addr1 u1 c-addr2 u2 -- )

  \ Create an HTML tag attribute if the content is provided.

  \ c-addr1 u1 = attribute content or empty string
  \ c-addr2 u2 = attribute label (e.g. alt, title, httplang, longdesc...)

  2SWAP DUP  IF
    space>html 2SWAP >>html
    S" ='" >>html >>html tick>html
  ELSE
    2DROP 2DROP
  THEN

  ;

: >html-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = attribute content
  \ c-addr2 u2 = attribute label
  \ c-addr3 u3 = attribute ready for a HTML tag

  S"  " 2SWAP str+
  S" ='" str+  2SWAP str+  S" '" str+

  ;

: >title-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = title attribute content
  \ c-addr2 u2 = title attribute ready for a HTML tag

  S" title" >html-attribute

  ;

: +title-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = title attribute content
  \ c-addr3 u3 = ready attributes with the title one added

  >title-attribute str+

  ;

: >alt-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = alt attribute content
  \ c-addr2 u2 = alt attribute ready for a HTML tag

  S" alt" >html-attribute

  ;

: +alt-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = alt attribute content
  \ c-addr3 u3 = ready attributes with the alt one added

  >alt-attribute str+

  ;

: >hreflang-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = hreflang attribute content
  \ c-addr2 u2 = hreflang attribute ready for a HTML tag

  S" hreflang" >html-attribute

  ;

: +hreflang-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = hreflang attribute content
  \ c-addr3 u3 = ready attributes with the hreflang one added

  >hreflang-attribute str+

  ;

: >longdesc-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = longdesc attribute content
  \ c-addr2 u2 = longdesc attribute ready for a HTML tag

  S" longdesc" >html-attribute

  ;

: +longdesc-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = longdesc attribute content
  \ c-addr3 u3 = ready attributes with the longdesc one added

  >longdesc-attribute str+

  ;

: >accesskey-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = accesskey attribute content
  \ c-addr2 u2 = accesskey attribute ready for a HTML tag

  S" accesskey" >html-attribute

  ;

: +accesskey-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = accesskey attribute content
  \ c-addr3 u3 = ready attributes with the accesskey one added

  >accesskey-attribute str+

  ;

: >width-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = width attribute content
  \ c-addr2 u2 = width attribute ready for a HTML tag

  S" width" >html-attribute

  ;

: +width-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = width attribute content
  \ c-addr3 u3 = ready attributes with the width one added

  >width-attribute str+

  ;

: >height-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = height attribute content
  \ c-addr2 u2 = height attribute ready for a HTML tag

  S" height" >html-attribute

  ;

: +height-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = height attribute content
  \ c-addr3 u3 = ready attributes with the height one added

  >height-attribute str+

  ;

: >class-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = class attribute content
  \ c-addr2 u2 = class attribute ready for a HTML tag

  S" class" >html-attribute

  ;

: +class-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = class attribute content
  \ c-addr3 u3 = ready attributes with the class one added

  >class-attribute str+

  ;

: >type-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = type attribute content
  \ c-addr2 u2 = type attribute ready for a HTML tag

  S" type" >html-attribute

  ;

: +type-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = type attribute content
  \ c-addr3 u3 = ready attributes with the type one added

  >type-attribute str+

  ;

: >xml:lang-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = lang attribute content (ISO language code)

  \ 2009-10-22 Written to be used in the Atom addon of forthCMS.
  \ 2009-10-24 Siplified with >HTML-ATTRIBUTE . Typo corrected.

  S" xml:lang" >html-attribute

  ;

: +xml:lang-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = lang attribute content (ISO language code)
  \ c-addr3 u3 = ready attributes with the lang one added

  \ 2009-10-24

  >xml:lang-attribute str+

  ;

: xml:lang-enough?  ( -- f )

  \ 2009-10-22 Sintactic sugar. In the future the rule could be more complex.

  xhtml11

  ;

: >lang-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = lang attribute content (ISO language code)

  \ 2006-09-02 Factored from >SPAN-LANG .
  \ 2006-09-03 Bug fixed.
  \ 2007-04-11 Improved to distingish XHTML 1.1.
  \ 2009-10-22 Factored out with >XML:LANG-ATTRIBUTE . Simplified.

[ 0 ] [if]  \ old version, until 2009-10-22

  xhtml11 IF
    S"  xml:lang='" 2SWAP
  ELSE
    S"  xml:lang='" 2OVER str+
    S" ' lang='" str+ 2SWAP
    str+ S" '" str+
  THEN

[then]

  \ Version 2009-10-22

  2dup >xml:lang-attribute 2swap
  xml:lang-enough? 0= if
    S"  lang='" 2swap str+ s" '" str+ str+
  else
    2drop
  then

  ;

: +lang-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = lang attribute content (ISO language code)
  \ c-addr3 u3 = ready attributes with the lang one added

  >lang-attribute str+

  ;

: >rel-attribute  ( c-addr1 u1 -- c-addr2 u2 )

  \ c-addr1 u1 = rel attribute content
  \ c-addr2 u2 = rel attribute ready for a HTML tag

  S" rel" >html-attribute

  ;

: +rel-attribute  ( c-addr1 u1 c-addr2 u2 -- c-addr3 u3 )

  \ c-addr1 u1 = ready attributes or empty string
  \ c-addr2 u2 = rel attribute content
  \ c-addr3 u3 = ready attributes with the rel one added

  >rel-attribute str+

  ;

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

  \ Insert the attribute for the provided language code in the string.

  \ c-addr1 u1 = string
  \ c-addr2 u2 = ISO language code
  \ c-addr3 u3 = new string

  \ 2006-06-27
  \ 2006-09-02 Factored out to >LANG-ATTRIBUTE .

  S" <span " 2SWAP >lang-attribute str+
  S" >" str+ 2SWAP str+
  S" </span>" str+

  ;

: >span-lang-es  ( c-addr1 u1 -- c-addr2 u2 )

  \ 2006-06-27

  \ Insert the Spanish language atribute in the string.

  S" es" >span-lang

;

: >span-lang-eo  ( c-addr1 u1 -- c-addr2 u2 )

  \ 2006-06-27

  \ Insert the Esperanto language atribute in the string.

  S" eo" >span-lang

;

: >span-lang-en  ( c-addr1 u1 -- c-addr2 u2 )

  \ 2006-06-27

  \ Insert the English language atribute in the string.

  S" en" >span-lang

;

: >span-lang-de  ( c-addr1 u1 -- c-addr2 u2 )

  \ 2006-06-27

  \ Insert the German language atribute in the string.

  S" de" >span-lang

;


\ .............................................................
\ Meta tags

: {meta} ( c-addr1 u1 c-addr2 u2 -- )

  \ Create a meta tag.

  \ c-addr1 u1 = content
  \ c-addr2 u2 = name

  \ 2007-04-05
  \ 2010-10-08 Support for Simplilo's format output.

  simplilo?  IF
    >html S"  = " >>html >>html
  ELSE
    S" <meta name='" >html >>html
    S" ' content='" >>html >>html
    S" ' />" >>html
  THEN

  ;

: {link} ( c-addr1 u1 c-addr2 u2 -- )

  \ Create a link tag.

  \ c-addr1 u1 = attributes
  \ c-addr2 u2 = href

  \ 2007-04-05

  S" <link  href='" >html >>html tick>html space>html >>html S"  />" >>html

  ;


\ .............................................................
\ Links

: {a-href  ( -- )

  \ Open the start <a> tag with the href attribute.

  simplilo?
  IF  S" [[ "
  ELSE  S" <a href='"
  THEN  >>html

  ;

: {a-href-http  ( -- )

  \ Open the start <a> tag with the href attribute and adds the http protocol.

  \ 2007-05-06

  {a-href S" http://" >>html

  ;

: a}  ( c-addr1 u1 c-addr2 u2 -- )

  \ Close the start <a> tag adding the href content and the attributes.

  \ c-addr1 u1 = attributes
  \ c-addr2 u2 = href

  >>html tick>html space>html >>html  S" >" >>html

  ;

: {a-href-http}
  ( c-addr1 u1 c-addr2 u2 -- ) \ with HTML output
  ( c-addr1 u1 c-addr2 u2 c-addr3 u3 -- ) \ with Simplilo's format output

  \ Create a start <a> tag for an external link, with all its content.

  \ c-addr1 u1 = attributes
  \ c-addr2 u2 = href without the http protocol.
  \ c-addr3 u3 = link text

  \ 2007-04-05 Renamed (formerly HTTP{A} ) and rewriten.
  \ 2010-10-22 Support for Simplilo's format output.

  simplilo?
  IF
    2SWAP {a-href-http
    S"  | " >>html
    S"  | " >>html
  ELSE
    {a-href-http
  THEN
  a}

  ;

: {a}  ( c-addr1 u1 c-addr2 u2 -- )

  \ Create a <a> tag.

  \ c-addr1 u1 = attributes
  \ c-addr2 u2 = whole href (with http protocol if needed)

  \ 2007-04-06

  {a-href a}

  ;

: {a/a}  ( c-addr1 u1 c-addr2 u2 c-addr3 u3 -- )

  \ Create a link.

  \ c-addr1 u1 = text
  \ c-addr2 u2 = attributes
  \ c-addr3 u3 = whole href (with http protocol if needed)

  \ 2004 04 29

  simplilo?  IF
    S" [[ " >>html >>html
    2SWAP S"  | " >>html >>html
    S"  | " >>html >>html
    S"  ]]" >>html
  ELSE
    {a} >>html {/a}
  THEN

  ;

.(  fhp-tags ok!)


fhp-ml.fs

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!)


fhp-date.fs

CR .( fhp-date )

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

\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This file provides the date and timing 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/).

\ .............................................................
\ History

\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2006-08-18: Created with code factored from my application
\ alinome-bici.
\
\ 2006-08-31: Several words added or improved.
\
\ 2006-09-04: New words ROT>STR+ and >META-DATE
\
\ 2013-05-18: '>iso-date' and its related code have been
\ factored out, rewritten and simplified as a module of the
\ Galope library.  See
\ <http://programandala.net/en.program.galope>. The module is
\ called "yyyymmdd-to-iso.fs".

\ .............................................................
\ Code

svariable time-zone
S" +02:00" time-zone place  \ system dependent time zone
\ S" CET" time-zone place  \ system dependent time zone
\ S" Z" time-zone place  \ alternative for UTC time zone

CREATE iso-date 10 ALLOT ALIGN

: iso-year>  ( c-addr1 u1 c-addr2 -- )

  \ Receive a string in the format "yyyy[mm[dd]]",
  \ extract the year and place it at the beginning of the counted string at c-addr2.

  \ 2006-08-10

  NIP 4 SWAP place

;

: iso-month>  ( c-addr1 u1 c-addr2 -- )

  \ Receive a string in the format "yyyy[mm[dd]]",
  \ extract the month and place it into the counted string at c-addr2,
  \ that already has "yyyy".

  \ 2006-08-10

  SWAP 4 >
  IF
    DUP >R COUNT + [CHAR] - OVER C!  \ put a separator after the year
    1+ SWAP 4 CHARS + SWAP 2 CMOVE  \ copy the 2 digits of the month
    7 R> C!  \ new lenght
  ELSE
    2DROP
  THEN

  ;

: iso-day>  ( c-addr1 u1 c-addr2 -- )

  \ Receive a string in the format "yyyy[mm[dd]]",
  \ extract the day and place it into the counted string at c-addr2,
  \ that already has "yyyy-mm".

  \ 2006-08-10

  SWAP 6 >
  IF
    DUP >R COUNT + [CHAR] - OVER C!  \ put separator
    1+ SWAP 6 CHARS + SWAP 2 CMOVE  \ copy the 2 digits
    10 R> C!  \ new lenght
  ELSE
    2DROP
  THEN

  ;

: not-digit?  ( c -- flag )

  \ 2006-08-10

  DUP [CHAR] 0 <  SWAP [CHAR] 9 > OR

  ;

: left-digits  ( c-addr1 u1 -- c-addr1 u1' )

  \ Return a string removing all characters at the right of (and including) the first non digit character found.

  \ 2006-08-10

  DROP DUP
  BEGIN
    DUP CHAR+ SWAP C@ not-digit?
  UNTIL
  char- OVER -

  ;

: >iso-date  ( c-addr1 u1 -- c-addr2 u2 )

  \ Transform a date string with the format:
  \   yyyy[mm[dd]]x*y
  \ (where "yyyy", "mm" and "dd" are numeric characters
  \ and "x*y" is any string that starts with a non numeric character)
  \ into the format:
  \   yyyy[-mm[-dd]]
  \ The goal is to get the date from the name of a file that has been named that way.
  \ It is also used to convert a metadata date ("change" or "created") format: "yyyymmdd".

  \ 2006-08-10

  left-digits
  2DUP iso-date iso-year>
  2DUP iso-date iso-month>
  iso-date iso-day>
  iso-date COUNT

  ;

: >iso-full-date  ( c-addr1 u1 -- c-addr2 u2 )

  \ Transform a date string with the format:
  \   yyyymmdd
  \ (where "yyyy", "mm" and "dd" are numeric characters)
  \ into the format:
  \   yyyy-mm-ddT00:00:00Z
  \ (where Z is the time zone stored in the variable time-zone)
  \ It is used to convert a metadata date ("change" or "created") format: "yyyymmdd" into
  \ a standard date.

  \ 2009-10-22

  >iso-date  s" T00:00:00" str+  time-zone count str+

  ;

: #>html  ( u -- )

  \ Send one number (part of a date) to the HTML file
  \ after converting it into a string
  \ and putting one left zero if needed.

  \ u = year, month, day, hour, minute or second

  n>str DUP 1 =
  IF [CHAR] 0 emit>html
  THEN
  >>html

  ;

: 3#>html  ( u1 u2 u3 c -- )

  \ Send three numbers to the html file separated by a character.

  \ u1 = day or second
  \ u2 = month or minute
  \ u3 = year or hour
  \ c = separator

  \ 2006-08-17

  >R
  #>html R@ emit>html
  #>html R> emit>html
  #>html

  ;

: time>html  ( u1 u2 u3 -- )

  \ u1 = hour
  \ u2 = minute
  \ u3 = second

  \ 2006-08-17

  [CHAR] : 3#>html

  ;

: date>html  ( u1 u2 u3 -- )

  \ u1 = day
  \ u2 = month
  \ u3 = year

  \ 2006-08-17

  [CHAR] - 3#>html

  ;

: iso-date&time>html  ( u1 u2 u3 u4 u5 u6 -- )

  \ Create into the HTML file a date and time string
  \ with the ISO format.

  \ u1 = second
  \ u2 = minute
  \ u3 = hour
  \ u4 = day
  \ u5 = month
  \ u6 = year

  \ 2006-08-17
  \ 2006-08-20 Conformed to ISO.
  \ 2006-08-31 Improved.

  date>html
  S" T" >>html time>html
  time-zone COUNT >>html

  ;

: rot>str+  ( n c-addr1 u1 -- c-addr2 u2 )

  \ Convert a number into a string and append it to a given string.

  \ 2006-09-04

  ROT n>str str+

  ;

: >meta-date  ( u1 u2 u3 u4 u5 u6 -- )

  \ Return a date and time string
  \ in the format used by the <meta> tag:
  \ yyyymmdd;hhmmss

  \ u1 = second
  \ u2 = minute
  \ u3 = hour
  \ u4 = day
  \ u5 = month
  \ u6 = year

  \ 2006-09-04

  n>str rot>str+ rot>str+
  S" ;" str+
  rot>str+ rot>str+ rot>str+

  ;

false [IF]  \ obsolete!!!
: meta-date>html  ( u1 u2 u3 u4 u5 u6 -- )

  \ Create into the HTML file a date and time string
  \ in the format used by the <meta> tag:
  \ yyyymmdd;hhmmss

  \ u1 = second
  \ u2 = minute
  \ u3 = hour
  \ u4 = day
  \ u5 = month
  \ u6 = year

  \ 2006-08-31

  #>html #>html #>html
  [CHAR] ; emit>html
  #>html #>html #>html

  ;
[THEN]

.(  fhp-date ok!)

fhp-img.fs

CR .( fhp-img )

\ Copyright (C) 2006,2010,2011 Marcos Cruz (programandala.net)

\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This module provides the image tags and 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/).

\ .............................................................
\ History

\ 2015-02-04: Header updated; layout a bit changed.
\
\ 2006-08-08: Added code written for my application alinome-bici.
\
\ 2010-10-07: First support for Simplilo's format output.

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

MARKER fhp-img

\ -----------------------------------------
\ Code

false [IF]  \ obsolete!!!

\ 2006-08-31: not used anymore

: img-size  ( c-addr1 u1 -- c-addr2 u2 )

  \ Return a string with the KiB size of the image.

  \ c-addr1 u1 = image file, without img-dir and img-subdir
  \ c-addr2 u2 = result

  \ 2006 07 02
  \ 2006 08 10 Now it calculates the whole local path.
  \ 2006-08-31 Now it does not include parenthesis.

  +img-disk-path
  R/O OPEN-FILE ABORT" OPEN-FILE error in img-size"
  DUP >R FILE-SIZE ABORT" FILE-SIZE error in img-size"
  D>S 1024 / n>str
  S"  <abbr class='first' lang='en' xml:lang='en' title='Kibibytes'>KiB</abbr>" str+
  R> CLOSE-FILE ABORT" CLOSE-FILE error in img-size"

  ;

[THEN]

: img-xy  ( c-addr u -- x y )

  \ Return an image's width and height in pixels.

  \ 2006 06 29
  \ 2006 08 10 Now it calculates the whole local path.

  \ c-addr u = image file, without img-dir and img-subdir
  \ x = width
  \ y = height

  +img-disk-path
  jpg-open jpg-xy
  ROT CLOSE-FILE ABORT" CLOSE-FILE error in img-xy"

  ;

: singlequotes>doublequotes  ( a u -- )

  \ Convert single to double quotes in a string.

  \ 2011-02-11 First version.

  s" '" str-quotes str-exchange-all

  ;

: attrs>attrs+alt  ( a1 u1 -- a2 u2 a3 u3 )

  \ Extract the alt attr content from image HTML attributes.

  \ a1 u1 = image attrs, with possible alt the start.
  \ a2 u2 = image attrs without the alt.
  \ a3 u3 = content of the alt attribute, or empty string if no alt.

  \ Note: the alt attribute, if present, is always at the start, and only single quotes are used, what make things much easier.

  \ 2011-02-11 First version.

  s" alt='" search
  if  \ alt text found
    5 /string  \ remove the string searched for
    over >r  \ save the start of the alt text
    s" '" search
    0= abort" Closing quote is missing in image 'alt' attribute."
    1 /string  \ remove the single quote searched for
    over r@ - 1- r> swap  \ calculate the content of the alt attribute
  else
    s" "  \ alt text is empty
  then
  2swap singlequotes>doublequotes 2swap
  ;

defer img

svariable img-align-class \ used for exporting to Simplilo format

: default-img  ( c-addr1 u1 c-addr2 u2 -- )

  \ Insert a JPEG image in the HTML page.

  \ c-addr1 u1 = attributes
  \ c-addr2 u2 = image file, without img-dir and img-subdir

  \ 2006 04 01
  \ 2006 08 10 Now it uses +img-url-path .
  \ 2010-10-08 First support for Simplilo's format output. Unfinished.
  \ 2011-02-10 Finnished the support for Simplilo's format output.
  \ 2011-02-11 Fixed. Single quotes are changed to double quotes in the HTML parameters of the Simplilo's format output. Single quotes caused rendering problems later, I don't know why.
  \ 2011-01-11 Factored out to attrs>attrs+alt .

  simplilo?  IF

    S" {{ " >html  +img-url-path >>html
    attrs>attrs+alt
    S"  | " >>html  >>html  \ alt text
    S"  | " >>html
    img-align-class count str+ >>html  \ add the image align class to the remaining attrs
    S"  }}" >>html

  ELSE

    S" <img src='" >html
    2DUP +img-url-path >>html tick>html
    img-xy
    n>str >height-attribute >>html
    n>str >width-attribute >>html
    space>html >>html S"  />" >>html

  THEN

  ;

' default-img is img

: leftimg{  ( -- )
  simplilo?
  IF
    S\"  class=\"left\"" img-align-class str!
    \ S" <<div leftimg />>" >html
  ELSE  S" <div class='leftimg'>" >html
  THEN
;
: rightimg{  ( -- )
  simplilo?
  IF
    S\"  class=\"right\"" img-align-class str!
    \ S" <<div rightimg />>" >html
  ELSE  S" <div class='rightimg'>" >html
  THEN
  ;
: centerimg{  ( -- )
  simplilo?
  IF
    S\" class=\"center\"" img-align-class str!
    \ S" <<div centerimg />>" >html
  ELSE  S" <div class='centerimg'>" >html
  THEN
  ;

simplilo? [IF]
' noop
[ELSE]
' {/div}
[THEN]
DUP DUP
alias }leftimg
alias }rightimg
alias }centerimg

: |img  ( c-addr1 u1 c-addr2 u2 -- )

  \ Make an image on the left.

  \ c-addr1 u1 = attributes
  \ c-addr2 u2 = image file, without img-dir and img-subdir

  \ 2006-04-02 First and third version.

  \ S" <div class='leftimg'>" >html img {/div}

  \ 2006-10-09 Second version.

  \ 2>R S"  class='left'" str+ 2R> img

  \ 2009-08-21 Fourth version.

  leftimg{ img }leftimg

  ;

: img|  ( c-addr1 u1 c-addr2 u2 -- )

  \ Make an image on the right.

  \ c-addr1 u1 = attributes
  \ c-addr2 u2 = image file, without img-dir and img-subdir

  \ 2006 04 02 First and third version.

  \ S" <div class='rightimg'>" >html img  {/div}

  \ 2006-10-09 Second version.

  \ 2>R S"  class='right'" str+ 2R> img

  \ 2009-08-21 Fourth version.

  rightimg{ img }rightimg

  ;

: |img|  ( c-addr1 u1 c-addr2 u2 -- )

  \ Make an image on the centre.

  \ c-addr1 u1 = attributes
  \ c-addr2 u2 = image file, without img-dir and img-subdir

  \ 2006-04-02 First and third version.

  \ S" <div class='centerimg'>" >html img {/div}

  \ 2006-10-09 New version.

  \ 2>R S"  class='center'" str+ 2R> img

  \ 2009-08-21 Fourth version.

  centerimg{ img }centerimg

  ;

.(  fhp-img ok!)

fhp-benchs.fs

CR .( fhp-benchs  )

\ Copyright (C) 2006 Marcos Cruz (programandala.net)

\ This file is part of
\ fhp ("Forth HTML Preprocessor") version B-00-201206
\ (http://programandala.net/en.program.fhp).
\ This file makes a speed test for debugging purposes.

\ 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/).

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

[undefined] fhp  [IF]   S" fhp.f"  INCLUDED  [THEN]

html-make off
html-echo off

\ .............................................................
\ Benchs

VARIABLE html[-speedtest
VARIABLE html\-speedtest
VARIABLE html(-speedtest

html[-speedtest on
html\-speedtest off
html(-speedtest off

html[-speedtest @ [IF]
CR .( html[ speed test)
TIME&DATE
:NONAME
html[
bla bla bla (long XHTML text here!)
]html
;
DROP -seconds
CR . .( seconds with html[ )
[THEN]

html(-speedtest @ [IF]
CR .( html( speed test)
TIME&DATE
html(
bla bla bla (long XHTML text here!)
)html
-seconds
CR . .( seconds with html( )
[THEN]

html\-speedtest @ [IF]
CR .( html\ speed test)
TIME&DATE
html\
bla bla bla (long XHTML text here!)

-seconds
CR . .( seconds with html\ )
[THEN]

\ 2006-04-26: Results (with Forth 5mx on a Psion 5mx):
\
\ original html[ 423 s
\ html\ 279 s (34% faster)
\ compile mode html[ 61 s
\ interpretation mode html( 399 s

Downloads

Related pages

Fendo
Website engine written in Forth.