More error handling on apply_env.
[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 ;;; paren.mes: 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    )
36   (mes
37    (mes-use-module (mes base-0))
38    (mes-use-module (mes base))
39    (mes-use-module (mes quasiquote))
40    (mes-use-module (mes let))
41    (mes-use-module (mes scm))
42    (mes-use-module (mes syntax))
43    (mes-use-module (srfi srfi-0))
44    (mes-use-module (mes record-0))
45    (mes-use-module (mes record))
46    (mes-use-module (srfi srfi-9))
47    (mes-use-module (mes lalr-0))
48    (mes-use-module (mes lalr))
49    ))
50
51 ;;; Taken from http://gambitscheme.org/wiki/index.php/Lalr_example
52 ;;; LGPL 2.1 / Apache 2.0
53
54 ;;; Read C source code, breaking it into the following types of tokens:
55 ;;; the identifier ___P, other identifiers, left and right parentheses,
56 ;;; and any other non-spacing character.  White space (space, tab, and
57 ;;; newline characters) is never a token and may come between any two
58 ;;; tokens, before the first, or after the last.
59
60 ;;; Whenever the identifier ___P is seen, read a left parenthesis
61 ;;; followed by a body (zero or more tokens) followed by a right
62 ;;; parenthesis.  If the body contains parentheses they must be properly
63 ;;; paired.  Other tokens in the body, including ___P, have no effect.
64 ;;; Count the deepest nesting level used in the body.  Count the maximum
65 ;;; deepest level (of all the bodies seen so far).
66
67 ;;; At the end of the file, print the maximum deepest level, or 0 if no
68 ;;; bodies were found.
69
70
71 ;;; Global variables used by lexical analyzer and parser.
72 ;;; The lexical analyzer needs them to print the maximum level at the
73 ;;; end of the file.
74
75 (define depth 0)
76 (define max-depth 0)
77
78 ;;; Lexical analyzer.  Passes tokens to the parser.
79
80 (define (paren-depth-lexer errorp)
81   (lambda ()
82
83     ;; Utility functions, for identifying characters, skipping any
84     ;; amount of white space, or reading multicharacter tokens.
85
86     (letrec ((char-whitespace?
87               (lambda (c)
88                 (or (char=? c #\space)
89                     (char=? c #\tab)
90                     (char=? c #\newline))))
91              (skip-whitespace
92               (lambda ()
93                 (let loop ((c (peek-char)))
94                   (if (and (not (eof-object? c))
95                            (char-whitespace? c))
96                       (begin (read-char)
97                              (loop (peek-char)))))))
98
99              (char-in-id?
100               (lambda (c)
101                 (or (char-alphabetic? c)
102                     (char=? c #\_))))
103              (read-___P-or-other-id
104               (lambda (l)
105                 (let ((c (peek-char)))
106                   (if (char-in-id? c)
107                       (read-___P-or-other-id (cons (read-char) l))
108                       ;; else
109                       (if (equal? l '(#\P #\_ #\_ #\_))
110                           '___P
111                           ;; else
112                           'ID))))))
113
114       ;; The lexer function.
115
116       (skip-whitespace)
117       (let loop ((c (read-char)))
118         (cond
119          ((eof-object? c)      (begin (display "max depth ")
120                                       (display max-depth)
121                                       (newline)
122                                       '*eoi*))
123          ((char-whitespace? c) (begin (errorp "didn't expect whitespace " c)
124                                       (loop (read-char))))
125          ((char-in-id? c)      (read-___P-or-other-id (list c)))
126          ((char=? c #\()       'LPAREN)
127          ((char=? c #\))       'RPAREN)
128          (else                 'CHAR))))))
129
130 ;;; Parser.
131
132 (define paren-depth-parser
133   (lalr-parser
134
135    ;; Options.
136
137    (expect: 0) ;; even one conflict is an error
138
139    ;; List of terminal tokens.
140
141    (CHAR LPAREN RPAREN ID ___P)
142
143    ;; Grammar rules.
144
145    (file       (newfile tokens))
146    (newfile    ()                      : (begin (set! depth 0)
147                                                 (set! max-depth 0)))
148
149    (tokens     (tokens token)
150                 (token))
151
152    ;; When not after a ___P, the structure of the file is unimportant.
153    (token      (CHAR)
154                 (LPAREN)
155                 (RPAREN)
156                 (ID)
157
158    ;; But after a ___P, we start counting parentheses.
159                 (___P newexpr in LPAREN exprs RPAREN out)
160                 (___P newexpr in LPAREN       RPAREN out))
161    (newexpr    ()                      : (set! depth 0))
162
163    ;; Inside an expression, ___P is treated like all other identifiers.
164    ;; Only parentheses do anything very interesting.  I'm assuming Lalr
165    ;; will enforce the pairing of parentheses, so my in and out actions
166    ;; don't check for too many or too few closing parens.
167
168    (exprs      (exprs expr)
169                 (expr))
170
171    (expr       (CHAR)
172                 (in LPAREN exprs RPAREN out)
173                 (in LPAREN       RPAREN out)
174                 (ID)
175                 (___P))
176    (in         ()                      : (begin (set! depth (+ depth 1))
177                                                 (if (> depth max-depth)
178                                                   (set! max-depth depth))))
179    (out        ()                      : (set! depth (- depth 1)))))
180
181 ;;; Main program.
182
183 (define paren-depth
184   (let ((errorp
185           (lambda args
186             (for-each display args)
187             (newline))))
188     (lambda ()
189       (paren-depth-parser (paren-depth-lexer errorp) errorp))))