lalr paren test

GNUmakefile

@@ -83,3 +83,12 @@ record: all
 	cat scm.mes syntax.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
 
 
+paren: all
+	cat scm.mes syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm paren.scm | ./mes
+#	#echo '___P((()))'
+
+paren.test: lib/lalr.scm paren.scm
+	cat $^ > $@
+
+guile-paren: paren.test
+	echo '___P((()))' | guile -s $^ 

lib/lalr.mes

@@ -0,0 +1,8 @@
+
+(define pprint display)
+(define lalr-keyword? symbol?)
+(define-macro (BITS-PER-WORD) 30)
+(define-macro (logical-or x . y) `(logior ,x ,@y))
+(define-macro (lalr-error msg obj) `(error ,msg ,obj))
+(define (note-source-location lvalue tok) lvalue)
+(define *eoi* -1)

lib/lalr.scm

@@ -20,7 +20,6 @@
 
 (define *lalr-scm-version* "2.5.0")
 
-
 (cond-expand 
 
  ;; -- Gambit-C
@@ -79,6 +78,7 @@
 
  ;; -- Guile
  (guile
+  (display "GUILE") (newline)
   (use-modules (ice-9 pretty-print))
   (use-modules (srfi srfi-9))
 
@@ -98,8 +98,15 @@
   (mes
    (display "MES!")
    (newline)
-   )
 
+   (define pprint display)
+   (define lalr-keyword? symbol?)
+   (define-macro (BITS-PER-WORD) 30)
+   (define-macro (logical-or x . y) `(logior ,x ,@y))
+   (define-macro (lalr-error msg obj) `(error ,msg ,obj))
+   (define (note-source-location lvalue tok) lvalue)
+   )
+  
  ;; -- Kawa
  (kawa
   (require 'pretty-print)

paren.scm

@@ -0,0 +1,138 @@
+;;; Read C source code, breaking it into the following types of tokens:
+;;; the identifier ___P, other identifiers, left and right parentheses,
+;;; and any other non-spacing character.  White space (space, tab, and
+;;; newline characters) is never a token and may come between any two
+;;; tokens, before the first, or after the last.
+
+;;; Whenever the identifier ___P is seen, read a left parenthesis
+;;; followed by a body (zero or more tokens) followed by a right
+;;; parenthesis.  If the body contains parentheses they must be properly
+;;; paired.  Other tokens in the body, including ___P, have no effect.
+;;; Count the deepest nesting level used in the body.  Count the maximum
+;;; deepest level (of all the bodies seen so far).
+
+;;; At the end of the file, print the maximum deepest level, or 0 if no
+;;; bodies were found.
+
+
+;;; Global variables used by lexical analyzer and parser.
+;;; The lexical analyzer needs them to print the maximum level at the
+;;; end of the file.
+
+(define depth 0)
+(define max-depth 0)
+
+;;; Lexical analyzer.  Passes tokens to the parser.
+
+(define (paren-depth-lexer errorp)
+  (lambda ()
+
+    ;; Utility functions, for identifying characters, skipping any
+    ;; amount of white space, or reading multicharacter tokens.
+
+    (letrec ((char-whitespace?
+              (lambda (c)
+                (or (char=? c #\space)
+                    (char=? c #\tab)
+                    (char=? c #\newline))))
+             (skip-whitespace
+              (lambda ()
+                (let loop ((c (peek-char)))
+                  (if (and (not (eof-object? c))
+                           (char-whitespace? c))
+                      (begin (read-char)
+                             (loop (peek-char)))))))
+
+             (char-in-id?
+              (lambda (c)
+                (or (char-alphabetic? c)
+                    (char=? c #\_))))
+             (read-___P-or-other-id
+              (lambda (l)
+                (let ((c (peek-char)))
+                  (if (char-in-id? c)
+                      (read-___P-or-other-id (cons (read-char) l))
+                      ;; else
+                      (if (equal? l '(#\P #\_ #\_ #\_))
+                          '___P
+                          ;; else
+                          'ID))))))
+
+      ;; The lexer function.
+
+      (skip-whitespace)
+      (let loop ((c (read-char)))
+        (cond
+         ((eof-object? c)      (begin (display "max depth ")
+                                      (display max-depth)
+                                      (newline)
+                                      '*eoi*))
+         ((char-whitespace? c) (begin (errorp "didn't expect whitespace " c)
+                                      (loop (read-char))))
+         ((char-in-id? c)      (read-___P-or-other-id (list c)))
+         ((char=? c #\()       'LPAREN)
+         ((char=? c #\))       'RPAREN)
+         (else                 'CHAR))))))
+
+;;; Parser.
+
+(define paren-depth-parser
+  (lalr-parser
+
+   ;; Options.
+
+   ;; (expect: 0) ;; even one conflict is an error
+
+   ;; List of terminal tokens.
+
+   (CHAR LPAREN RPAREN ID ___P)
+
+   ;; Grammar rules.
+
+   (file       (newfile tokens))
+   (newfile    ()                      : (begin (set! depth 0)
+                                                (set! max-depth 0)))
+
+   (tokens     (tokens token)
+                (token))
+
+   ;; When not after a ___P, the structure of the file is unimportant.
+   (token      (CHAR)
+                (LPAREN)
+                (RPAREN)
+                (ID)
+
+   ;; But after a ___P, we start counting parentheses.
+                (___P newexpr in LPAREN exprs RPAREN out)
+                (___P newexpr in LPAREN       RPAREN out))
+   (newexpr    ()                      : (set! depth 0))
+
+   ;; Inside an expression, ___P is treated like all other identifiers.
+   ;; Only parentheses do anything very interesting.  I'm assuming Lalr
+   ;; will enforce the pairing of parentheses, so my in and out actions
+   ;; don't check for too many or too few closing parens.
+
+   (exprs      (exprs expr)
+                (expr))
+
+   (expr       (CHAR)
+                (in LPAREN exprs RPAREN out)
+                (in LPAREN       RPAREN out)
+                (ID)
+                (___P))
+   (in         ()                      : (begin (set! depth (+ depth 1))
+                                                (if (> depth max-depth)
+                                                  (set! max-depth depth))))
+   (out        ()                      : (set! depth (- depth 1)))))
+
+;;; Main program.
+
+(define paren-depth
+  (let ((errorp
+          (lambda args
+            (for-each display args)
+            (newline))))
+    (lambda ()
+      (paren-depth-parser (paren-depth-lexer errorp) errorp))))
+
+(paren-depth)

scm.mes

@@ -134,6 +134,11 @@
 
 (define assv assq)
 
+(define (assoc key alist)
+  (cond ((null? alist) #f)
+        ((equal? key (caar alist)) (car alist))
+        (#t (assoc key (cdr alist)))))
+
 (define (memq x lst)
   (cond ((null? lst) #f)
         ((eq? x (car lst)) lst)
@@ -198,8 +203,26 @@
 
 (define else #t)
 
+(define (error who . rest)
+  (display "error:")
+  (display who)
+  (display ":")
+  (display rest)
+  (display newline))
+
+(define (syntax-error message . rest)
+  (display "syntax-error:")
+  (display message)
+  (display ":")
+  (display rest)
+  (newline))
+
 ;; srfi-1
 (define (last-pair lst)
   (let loop ((lst lst))
     (if (or (null? lst) (null? (cdr lst))) lst
         (loop (cdr lst)))))
+
+(define (reverse lst)
+  (if (null? lst) '()
+      (append (reverse (cdr lst)) (cons (car lst) '()))))

test.mes

@@ -140,6 +140,7 @@
 (pass-if "assq-ref 2" (seq? (assq-ref '((b . 1) (c . 2)) 'a) #f))
 (pass-if "assq-set!" (sequal? (assq-set! '((b . 1)) 'a 0) '((a . 0) (b . 1))))
 (pass-if "assq-set! 2" (sequal? (assq-set! '((a . 0)) 'a 1) '((a . 1))))
+(pass-if "assoc" (sequal? (assoc '(a . 0) '((a . 0) (b . 1) ((a . 0) aa))) '((a . 0) aa)))
 
 ;; works, but debugging is foo
 ;; (cond ((defined? 'loop2)
@@ -224,7 +225,7 @@
                #t))
 
 (pass-if "last-pair " (sequal? (last-pair '(1 2 3 4)) '(4)))
-(pass-if "last-pair 2" (eq? (last-pair '()) '()))
+(pass-if "last-pair 2" (seq? (last-pair '()) '()))
 ;; (pass-if "circular-list? "
 ;;   (seq?
 ;;    (let ((x (list 1 2 3 4)))
@@ -232,6 +233,8 @@
 ;;      (circular-list? x))
 ;;    #t))
 
+(pass-if "reverse" (sequal? (reverse '(1 2 3)) '(3 2 1)))
+
 (pass-if "cond-expand" (sequal? (cond-expand (foobar #f) (mes (display ": pass: *YAY*") 'mes) (guile (display ": pass: *GUILE*") 'mes)) 'mes))
 
 (begin (define *top-begin-a* '*top-begin-a*))