[Qemacs-commit] qemacs Makefile forth.c

[Charlie Gordon]

CVSROOT:        /sources/qemacs
Module name:    qemacs
Changes by:     Charlie Gordon <chqrlie>        14/05/30 17:53:19

Modified files:
        .              : Makefile 
Added files:
        .              : forth.c 

Log message:
        add mode for Forth languages

CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/qemacs/Makefile?cvsroot=qemacs&r1=1.65&r2=1.66
http://cvs.savannah.gnu.org/viewcvs/qemacs/forth.c?cvsroot=qemacs&rev=1.1

Patches:
Index: Makefile
===================================================================
RCS file: /sources/qemacs/qemacs/Makefile,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -b -r1.65 -r1.66
--- Makefile    7 Mar 2014 02:30:05 -0000       1.65
+++ Makefile    30 May 2014 17:53:19 -0000      1.66
@@ -109,7 +109,7 @@
 OBJS+= charsetjis.o charsetmore.o
 
 ifdef CONFIG_ALL_MODES
-  OBJS+= unihex.o bufed.o clang.o xml.o htmlsrc.o \
+  OBJS+= unihex.o bufed.o clang.o xml.o htmlsrc.o forth.o \
          lisp.o makemode.o markdown.o orgmode.o perl.o script.o extra-modes.o
   ifndef CONFIG_WIN32
     OBJS+= shell.o dired.o latex-mode.o archive.o

