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