Add loadable modules.
[mes.git] / module / language / paren.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright © 2008 Derek Peschel
5 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;
7 ;;; This file is part of Mes.
8 ;;;
9 ;;; Mes is free software; you can redistribute it and/or modify it
10 ;;; under the terms of the GNU General Public License as published by
11 ;;; the Free Software Foundation; either version 3 of the License, or (at
12 ;;; your option) any later version.
13 ;;;
14 ;;; Mes is distributed in the hope that it will be useful, but
15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 ;;; GNU General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU General Public License
20 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
21
22 ;;; Commentary:
23
24 ;;; paren.mes is a simple yet full lalr test for Mes taken from the
25 ;;; Gambit wiki.
26 ;;;
27 ;;; Run with Guile:
28 ;;;    echo '___P((()))' | guile -s <(echo '(paren-depth)' | cat cc/paren.mes -)
29
30 ;;; Code:
31
32 (cond-expand
33   (guile
34    (use-modules (system base lalr)))
35   (mes
36    (mes-use-module (srfi srfi-9))
37    (mes-use-module (mes lalr))))
38
39 ;;; Taken from http://gambitscheme.org/wiki/index.php/Lalr_example
40 ;;; LGPL 2.1 / Apache 2.0
41
42 ;;; Read C source code, breaking it into the following types of tokens:
43 ;;; the identifier ___P, other identifiers, left and right parentheses,
44 ;;; and any other non-spacing character.  White space (space, tab, and
45 ;;; newline characters) is never a token and may come between any two
46 ;;; tokens, before the first, or after the last.
47
48 ;;; Whenever the identifier ___P is seen, read a left parenthesis
49 ;;; followed by a body (zero or more tokens) followed by a right
50 ;;; parenthesis.  If the body contains parentheses they must be properly
51 ;;; paired.  Other tokens in the body, including ___P, have no effect.
52 ;;; Count the deepest nesting level used in the body.  Count the maximum
53 ;;; deepest level (of all the bodies seen so far).
54
55 ;;; At the end of the file, print the maximum deepest level, or 0 if no
56 ;;; bodies were found.
57
58
59 ;;; Global variables used by lexical analyzer and parser.
60 ;;; The lexical analyzer needs them to print the maximum level at the
61 ;;; end of the file.
62
63 (define depth 0)
64 (define max-depth 0)
65
66 ;;; Lexical analyzer.  Passes tokens to the parser.
67
68 (define (paren-depth-lexer errorp)
69   (lambda ()
70
71     ;; Utility functions, for identifying characters, skipping any
72     ;; amount of white space, or reading multicharacter tokens.
73
74     (letrec ((char-whitespace?
75               (lambda (c)
76                 (or (char=? c #\space)
77                     (char=? c #\tab)
78                     (char=? c #\newline))))
79              (skip-whitespace
80               (lambda ()
81                 (let loop ((c (peek-char)))
82                   (if (and (not (eof-object? c))
83                            (char-whitespace? c))
84                       (begin (read-char)
85                              (loop (peek-char)))))))
86
87              (char-in-id?
88               (lambda (c)
89                 (or (char-alphabetic? c)
90                     (char=? c #\_))))
91              (read-___P-or-other-id
92               (lambda (l)
93                 (let ((c (peek-char)))
94                   (if (char-in-id? c)
95                       (read-___P-or-other-id (cons (read-char) l))
96                       ;; else
97                       (if (equal? l '(#\P #\_ #\_ #\_))
98                           '___P
99                           ;; else
100                           'ID))))))
101
102       ;; The lexer function.
103
104       (skip-whitespace)
105       (let loop ((c (read-char)))
106         (cond
107          ((eof-object? c)      (begin (display "max depth ")
108                                       (display max-depth)
109                                       (newline)
110                                       '*eoi*))
111          ((char-whitespace? c) (begin (errorp "didn't expect whitespace " c)
112                                       (loop (read-char))))
113          ((char-in-id? c)      (read-___P-or-other-id (list c)))
114          ((char=? c #\()       'LPAREN)
115          ((char=? c #\))       'RPAREN)
116          (else                 'CHAR))))))
117
118 ;;; Parser.
119
120 (define paren-depth-parser
121   (lalr-parser
122
123    ;; Options.
124
125    (expect: 0) ;; even one conflict is an error
126
127    ;; List of terminal tokens.
128
129    (CHAR LPAREN RPAREN ID ___P)
130
131    ;; Grammar rules.
132
133    (file       (newfile tokens))
134    (newfile    ()                      : (begin (set! depth 0)
135                                                 (set! max-depth 0)))
136
137    (tokens     (tokens token)
138                 (token))
139
140    ;; When not after a ___P, the structure of the file is unimportant.
141    (token      (CHAR)
142                 (LPAREN)
143                 (RPAREN)
144                 (ID)
145
146    ;; But after a ___P, we start counting parentheses.
147                 (___P newexpr in LPAREN exprs RPAREN out)
148                 (___P newexpr in LPAREN       RPAREN out))
149    (newexpr    ()                      : (set! depth 0))
150
151    ;; Inside an expression, ___P is treated like all other identifiers.
152    ;; Only parentheses do anything very interesting.  I'm assuming Lalr
153    ;; will enforce the pairing of parentheses, so my in and out actions
154    ;; don't check for too many or too few closing parens.
155
156    (exprs      (exprs expr)
157                 (expr))
158
159    (expr       (CHAR)
160                 (in LPAREN exprs RPAREN out)
161                 (in LPAREN       RPAREN out)
162                 (ID)
163                 (___P))
164    (in         ()                      : (begin (set! depth (+ depth 1))
165                                                 (if (> depth max-depth)
166                                                   (set! max-depth depth))))
167    (out        ()                      : (set! depth (- depth 1)))))
168
169 ;;; Main program.
170
171 (define paren-depth
172   (let ((errorp
173           (lambda args
174             (for-each display args)
175             (newline))))
176     (lambda ()
177       (paren-depth-parser (paren-depth-lexer errorp) errorp))))