Index: forth.c
===================================================================
RCS file: forth.c
diff -N forth.c
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ forth.c     30 May 2014 17:53:18 -0000      1.1
@@ -0,0 +1,339 @@
+/*
+ * Miscellaneous QEmacs modes for Forth variants
+ *
+ * Copyright (c) 2014 Charlie Gordon.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2 of the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ */
+
+#include "qe.h"
+
+/* XXX: should have different flavors of Forth:
+ * FreeForth, ficl, gforth...
+ */
+
+/*---------------- Free Forth language coloring ----------------*/
+
+char const ff_keywords[] = {
+    "|rst|>SC|SC|>S1|>S0|>C1|>C0|c04|s09|s08|s01|s1|,3`|,4`|,2`|,1`"
+    "|here`|allot`|align`|,`|w,`|c,`|swap`|2dup`|dup`|nipdup`|tuck`"
+    "|over`|under`|pick`|2drop`|drop`|nip`|rot`|-rot`|>rswapr>`|depth"
+    
"|>r`|2>r`|dup>r`|r>`|2r>`|dropr>`|r`|2r`|rdrop`|2rdrop`|address@hidden|address@hidden"
+    // |` requires a different separator
+    "|over&`|over|`|over^`|2dup+`|over+`|over-`|over*`|&`|^`|+`|-`|*`|/`|%`"
+    "|~`|negate`|bswap`|flip`|invert|not|and|or|xor|mod|1-`"
+    "|1+`|2+`|4+`|2*`|2/`|4*`|4/`|8*`|8/`|<<`|>>`|m/mod`|/%`|min`|max`"
+    
"|within|bounds`|@`|address@hidden|address@hidden|address@hidden|address@hidden|address@hidden|address@hidden|@+`|address@hidden|address@hidden"
+    "|!`|c!`|w!`|2!`|+!`|-!`|over!`|overc!`|overw!`|over+!`|over-!`"
+    "|tuck!`|tuckc!`|tuckw!`|tuck+!`|tuck-!`|2dup!`|2dupc!`|2dupw!`"
+    "|2dup+!`|2dup-!`|on`|off`|erase|fill|move|cmove`|place`|$-|search"
+    "|lit`|'`|-call|call,|callmark|;;`|tailrec|anon:`|anon|;`|[`|]`"
+    "|H|header|find|which|>in|tp|tib|eob|\\`|(`|EOF`|parse|wsparse|lnparse"
+    "|compiler|number|notfound|classes|:`|alias`|create`|variable`|constant`"
+    "|equ`|:^`|^^`|!^`|@^`|execute|reverse`|catch|throw|:|;|?"
+    "|+longconds`|-longconds`|?`|0>`|0<=`|0>=`|0<`|0<>`|0=`|C1?`|C0?`"
+    "|0-`|`?1|`?#|<>`|=`|>`|<=`|>=`|<`|u>`|u<=`|u>=`|u<`|`?2|BOOL`"
+    "|nzTRUE|zFALSE|`?off|`cond|IF`|CASE`|ELSE`|SKIP`|THEN`|;THEN`"
+    "|BEGIN`|`mrk|TIMES`|RTIMES`|START`|ENTER`|0;`|TILL`|WHILE`|AGAIN`"
+    "|BREAK`|END`|UNTIL`|REPEAT`|if`|0=if`|0<if`|0>=if`|=if`|<>if`|<if`"
+    "|<=if`|u<if`|u<=if`|then`|;then`|else`|again`|while`|repeat`|for`"
+    "|next`|[THEN]`|[ELSE]`|[IF]`|[0]`|[1]`|[~]`|[os]`|syscall|stdin|stdout"
+    "|open'|openr|openw|openw0|close|read|write|lseek|ioctl|select"
+    "|malloc|free|type|accept|emit|space|cr|key|.|.\\|.digit|base"
+    "|.l|.w|.b|.#s|.dec|.dec\\|dump|2dump|;dump`|stopdump?|ui|prompt"
+    "|.s`|.h`|words`|hid'm`|mark`|marker|loc:`|needs`|needed|eval|bye`"
+    "|exit|#lib|#fun|#call|lib:`|fun:`|libc.`|libc|man`|k32.`|k32"
+    "|win32.hlp`|ior|?ior|zt|cd`|shell|!!`|cls`|home|atxy|normal"
+    "|background|foreground|.d|.wd|.dt|.t|.now`|now|ms|ms@|}}}`|{{{`"
+    "|fcell|fsw@|fcw@|fcw!|floor|f>df|df>f|f>s|s>f|`f:`|finit`|fpi`"
+    "|1.`|0.`|fdup`|fover`|fdrop`|fnip`|fswap`|f2drop`|f2dup`|ftuck`"
+    "|funder`|frot`|f-rot`|fmax`|fmin`|fabs`|fnegate`|f+`|fover+`|f-`"
+    "|fover-`|fswap-`|f*`|fover*`|f/`|fover/`|fswap/`|f1/`|`fscale`"
+    "|`fxtract`|f2/|f2*|`fldln2|`fldlg2|`fldl2e|`fldl2t|`fxl2y|`fxl2yp1"
+    "|`f2xm1|fln`|flog`|f**|faln|falog|fsqrt`|sqrt|fsinh|fcosh|ftanh"
+    "|fasinh|facosh|fatanh|fsin`|fcos`|ftan`|fsincos`|fasin|facos"
+    "|fatan`|fatan2`|f0<`|f0>=`|f0<>`|f0=`|f0<=`|f0>`|`f?1|f<`|f>=`"
+    
"|f<>`|f=`|f<=`|f>`|`f?2|f~|address@hidden|address@hidden|f+!`|f!`|dupf!`|f,`|fvariable`"
+    "|flit`|fconstant`|f#|f.|f.s`|fnumber|uart!|port!|.ports`|COM"
+    "|bps|.bps`|noParity|oddParity|evenParity|DSR?|CTS?|RI?|CD?"
+    "|RTS0|RTS1|DTR0|DTR1|UBREAK|RX|RX?|key?|TX|XRECV|XSEND"
+    "|dumpterm|dumbterm|utrace"
+    "|"
+};
+
+enum {
+    FF_STYLE_TEXT        = QE_STYLE_DEFAULT,
+    FF_STYLE_COMMENT     = QE_STYLE_COMMENT,
+    FF_STYLE_KEYWORD     = QE_STYLE_KEYWORD,
+    FF_STYLE_STRING      = QE_STYLE_STRING,
+    FF_STYLE_NUMBER      = QE_STYLE_NUMBER,
+};
+
+enum {
+    IN_FF_TRAIL = 1,     /* beyond EOF directive */
+    IN_FF_COMMENT = 2,   /* multiline comment ( ... ) */
+};
+
+static int ff_convert_date(int year, int month, int day)
+{
+    /* convert date to generalized gregorian day number */
+    int gday = 0;
+
+    if (year >= 0 && month > 0) {
+        static int const elapsed_days[12] = {
+            0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334,
+        };
+        int mm = month - 1;
+        int yy = year + mm / 12;
+        mm %= 12;
+        yy -= 1;
+        gday = year * 365 + yy / 4 - yy / 100 + yy / 400;
+        gday += elapsed_days[mm];
+        if (year % 4 == 0 && (year % 100 != 0 || year % 400 == 0) && mm > 1)
+            gday += 1;
+        gday += day - 60;       /* starting on 1/3/0000 */
+    }
+    return gday;
+}
+
+static int ff_match_number(const char *str, int *pnum)
+{
+    int i = 0, base = 10, c, digit;
+    int year = -1, month = -1;
+    long long num = 0, stash = 0;
+
+    if (str[i] == '-') {
+        i++;
+        if (str[i] == '\0')
+            return 0;
+    }
+
+    for (; (c = str[i]) != '\0'; i++) {
+        switch (c) {
+        case '\'':
+            continue;
+        case '$':
+            base = 16;
+            continue;
+        case '&':
+            base = 8;
+            continue;
+        case '%':
+            base = 2;
+            continue;
+        case '#':
+            base = num;
+            num = 0;
+            continue;
+        case ':':
+            if (i == 0)
+                break;
+            stash = (stash + num) * 60;
+            num = 0;
+            continue;
+        case '_':
+            if (i == 0)
+                break;
+            if (year >= 0 && month >= 0) {
+                num = ff_convert_date(year, month, num);
+                num = 0;
+                year = month = -1;
+            }
+            stash = (stash + num) * 24;
+            num = 0;
+            continue;
+        case '-':
+            if (i == 0)
+                break;
+            if (year < 0)
+                year = num;
+            else
+                month = num;
+            num = 0;
+            continue;
+        default:
+            if (c >= '0' && c <= '9')
+                digit = c - '0';
+            else
+            if (c >= 'a' && c <= 'z')
+                digit = c - 'a' + 10;
+            else
+            if (c >= 'A' && c <= 'Z')
+                digit = c - 'A' + 10;
+            else
+                digit = 255;
+            if (digit >= base)
+                break;
+            num = num * base + digit;
+            continue;
+        }
+        break;
+    }
+    if (year >= 0 && month >= 0) {
+        stash = ff_convert_date(year, month, num);
+        num = 0;
+    }
+    num += stash;
+    if (i > 0 && str[i] == '\0') {
+        if (pnum)
+            *pnum = (*str == '-') ? -num : num;
+        return i;
+    }
+    return 0;
+}
+
+static void ff_colorize_line(QEColorizeContext *cp,
+                             unsigned int *str, int n, ModeDef *syn)
+{
+    char word[64];
+    int i = 0, start = 0, c, num = 0, len, numlen, colstate = 
cp->colorize_state;
+
+    if (colstate & IN_FF_TRAIL)
+        goto comment;
+
+    if (str[0] == '#' && str[1] == '!')
+        goto comment;
+
+    for (; i < n;) {
+        start = i;
+        c = str[i++];
+        if (c == '(' && str[i] == ' ') {
+            colstate |= IN_FF_COMMENT;
+        }
+        if (colstate & IN_FF_COMMENT) {
+            if (c == ')')
+                colstate &= ~IN_FF_COMMENT;
+            SET_COLOR1(str, start, FF_STYLE_COMMENT);
+            continue;
+        }
+        if (qe_isspace(c))
+            continue;
+        if (c == '\\' && str[i] == ' ') {
+        comment:
+            i = n;
+            SET_COLOR(str, start, i, FF_STYLE_COMMENT);
+            continue;
+        }
+        switch (c) {
+        case ',':
+        case '!':
+        case '.':
+            if (str[i] == '\"') {
+                i++;
+                goto string;
+            }
+            break;
+        case '\"':
+        string:
+            /* parse string const */
+            for (; i < n; i++) {
+                if (str[i] == '\\' && i + 1 < n) {
+                    i++;
+                } else
+                if (str[i] == '\"') {
+                    i++;
+                    break;
+                }
+            }
+        has_string:
+            SET_COLOR(str, start, i, FF_STYLE_STRING);
+            continue;
+        default:
+            break;
+        }
+        /* scan for space and determine word type */
+        len = 0;
+        word[len++] = c;
+        for (; i < n && !qe_isspace(str[i]); i++) {
+            if (len < countof(word) - 1)
+                word[len++] = str[i];
+        }
+        word[len] = '\0';
+        if (!strcmp("EOF", word) || !strcmp("EOF`", word)) {
+            SET_COLOR(str, start, i, FF_STYLE_KEYWORD);
+            colstate |= IN_FF_TRAIL;
+            start = i;
+            goto comment;
+        }
+        if (word[len - 1] == '\"')
+            goto has_string;
+
+        if (syn && syn->keywords) {
+            if (!strcmp("|`", word) || strfind(syn->keywords, word)) {
+                SET_COLOR(str, start, i, FF_STYLE_KEYWORD);
+                continue;
+            }
+            if (len < countof(word) - 1 && word[len - 1] != '`') {
+                word[len] = '`';
+                word[len + 1] = '\0';
+                if (!strcmp("|`", word) || strfind(syn->keywords, word)) {
+                    SET_COLOR(str, start, i, FF_STYLE_KEYWORD);
+                    continue;
+                }
+            }
+        }
+        numlen = len;
+        if (numlen > 1 && qe_findchar("|&^+-*/%~,", word[numlen - 1]))
+            word[--numlen] = '\0';
+        if (ff_match_number(word, &num) == numlen) {
+            SET_COLOR(str, start, start + numlen, FF_STYLE_NUMBER);
+            if (numlen < len)
+                SET_COLOR1(str, start + numlen, FF_STYLE_KEYWORD);
+            continue;
+        }
+    }
+    cp->colorize_state = colstate;
+}
+
+static int ff_probe(ModeDef *syn, ModeProbeData *pd)
+{
+    const char *p = (const char *)pd->buf;
+    const char *p1 = (const char *)pd->buf + pd->line_len;
+
+    if (match_extension(pd->filename, syn->extensions))
+        return 80;
+
+    if (p[0] == '#' && p[1] == '!') {
+        if (memstr(p, pd->line_len, "forth")
+        ||  memstr(p, pd->line_len, "fth")
+        ||  memstr(p, pd->line_len, "needs")) {
+            return 80;
+        }
+    }
+
+    if ((p[0] == ':' || p[0] == '\\') && p[1] == ' ')
+        return 60;
+
+    if ((p1[0] == ':' || p1[0] == '\\') && p[1] == ' ')
+        return 50;
+
+    return 1;
+}
+
+static ModeDef ff_mode = {
+    .name = "Forth",
+    .extensions = "ff|fth|fs|fr|4th",
+    .mode_probe = ff_probe,
+    .keywords = ff_keywords,
+    .colorize_func = ff_colorize_line,
+};
+
+static int ff_init(void)
+{
+    qe_register_mode(&ff_mode, MODEF_SYNTAX);
+    return 0;
+}
+
+qe_module_init(ff_init);