Prepare for 0.1 release: new directory structure.
authorJan Nieuwenhuizen <janneke@gnu.org>
Wed, 12 Oct 2016 21:40:11 +0000 (23:40 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Wed, 12 Oct 2016 21:40:11 +0000 (23:40 +0200)
* scripts/elf.mes: New file.
* scripts/include.mes: New file.
* scripts/mescc.mes: New file.
* scripts/paren.mes: New file.
* scripts/repl.mes: New file.
* doc/examples/main.c: Move from ./main.c.
* module/mes/base-0.mes: Move from ./base0.mes.
* module/mes/base.mes: Move from top.
* module/mes/elf.mes: Likewise.
* module/mes/let-syntax.mes: Likewise.
* module/mes/let.mes: Likewise.
* module/mes/mes.mes: Likewise.
* module/mes/quasiquote.mes: Likewise.
* module/mes/repl.mes: Likewise.
* module/mes/scm.mes: Likewise.
* module/mes/syntax.mes: Likewise.
* module/mes/lalr-0.mes: Move from lib/lalr.mes.
* module/mes/lalr.mes: Move from lib/lalr.scm.
* module/mes/match.mes: Move from lib/match.scm.
* module/mes/record-0.mes: Move from lib/record.mes.
* module/mes/record.mes: Move from lib/record.scm.
* module/mes/test.mes: Move flom lib/.
* module/rnrs/bytevectors.mes: Move from lib/rnrs.
* module/srfi/srfi-0.mes: Move from lib/srfi.
* module/srfi/srfi-1.mes: Likewise.
* module/srfi/srfi-9.mes: Likewise.
* module/language/c/lexer.mes: Move from ./c-lexer.scm.
* module/language/c/parser.mes: Move from ./mescc.scm.
* module/language/c/compiler.mes: New file, split from parser.mes.
* module/language/paren.mes: Move from ./paren.scm.
* module/mes/libc-i386.mes: New file, split from elf.mes.
* tests/base.test: Move from test/.
* tests/closure.test: Likewise.
* tests/let-syntax.test: Likewise.
* tests/let.test: Likewise.
* tests/match.test: Likewise.
* tests/quasiquote.test: Likewise.
* tests/record.test: Likewise.
* tests/scm.test: Likewise.
* hello.S: Remove.
* hello.c: Remove.
* loop2.mes: Remove.
* test/foo.test: Remove.

84 files changed:
.gitignore
GNUmakefile
TODO
base.mes [deleted file]
base0-if.mes [deleted file]
base0.mes [deleted file]
c-lexer.scm [deleted file]
doc/examples/main.c [new file with mode: 0644]
elf.mes [deleted file]
guile/mes-0.scm [new file with mode: 0644]
guile/mes.scm [new file with mode: 0755]
hello.S [deleted file]
hello.c [deleted file]
let-syntax.mes [deleted file]
let.mes [deleted file]
lib/elf.mes [deleted file]
lib/lalr.mes [deleted file]
lib/lalr.scm [deleted file]
lib/match.scm [deleted file]
lib/record.mes [deleted file]
lib/record.scm [deleted file]
lib/rnrs/bytevectors.scm [deleted file]
lib/srfi/srfi-0.scm [deleted file]
lib/srfi/srfi-1.scm [deleted file]
lib/srfi/srfi-9.scm [deleted file]
lib/test.mes [deleted file]
loop2.mes [deleted file]
main.c [deleted file]
mes.mes [deleted file]
mes.scm [deleted file]
mes.test [deleted file]
mescc.scm [deleted file]
module/language/c/compiler.mes [new file with mode: 0644]
module/language/c/lexer.mes [new file with mode: 0644]
module/language/c/parser.mes [new file with mode: 0644]
module/language/paren.mes [new file with mode: 0644]
module/mes/base-0.mes [new file with mode: 0644]
module/mes/base.mes [new file with mode: 0644]
module/mes/elf.mes [new file with mode: 0644]
module/mes/lalr-0.mes [new file with mode: 0644]
module/mes/lalr.mes [new file with mode: 0644]
module/mes/let-syntax.mes [new file with mode: 0644]
module/mes/let.mes [new file with mode: 0644]
module/mes/libc-i386.mes [new file with mode: 0644]
module/mes/match.mes [new file with mode: 0644]
module/mes/mes.mes [new file with mode: 0644]
module/mes/quasiquote.mes [new file with mode: 0644]
module/mes/record-0.mes [new file with mode: 0644]
module/mes/record.mes [new file with mode: 0644]
module/mes/repl.mes [new file with mode: 0644]
module/mes/scm.mes [new file with mode: 0644]
module/mes/syntax.mes [new file with mode: 0644]
module/mes/test.mes [new file with mode: 0644]
module/rnrs/bytevectors.mes [new file with mode: 0644]
module/srfi/srfi-0.mes [new file with mode: 0644]
module/srfi/srfi-1.mes [new file with mode: 0644]
module/srfi/srfi-9.mes [new file with mode: 0644]
paren.scm [deleted file]
quasiquote.mes [deleted file]
repl.mes [deleted file]
scm.mes [deleted file]
scripts/elf.mes [new file with mode: 0755]
scripts/include.mes [new file with mode: 0755]
scripts/mescc.mes [new file with mode: 0755]
scripts/paren.mes [new file with mode: 0755]
scripts/repl.mes [new file with mode: 0755]
syntax.mes [deleted file]
test/base.test [deleted file]
test/closure.test [deleted file]
test/foo.test [deleted file]
test/let-syntax.test [deleted file]
test/let.test [deleted file]
test/match.test [deleted file]
test/quasiquote.test [deleted file]
test/record.test [deleted file]
test/scm.test [deleted file]
tests/base.test [new file with mode: 0644]
tests/closure.test [new file with mode: 0644]
tests/let-syntax.test [new file with mode: 0644]
tests/let.test [new file with mode: 0644]
tests/match.test [new file with mode: 0644]
tests/quasiquote.test [new file with mode: 0644]
tests/record.test [new file with mode: 0644]
tests/scm.test [new file with mode: 0644]

index 8751850f53ed47ce1a10848995efbf94bbf997cd..cd8891a55a420df182f69d160872b508228e633b 100644 (file)
@@ -10,5 +10,3 @@
 /*.cat
 ?
 ?.mes
-/hello
-/hello.o
index 6647f290c3a95e610dcee230e86b482e22ad6a07..2c979c8ee62b4071ca396c1d510cbddc9529507e 100644 (file)
@@ -1,4 +1,4 @@
-.PHONY: all check default 
+.PHONY: all check clean default 
 #CFLAGS:=-std=c99 -O0
 CFLAGS:=-std=c99 -O3 -finline-functions
 #CFLAGS:=-pg -std=c99 -O0
@@ -10,6 +10,9 @@ all: mes
 
 mes: mes.c mes.h
 
+clean:
+       rm -f mes environment.i symbol.i mes.h *.cat a.out
+
 mes.h: mes.c GNUmakefile
        ( echo '#if MES_C'; echo '#if MES_FULL' 1>&2;\
        grep -E '^(scm [*])*[a-z0-9_]+ \(.*\)( {|$$)' $< | grep -Ev '\(.*(char |bool |int )' | sed -e 's,^scm [*],,' | sort |\
@@ -38,98 +41,42 @@ mes.h: mes.c GNUmakefile
 
 check: all guile-check mes-check
 
-mes-check: all
-#      ./mes.test
-#      ./mes.test ./mes
-       cat base0.mes base0-if.mes base.mes lib/test.mes test/base.test | ./mes
-       cat base0.mes base0-if.mes base.mes lib/test.mes test/closure.test | ./mes
-       cat base0.mes base0-if.mes base.mes quasiquote.mes lib/test.mes test/quasiquote.test | ./mes
-       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes lib/test.mes test/let.test | ./mes
-       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes lib/srfi/srfi-0.scm scm.mes lib/test.mes test/scm.test | ./mes
-       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes lib/srfi/srfi-0.scm scm.mes syntax.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/test.mes test/record.test |./mes
-ifneq ($(SYNTAX),)
-       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes let-syntax.mes lib/srfi/srfi-0.scm lib/test.mes test/let-syntax.test | ./mes
-       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes let-syntax.mes lib/srfi/srfi-0.scm lib/match.scm lib/test.mes test/match.test | ./mes
-else
-       @echo skipping slooowwww syntax tests
-endif
+TESTS:=\
+ tests/base.test\
+ tests/closure.test\
+ tests/quasiquote.test\
+ tests/let.test\
+ tests/scm.test\
+ tests/record.test\
+ tests/let-syntax.test\
+ tests/match.test\
+#
+
+BASE-0:=module/mes/base-0.mes
+MES-0:=guile/mes-0.scm
+MES:=./mes
 
-repl:
-       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes let-syntax.mes lib/srfi/srfi-0.scm lib/match.scm repl.mes /dev/stdin | ./mes 
+mes-check: all
+       for i in $(TESTS); do\
+               cat $(BASE-0) $$(scripts/include.mes $$i) $$i | $(MES);\
+       done
 
 guile-check:
-       guile -s <(cat base.mes lib/test.mes test/base.test)
-       guile -s <(cat base.mes lib/test.mes test/closure.test)
-       guile -s <(cat base.mes lib/test.mes test/quasiquote.test)
-       guile -s <(cat quasiquote.mes lib/test.mes test/quasiquote.test)
-#      guile -s <(cat base.mes quasiquote.mes let.mes lib/test.mes test/let.test)
-#      guile -s <(cat base.mes let.mes test/foo.test)
-#      exit 1
-       guile -s <(cat lib/test.mes test/base.test)
-       guile -s <(cat lib/test.mes test/quasiquote.test)
-       guile -s <(cat lib/test.mes test/let.test)
-       guile -s <(cat quasiquote.mes lib/test.mes test/base.test)
-       guile -s <(cat quasiquote.mes lib/test.mes test/quasiquote.test)
-       guile -s <(cat lib/test.mes test/record.test)
-       guile -s <(cat lib/test.mes test/let-syntax.test)
-       guile -s <(cat lib/test.mes test/match.test)
-
-run: all
-       cat scm.mes test.mes | ./mes
-
-psyntax: all
-       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
-
-syntax-case: all
-       cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
-
-syntax-case.cat: syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
-       cat $^ > $@
-
-guile-syntax-case: syntax-case.cat
-       guile -s $^
-
-peg: all
-       cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes | ./mes
-
-peg.cat: peg/pmatch.scm peg.mes peg/codegen.scm peg/string-peg.scm peg/simplify-tree.scm peg/using-parsers.scm peg/cache.scm peg-test.mes
-       cat $^ | sed 's,\(;; Packages the results of a parser\),(when (guile?) (set! compile-peg-pattern (@@ (ice-9 peg codegen) compile-peg-pattern)))\n\1,' > $@
-
-guile-peg: peg.cat
-#      guile -s peg-test.mes
-#      @echo "======================================="
-       guile -s $^
-
-clean:
-       rm -f mes environment.i symbol.i mes.h *.cat hello.o main.o a.out
-
-paren: all
-       echo -e 'EOF\n___P((()))' | cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes 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
-
-paren.cat: lib/lalr.scm paren.scm
-       cat $^ > $@
-
-guile-paren: paren.cat
-       echo '___P((()))' | guile -s $^ 
+       for i in $(TESTS); do\
+               guile -s <(cat $(MES-0) $$(scripts/include.mes $$i | grep -Ev 'let.mes|quasiquote.mes|srfi-0') $$i);\
+       done
+       for i in $(TESTS); do\
+               guile -s <(cat $(MES-0) module/mes/test.mes $$i);\
+       done
 
 mescc: all
-       echo ' EOF ' | cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes syntax.mes let-syntax.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm - main.c | ./mes > a.out
-       chmod +x a.out
+       scripts/mescc.mes
+       ./a.out
 
-mescc.cat: lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm
-       cat $^ > $@
+mescc.cat: $(MES-0) module/mes/lalr.mes module/mes/elf.mes module/mes/libc-i386.mes $(shell scripts/include.mes scripts/mescc.mes | grep -Ev '/mes/|/srfi/')
+       echo '(compile)' | cat $^ - > $@
 
 guile-mescc: mescc.cat
-       cat main.c | guile -s $^ > a.out
-       chmod +x a.out
-
-hello.o: hello.S
-       as --32 -march=i386 -o $@ $^
-
-hello: hello.o
-       ld -A i386 -m elf_i386 -nostdlib -nodefaultlibs -A i386 -o $@ $^
-#      ld -A i386 -m elf_i386 -A i386 -o $@ $^
-
-a.out: lib/elf.mes elf.mes GNUmakefile
-       cat base0.mes base0-if.mes base.mes quasiquote.mes let.mes scm.mes lib/rnrs/bytevectors.scm lib/elf.mes elf.mes | ./mes > a.out
+       cat doc/examples/main.c | guile -s $^ > a.out
        chmod +x a.out
+       ./a.out
diff --git a/TODO b/TODO
index c61a93049f12e475c75f00144dd87be9c41814c6..76dd3a9b97f3671872c7162fd7bbbd87d4a95cc6 100644 (file)
--- a/TODO
+++ b/TODO
@@ -62,6 +62,13 @@ http://www.muppetlabs.com/~breadbox/software/tiny/
 http://www.cirosantilli.com/elf-hello-world/
 
 ** SCM
+** RNRS
+   http://www.scheme-reports.org/
+*** Scheme
+ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-349.pdf
+*** RRS
+ftp://publications.ai.mit.edu/ai-publications/pdf/AIM-452.pdf
+
 http://groups.csail.mit.edu/mac/ftpdir/scm/OLD/scm2e.tar.Z
 wget http://groups.csail.mit.edu/mac/ftpdir/scm/OLD/scm3c13.tar.Z
 http://groups.csail.mit.edu/mac/ftpdir/scm/OLD/scm4a5.tar.Z
diff --git a/base.mes b/base.mes
deleted file mode 100644 (file)
index c2755e6..0000000
--- a/base.mes
+++ /dev/null
@@ -1,79 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; base.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(define (identity x) x)
-(define else #t)
-
-;; IF based
-(define-macro (or . x)
-  (if (null? x) #f ;; IF
-      (if (null? (cdr x)) (car x) ;; IF
-          (list 'if (car x) (car x)
-                (cons* 'or (cdr x))))))
-
-(define-macro (and . x)
-  (if (null? x) #t ;; IF
-      (if (null? (cdr x)) (car x) ;; IF
-          (list 'if (car x) (cons 'and (cdr x)) ;; IF
-                #f))))
-
-(define (not x)
-  (if x #f #t))
-
-(define (equal? a b) ;; FIXME: only 2 arg
-  (if (and (null? a) (null? b)) #t ;; IF
-      (if (and (pair? a) (pair? b))
-          (and (equal? (car a) (car b))
-               (equal? (cdr a) (cdr b)))
-          (if (and (string? a) (string? b)) ;; IF
-              (eq? (string->symbol a) (string->symbol b))
-              (if (and (vector? a) (vector? b)) ;; IF
-                  (equal? (vector->list a) (vector->list b))
-                  (eq? a b))))))
-
-(define (memq x lst)
-  (if (null? lst) #f ;; IF
-      (if (eq? x (car lst)) lst ;; IF
-          (memq x (cdr lst)))))
-
-(define guile? (not (pair? (current-module))))
-
-(define (map f l . r)
-  (if (null? l) '() ;; IF
-      (if (null? r) (cons (f (car l)) (map f (cdr l))) ;; IF
-          (if (null? (cdr r)) ;; IF
-              (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
-
-(define-macro (simple-let bindings . rest)
-  (cons (cons 'lambda (cons (map car bindings) rest))
-        (map cadr bindings)))
-
-(define-macro (let bindings . rest)
-  (cons* 'simple-let bindings rest))
-
-(define (list? x)
-  (or (null? x)
-      (and (pair? x) (list? (cdr x)))))
-
-(define (procedure? p)
-  (cond ((builtin? p) #t)
-        ((and (pair? p) (eq? (car p) 'lambda)))
-        ((and (pair? p) (eq? (car p) '*closure*)))
-        (#t #f)))
diff --git a/base0-if.mes b/base0-if.mes
deleted file mode 100644 (file)
index 551c2c5..0000000
+++ /dev/null
@@ -1,40 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; base.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(define (cons* x . rest)
-  (define (loop rest)
-    (if (null? (cdr rest)) (car rest)
-        (cons (car rest) (loop (cdr rest)))))
-  (loop (cons x rest)))
-
-(define-macro cond
-  (lambda clauses
-    (if (null? clauses) *unspecified*
-        (if (null? (cdr clauses))
-            (list 'if (car (car clauses))
-                  (cons* 'begin (car (car clauses)) (cdr (car clauses)))
-                  *unspecified*)
-            (if (eq? (car (cadr clauses)) 'else)
-                (list 'if (car (car clauses))
-                      (cons* 'begin (car (car clauses)) (cdr (car clauses)))
-                      (cons* 'begin *unspecified* (cdr (cadr clauses))))
-                (list 'if (car (car clauses))
-                      (cons* 'begin (car (car clauses)) (cdr (car clauses)))
-                      (cons* 'cond (cdr clauses))))))))
diff --git a/base0.mes b/base0.mes
deleted file mode 100644 (file)
index fc27aef..0000000
--- a/base0.mes
+++ /dev/null
@@ -1,26 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; base0.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-macro (defined? x)
-  (list 'assq x '(cddr (current-module))))
-
-(define (current-input-port) 0)
-(define (current-output-port) 1)
-(define (current-error-port) 2)
diff --git a/c-lexer.scm b/c-lexer.scm
deleted file mode 100644 (file)
index 7deadac..0000000
+++ /dev/null
@@ -1,415 +0,0 @@
-;;; ECMAScript for Guile
-
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
-
-;;;; 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-
-;;; Code:
-
-;; (define-module (language ecmascript tokenize)
-;;   #:use-module (ice-9 rdelim)
-;;   #:use-module ((srfi srfi-1) #:select (unfold-right))
-;;   #:use-module (system base lalr)
-;;   #:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))
-
-(cond-expand
-  (guile
-   ;;(use-modules ((ice-9 rdelim)))
-
-   (define (syntax-error what loc form . args)
-     (throw 'syntax-error #f what
-            ;;(and=> loc source-location->source-properties)
-            loc
-            form #f args))
-   
-   )
-  (mes
-
-      
-   )
-  )
-
-(define (read-delimited delims port handle-delim)
-     (let ((stop (string->list delims)))
-       (let loop ((c (peek-char)) (lst '()))
-         (if (member c stop)
-             (list->string lst)
-             (begin
-               (read-char)
-               (loop (peek-char) (append lst (list c))))))))
-
-(define (read-line . rest ;; port handle-delim
-         )
-  (let ((line (read-delimited "\n\r" (current-input-port) 'peek)))
-    (read-char)
-    line))
-
-(define (port-source-location port)
-  (make-source-location (port-filename port)
-                        (port-line port)
-                        (port-column port)
-                        (false-if-exception (ftell port))
-                        #f))
-
-;; taken from SSAX, sorta
-(define (read-until delims loc)
-  (if (eof-object? (peek-char))
-      (syntax-error "EOF while reading a token" loc #f)
-      (let ((token (read-delimited delims (current-input-port) 'peek)))
-        (if (eof-object? (peek-char))
-            (syntax-error "EOF while reading a token" loc token)
-            token))))
-
-(define (char-hex? c)
-  (and (not (eof-object? c))
-       (or (char-numeric? c)
-           (memv c '(#\a #\b #\c #\d #\e #\f))
-           (memv c '(#\A #\B #\C #\D #\E #\F)))))
-
-(define (digit->number c)
-  (- (char->integer c) (char->integer #\0)))
-
-(define (hex->number c)
-  (if (char-numeric? c)
-      (digit->number c)
-      (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
-
-(define (read-slash loc div?)
-  (let ((c1 (begin
-              (read-char)
-              (peek-char))))
-    (cond
-     ((eof-object? c1)
-      ;; hmm. error if we're not looking for a div? ?
-      (make-lexical-token '/ loc #f))
-     ((char=? c1 #\/)
-      (read-line)
-      (next-token div?))
-     ((char=? c1 #\*)
-      (read-char)
-      (let lp ((c (read-char)))
-        (cond
-         ((eof-object? c)
-          (syntax-error "EOF while in multi-line comment" loc #f))
-         ((char=? c #\*)
-          (if (eqv? (peek-char) #\/)
-              (begin
-                (read-char)
-                (next-token div?))
-              (lp (read-char))))
-         (else
-          (lp (read-char))))))
-     (div?
-      (case c1
-        ((#\=) (read-char) (make-lexical-token '/= loc #f))
-        (else (make-lexical-token '/ loc #f))))
-     (else
-      ;;;(read-regexp loc)
-      (make-lexical-token '/ loc #f)))))
-
-(define (read-string loc)
-  (let ((c (read-char)))
-    (let ((terms (string c #\\ #\newline #\return)))
-      (define (read-escape)
-        (let ((c (read-char)))
-          (case c
-            ((#\' #\" #\\) c)
-            ((#\b) #\backspace)
-            ((#\f) #\page)
-            ((#\n) #\newline)
-            ((#\r) #\return)
-            ((#\t) #\tab)
-            ((#\v) #\vt)
-            ((#\0)
-             (let ((next (peek-char)))
-               (cond
-                ((eof-object? next) #\nul)
-                ((char-numeric? next)
-                 (syntax-error "octal escape sequences are not supported"
-                               loc #f))
-                (else #\nul))))
-            ((#\x)
-             (let* ((a (read-char))
-                    (b (read-char)))
-               (cond
-                ((and (char-hex? a) (char-hex? b))
-                 (integer->char (+ (* 16 (hex->number a)) (hex->number b))))
-                (else
-                 (syntax-error "bad hex character escape" loc (string a b))))))
-            ((#\u)
-             (let* ((a (read-char))
-                    (b (read-char))
-                    (c (read-char))
-                    (d (read-char)))
-               (integer->char (string->number (string a b c d) 16))))
-            (else
-             c))))
-      (let lp ((str (read-until terms loc)))
-        (let ((terminator (peek-char)))
-          (cond
-           ((char=? terminator c)
-            (read-char)
-            (make-lexical-token 'StringLiteral loc str))
-           ((char=? terminator #\\)
-            (read-char)
-            (let ((echar (read-escape)))
-              (lp (string-append str (string echar)
-                                 (read-until terms loc)))))
-           (else
-            (syntax-error "string literals may not contain newlines"
-                          loc str))))))))
-
-(define *keywords*
-  '(("break" . break)
-    ("case" . case)
-    ("continue" . continue)
-    ("else" . else)
-    ("goto" . goto)
-
-    ("char" . char)
-    ("double" . double)
-    ("float" . float)
-    ("int" . int)
-    ("long" . long)
-    ("short" . short)
-    ("unsigned" . unsigned)
-    
-    ("return" . return)
-    ("void" . void)
-    ("for" . for)
-    ("switch" . switch)
-    ("while" . while)
-    ("continue" . continue)
-    ("default" . default)
-    ("if" . if)
-    ("do" . do)
-
-    ;; these aren't exactly keywords, but hey
-    ("true" . true)
-    ("false" . false)))
-
-(define (read-identifier loc)
-  (let lp ((c (peek-char)) (chars '()))
-    (if (or (eof-object? c)
-            (not (or (char-alphabetic? c)
-                     (char-numeric? c)
-                     (char=? c #\$)
-                     (char=? c #\_))))
-        (let ((word (list->string (reverse chars))))
-          (cond ((assoc-ref *keywords* word)
-                 (make-lexical-token (assoc-ref *keywords* word) loc #f))
-                (else (make-lexical-token 'Identifier loc
-                                          (string->symbol word)))))
-        (begin (read-char)
-               (lp (peek-char) (cons c chars))))))
-
-(define (read-numeric loc)
-  (let* ((c0 (if (char=? (peek-char) #\.)
-                 #\0
-                 (read-char)))
-         (c1 (peek-char)))
-    (cond
-     ((eof-object? c1) (digit->number c0))
-     ((and (char=? c0 #\0) (or (char=? c1 #\x) (char=? c1 #\X)))
-      (read-char)
-      (let ((c (peek-char)))
-        (if (not (char-hex? c))
-            (syntax-error "bad digit reading hexadecimal number"
-                          loc c))
-        (let lp ((c c) (acc 0))
-          (cond ((char-hex? c)
-                 (read-char)
-                 (lp (peek-char)
-                     (+ (* 16 acc) (hex->number c))))
-                (else
-                 acc)))))
-     ((and (char=? c0 #\0) (char-numeric? c1))
-      (let lp ((c c1) (acc 0))
-        (cond ((eof-object? c) acc)
-              ((char-numeric? c)
-               (if (or (char=? c #\8) (char=? c #\9))
-                   (syntax-error "invalid digit in octal sequence"
-                                 loc c))
-               (read-char)
-               (lp (peek-char)
-                   (+ (* 8 acc) (digit->number c))))
-              (else
-               acc))))
-     (else
-      (let lp ((c1 c1) (acc (digit->number c0)))
-        (cond
-         ((eof-object? c1) acc)
-         ((char-numeric? c1)
-          (read-char)
-          (lp (peek-char)
-              (+ (* 10 acc) (digit->number c1))))
-         ((or (char=? c1 #\e) (char=? c1 #\E))
-          (read-char)
-          (let ((add (let ((c (peek-char)))
-                       (cond ((eof-object? c)
-                              (syntax-error "error reading exponent: EOF"
-                                            loc #f))
-                             ((char=? c #\+) (read-char) +)
-                             ((char=? c #\-) (read-char) -)
-                             ((char-numeric? c) +)
-                             (else
-                              (syntax-error "error reading exponent: non-digit"
-                                            loc c))))))
-            (let lp ((c (peek-char)) (e 0))
-              (cond ((and (not (eof-object? c)) (char-numeric? c))
-                     (read-char)
-                     (lp (peek-char) (add (* 10 e) (digit->number c))))
-                    (else
-                     (* (if (negative? e) (* acc 1.0) acc) (expt 10 e)))))))
-         ((char=? c1 #\.)
-          (read-char)
-          (let lp2 ((c (peek-char)) (dec 0.0) (n -1))
-            (cond ((and (not (eof-object? c)) (char-numeric? c))
-                   (read-char)
-                   (lp2 (peek-char)
-                        (+ dec (* (digit->number c) (expt 10 n)))
-                        (1- n)))
-                  (else
-                   ;; loop back to catch an exponential part
-                   (lp c (+ acc dec))))))
-         (else
-          acc)))))))
-           
-(define *punctuation*
-  '(("{" . lbrace)
-    ("}" . rbrace)
-    ("(" . lparen)
-    (")" . rparen)
-    ("[" . lbracket)
-    ("]" . rbracket)
-    ("." . dot)
-    (";" . semicolon)
-    ("," . comma)
-    ("<" . <)
-    (">" . >)
-    ("<=" . <=)
-    (">=" . >=)
-    ("==" . ==)
-    ("!=" . !=)
-    ("===" . ===)
-    ("!==" . !==)
-    ("+" . +)
-    ("-" . -)
-    ("*" . *)
-    ("%" . %)
-    ("++" . ++)
-    ("--" . --)
-    ("<<" . <<)
-    (">>" . >>)
-    (">>>" . >>>)
-    ("&" . &)
-    ("|" . bor)
-    ("^" . ^)
-    ("!" . !)
-    ("~" . ~)
-    ("&&" . &&)
-    ("||" . or)
-    ("?" . ?)
-    (":" . colon)
-    ("=" . =)
-    ("+=" . +=)
-    ("-=" . -=)
-    ("*=" . *=)
-    ("%=" . %=)
-    ("<<=" . <<=)
-    (">>=" . >>=)
-    (">>>=" . >>>=)
-    ("&=" . &=)
-    ("|=" . bor=)
-    ("^=" . ^=)))
-
-(define *div-punctuation*
-  '(("/" . /)
-    ("/=" . /=)))
-
-;; node ::= (char (symbol | #f) node*)
-(define read-punctuation
-  (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*))
-                     (cond ((null? puncs)
-                            nodes)
-                           ((assv-ref nodes (string-ref (caar puncs) 0))
-                            (let ((node-tail (assv-ref nodes (string-ref (caar puncs) 0))))
-                              (if (= (string-length (caar puncs)) 1)
-                                  (set-car! node-tail (cdar puncs))
-                                  (set-cdr! node-tail
-                                            (lp (cdr node-tail)
-                                                `((,(substring (caar puncs) 1)
-                                                   . ,(cdar puncs))))))
-                              (lp nodes (cdr puncs))))
-                           (else
-                            (lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
-                                puncs))))))
-    (lambda (loc)
-      (let lp ((c (peek-char)) (tree punc-tree) (candidate #f))
-        ;;(display "read-punctuation c=") (display c) (newline)
-        (cond
-         ((assv-ref tree c)
-          (let ((node-tail (assv-ref tree c)))
-            (read-char)
-            (lp (peek-char) (cdr node-tail) (car node-tail))))
-         (candidate
-          (make-lexical-token candidate loc #f))
-         (else
-          (syntax-error "bad syntax: character not allowed" loc c)))))))
-
-(define (next-token div?)
-  (let ((c   (peek-char))
-        (loc (port-source-location (current-input-port))))
-    ;;(display "next-token c=") (display c) (newline)
-
-    (case c
-      ((#\tab #\vt #\page #\space ;;#\x00A0
-        ) ; whitespace
-       (read-char)
-       (next-token div?))
-      ((#\newline #\return)                 ; line break
-       (read-char)
-       (next-token div?))
-      ((#\/)
-       ;; division, single comment, double comment, or regexp
-       (read-slash loc div?))
-      ((#\" #\')                        ; string literal
-       (read-string loc))
-      (else
-       (cond
-        ((eof-object? c)
-         '*eoi*)
-        ((or (char-alphabetic? c)
-             (char=? c #\$)
-             (char=? c #\_))
-         ;; reserved word or identifier
-         (read-identifier loc))
-        ((char-numeric? c)
-         ;; numeric -- also accept . FIXME, requires lookahead
-         (make-lexical-token 'NumericLiteral loc (read-numeric loc)))
-        (else
-         ;; punctuation
-         (read-punctuation loc)))))))
-
-(define (c-lexer errorp)
-  (let ((div? #f))
-    (lambda ()
-      (let ((tok (next-token div?)))
-        (set! div? (and (lexical-token? tok)
-                        (let ((cat (lexical-token-category tok)))
-                          (or (eq? cat 'Identifier)
-                              (eq? cat 'NumericLiteral)
-                              (eq? cat 'StringLiteral)))))
-        tok))))
diff --git a/doc/examples/main.c b/doc/examples/main.c
new file mode 100644 (file)
index 0000000..929df2b
--- /dev/null
@@ -0,0 +1,8 @@
+int main ()
+{
+  int i; // = 0;
+  puts ("Hi Mes!\n");
+  for (i = 0; i < 4; ++i)
+    puts ("  Hello, world!\n");
+  return 1;
+}
diff --git a/elf.mes b/elf.mes
deleted file mode 100644 (file)
index eb68646..0000000
--- a/elf.mes
+++ /dev/null
@@ -1,82 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; scm.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(define (i386:puts data length)
-  `(
-     #xba ,@(int->bv32 length)      ;; mov    $0xe,%edx
-          #xb9 ,@(int->bv32 data)        ;; mov    $data,%ecx
-          #xbb #x01 #x00 #x00 #x00       ;; mov    $0x1,%ebx
-          #xb8 #x04 #x00 #x00 #x00       ;; mov    $0x4,%eax
-          #xcd #x80                      ;; int    $0x80
-          ))
-
-(define (i386:exit code)
-  `(
-    #xbb ,@(int->bv32 code)        ;; mov    $code,%ebx
-         #xb8 #x01 #x00 #x00 #x00       ;; mov    $0x1,%eax
-         #xcd #x80                      ;; int    $0x80
-         ))
-
-(define (i386:for start test step statement)
-`(
-
-  ;;   b:
-  #x89 #xe5                    ;; mov    %esp,%ebp
-       ;;21:
-       #xc7 #x45 #xf4 ,@(int->bv32 start) ;;   movl   $start,-0xc(%ebp)
-       ;;28:
-       #xeb ,(+ (length statement) 9) ;;x14    jmp    3e <main+0x3e>
-       ;;2a:
-       ;;#x83 #xec #x0c             ;; sub    $0xc,%esp
-       
-       ;;   9:
-       #x55   ;;                       push   %ebp
-       
-       ,@statement
-       #x5d   ;;                       pop   %ebp
-       ;;2d:
- ;;;;;;#x68 #x09 #x00 #x00 #x00       ;;       push   $0x9
-       ;;32:
- ;;;;;;#xe8 #xfc #xff #xff #xff       ;;       call   33 <main+0x33>
-       ;;37:
- ;;;;;;#x83 #xc4 #x10             ;;   add    $0x10,%esp
-       ;;3a:
-       ;;;;#x83 #x45 #xf4 ,step          ;;    addl   $step,-0xc(%ebp)
-       ;;3e:
-       ;;;;#x83 #x7d #xf4 ,test          ;;    cmpl   $test,-0xc(%ebp)
-       #x81 #x45 #xf4 ,@(int->bv32 step)       ;;addl   $step,-0xc(%ebp)
-       #x81 #x7d #xf4 ,@(int->bv32 test) ;;cmpl   $0x7cff,-0xc(%ebp)
-       ;;42:
-       ;;;#x7e ,(- 0 (length statement) 18) ;;#xe6 ;;  jle    2a <main+0x2a>
-       #x75 ,(- 0 (length statement) 18) ;;#xe6 ;;     jne    2a <main+0x2a>
-))
-
-(define data
-  (string->list "Hello, world!\n"))
-
-(define (text d)
-  (append
-   (i386:puts d (length data))
-   (i386:for 0 3 1 (i386:puts (+ d 6) (- (length data) 6)))
-   (i386:exit 0)
-   ))
-
-(define (write-any x) (write-char (if (char? x) x (integer->char x))))
-(map write-any (make-elf text data))
diff --git a/guile/mes-0.scm b/guile/mes-0.scm
new file mode 100644 (file)
index 0000000..64dd346
--- /dev/null
@@ -0,0 +1,31 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; mes-0.scm: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; mes-0.scm is the first file being loaded into Guile.  It provides
+;;; non-standard definitions that Mes modules and tests depend on.
+
+;;; Code:
+
+(define-macro (mes-use-module . rest) #t)
+(define builtin? procedure?) ; not strictly true, but ok for tests/*.test
+(define guile? (not (pair? (current-module))))
+(define EOF (if #f #f))
diff --git a/guile/mes.scm b/guile/mes.scm
new file mode 100755 (executable)
index 0000000..2794b07
--- /dev/null
@@ -0,0 +1,224 @@
+#! /bin/sh
+# -*-scheme-*-
+exec guile -L $(pwd)/module -e '(mes)' -s "$0" "$@"
+!#
+
+;;; Mes --- The Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;; The Maxwell Equations of Software -- John McCarthy page 13
+;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
+
+(define-module (mes)
+  #:export (main))
+
+(set-current-module
+ (make-module 10 `(,(resolve-interface
+                     '(guile)
+                     #:select '(
+                                ;; Debugging
+                                apply
+                                cons*
+                                current-error-port
+                                current-output-port
+                                display
+                                eof-object?
+                                exit
+                                force-output
+                                format
+                                newline
+                                read
+                                with-input-from-string
+
+                                ;; Guile admin
+                                module-define!
+                                resolve-interface
+
+                                ;; PRIMITIVES
+                                car
+                                cdr
+                                cons
+                                eq?
+                                null?
+                                pair?
+
+                                ;; ADDITIONAL PRIMITIVES
+                                number?
+                                procedure?
+                                <
+                                -
+                                )
+                     #:renamer (symbol-prefix-proc 'guile:)))))
+
+(define (logf port string . rest)
+  (guile:apply guile:format (guile:cons* port string rest))
+  (guile:force-output port)
+  #t)
+
+(define (stderr string . rest)
+  (guile:apply logf (guile:cons* (guile:current-error-port) string rest)))
+
+(define (stdout string . rest)
+  (guile:apply logf (guile:cons* (guile:current-output-port) string rest)))
+
+(define (debug . x) #t)
+;;(define debug stderr)
+
+;; TODO
+(define (atom? x)
+  (cond
+   ((guile:pair? x) #f)
+   ((guile:null? x) #f)
+   (#t x)))
+
+;; PRIMITIVES
+(define car guile:car)
+(define cdr guile:cdr)
+(define cons guile:cons)
+(define eq? guile:eq?)
+(define null? guile:null?)
+(define pair? guile:pair?)
+(define builtin? guile:procedure?)
+(define number? guile:number?)
+(define call guile:apply)
+
+(include-from-path "mes/mes.mes")
+
+(define (pairlis x y a)
+  ;;(debug "pairlis x=~a y=~a a=~a\n" x y a)
+  (cond
+   ((null? x) a)
+   ((atom? x) (cons (cons x y) a))
+   (#t (cons (cons (car x) (car y))
+             (pairlis (cdr x) (cdr y) a)))))
+
+(define (assq x a)
+  ;;(stderr "assq x=~a\n" x)
+  ;;(debug "assq x=~a a=~a\n" x a)
+  (cond
+   ((null? a) #f)
+   ((eq? (caar a) x) (car a))
+   (#t (assq x (cdr a)))))
+
+(define (append x y)
+  (cond ((null? x) y)
+        (#t (cons (car x) (append (cdr x) y)))))
+
+(define (eval-environment e a)
+  (eval e (append a environment)))
+
+(define (apply-environment fn e a)
+  (apply-env fn e (append a environment)))
+
+(define (readenv a)
+  (let ((x (guile:read)))
+    (if (guile:eof-object? x) '()
+        x)))
+
+(define environment
+  `(
+    (() . ())
+    (#t . #t)
+    (#f . #f)
+    
+    (*unspecified* . ,*unspecified*)
+
+    (atom? . ,atom?)
+    (car . ,car)
+    (cdr . ,cdr)
+    (cons . ,cons)
+    (cond . ,evcon)
+    (eq? . ,eq?)
+
+    (null? . ,null?)
+    (pair? . ,guile:pair?)
+    ;;(quote . ,quote)
+
+    (evlis . ,evlis)
+    (evcon . ,evcon)
+    (pairlis . ,pairlis)
+    (assq . ,assq)
+
+    (eval . ,eval-environment)
+    (apply-env . ,apply-environment)
+
+    (readenv . ,readenv)
+    (display . ,guile:display)
+    (newline . ,guile:newline)
+
+    (builtin? . ,builtin?)
+    (number? . ,number?)
+    (call . ,call)
+
+    (< . ,guile:<)
+    (- . ,guile:-)
+
+    ;; DERIVED
+    (caar . ,caar)
+    (cadr . ,cadr)
+    (cdar . ,cdar)
+    (cddr . ,cddr)
+    (caadr . ,caadr)
+    (caddr . ,caddr)
+    (cdadr . ,cdadr)
+    (cadar . ,cadar)
+    (cddar . ,cddar)
+    (cdddr . ,cdddr)
+
+    (append . ,append)
+    (exit . ,guile:exit)
+
+    (*macro* . ())
+
+    ;;
+    (stderr . ,stderr)))
+
+(define (mes-define-lambda x a)
+  (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))
+
+(define (mes-define x a)
+  (if (atom? (cadr x))
+      (cons (cadr x) (eval (caddr x) a))
+      (mes-define-lambda x a)))
+
+(define (mes-define-macro x a)
+  (cons '*macro*
+        (cons (mes-define-lambda x a)
+              (cdr (assq '*macro* a)))))
+
+(define (loop r e a)
+  (cond ((null? e) r)
+        ((eq? e 'exit)
+         (apply-env (cdr (assq 'loop a))
+                    (cons *unspecified* (cons #t (cons a '())))
+                    a))
+        ((atom? e) (loop (eval e a) (readenv a) a))
+        ((eq? (car e) 'define)
+         (loop *unspecified* (readenv a) (cons (mes-define e a) a)))
+        ((eq? (car e) 'define-macro)
+         (loop *unspecified* (readenv a) (cons (mes-define-macro e a) a)))
+        (#t (loop (eval e a) (readenv a) a))))
+
+(define (main arguments)
+  (let ((a (append environment `((*a* . ,environment)))))
+    ;;(guile:display (eval (readenv a) a))
+    (guile:display (loop *unspecified* (readenv a) a))
+    )
+  (guile:newline))
+
+(guile:module-define! (guile:resolve-interface '(mes)) 'main main)
diff --git a/hello.S b/hello.S
deleted file mode 100644 (file)
index 36c42e0..0000000
--- a/hello.S
+++ /dev/null
@@ -1,29 +0,0 @@
-
-.text                           # section declaration
-
-                                                 # we must export the entry point to the ELF linker or
-    .global _start              # loader. They conventionally recognize _start as their
-                                                 # entry point. Use ld -e foo to override the default.
-
-_start:
-
-                                # write our string to stdout
-
-         movl    $len,%edx           # third argument: message length
-         movl    $msg,%ecx           # second argument: pointer to message to write
-         movl    $1,%ebx             # first argument: file handle (stdout)
-         movl    $4,%eax             # system call number (sys_write)
-         int     $0x80               # call kernel
-
-                                # and exit
-
-         movl    $0,%ebx             # first argument: exit code
-         movl    $1,%eax             # system call number (sys_exit)
-         int     $0x80               # call kernel
-
-.data                           # section declaration
-
-msg:
-       .ascii    "Hello, world!\n"   # our dear string
-       len = . - msg                 # length of our dear string
diff --git a/hello.c b/hello.c
deleted file mode 100644 (file)
index 6eafe71..0000000
--- a/hello.c
+++ /dev/null
@@ -1,5 +0,0 @@
-int main ()
-{
-  puts ("HALLO\n");
-  return 0;
-}
diff --git a/let-syntax.mes b/let-syntax.mes
deleted file mode 100644 (file)
index cda9a70..0000000
+++ /dev/null
@@ -1,29 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; let-syntax.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-macro (let-syntax bindings . rest)
-  `((lambda ()
-      ,@(map (lambda (binding)
-               `(define-macro (,(car binding) . args)
-                  (,(cadr binding) (cons ',(car binding) args)
-                   (lambda (x0) x0)
-                   eq?)))
-             bindings)
-      ,@rest)))
diff --git a/let.mes b/let.mes
deleted file mode 100644 (file)
index d87b2be..0000000
--- a/let.mes
+++ /dev/null
@@ -1,76 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; let.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(define-macro (simple-let bindings . rest)
-  `(,`(lambda ,(map car bindings) ,@rest)
-    ,@(map cadr bindings)))
-
-(define-macro (named-let label bindings . rest)
-  `(simple-let ((,label *unspecified*))
-     (set! ,label (lambda ,(map car bindings) ,@rest))
-     (,label ,@(map cadr bindings))))
-
-(define-macro (let bindings-or-label . rest)
-  `(`,(if ,(symbol? bindings-or-label)
-          (list 'lambda '() (cons* 'named-let ,bindings-or-label ,(car rest) ,(cdr rest)))
-            (list 'lambda '() (cons* 'simple-let ,bindings-or-label ,rest)))))
-
-(define-macro (xsimple-let bindings rest)
-  `(,`(lambda ,(map car bindings) ,@rest)
-    ,@(map cadr bindings)))
-
-(define-macro (xnamed-let label bindings rest)
-  `(simple-let ((,label *unspecified*))
-     (set! ,label (lambda ,(map car bindings) ,@rest))
-     (,label ,@(map cadr bindings))))
-
-;; IF
-(define-macro (let bindings-or-label . rest)
-  `(if ,(symbol? bindings-or-label) ;; IF
-       (xnamed-let ,bindings-or-label ,(car rest) ,(cdr rest))
-       (xsimple-let ,bindings-or-label ,rest)))
-
-(define (expand-let* bindings body)
-  (if (null? bindings)
-      `((lambda () ,@body))
-      `((lambda (,(caar bindings))
-          ,(expand-let* (cdr bindings) body))
-        ,@(cdar bindings))))
-
-(define-macro (let* bindings . body)
-  (expand-let* bindings body))
-
-(define (unspecified-bindings bindings params)
-  (if (null? bindings) params
-      (unspecified-bindings
-       (cdr bindings)
-       (append params (cons (cons (caar bindings) '(*unspecified*)) '())))))
-
-(define (letrec-setters bindings setters)
-  (if (null? bindings) setters
-      (letrec-setters (cdr bindings)
-                      (append setters
-                              (cons (cons 'set! (car bindings)) '())))))
-
-(define-macro (letrec bindings . body)
-  `(let ,(unspecified-bindings bindings '())
-     ,@(letrec-setters bindings '())
-     ,@body))
-
diff --git a/lib/elf.mes b/lib/elf.mes
deleted file mode 100644 (file)
index 5ce0126..0000000
+++ /dev/null
@@ -1,209 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; scm.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(define (int->bv32 value)
-  (let ((bv (make-bytevector 4)))
-    (bytevector-u32-native-set! bv 0 value)
-    bv))
-
-(define (int->bv16 value)
-  (let ((bv (make-bytevector 2)))
-    (bytevector-u16-native-set! bv 0 value)
-    bv))
-
-(define elf32-addr int->bv32)
-(define elf32-half int->bv16)
-(define elf32-off int->bv32)
-(define elf32-word int->bv32)
-
-(define (make-elf text data)
- (define vaddress #x08048000)
-
- (define ei-magic `(#x7f ,@(string->list "ELF")))
- (define ei-class '(#x01)) ;; 32 bit
- (define ei-data '(#x01)) ;; little endian
- (define ei-version '(#x01))
- (define ei-osabi '(#x00))
- (define ei-pad '(#x0 #x0 #x0 #x0 #x0 #x0 #x0 #x0))
- (define e-ident
-   (append
-    ei-magic
-    ei-class
-    ei-data
-    ei-version
-    ei-osabi
-    ei-pad))
-
- (define ET-EXEC 2)
- (define EM-386 3)
- (define EV-CURRENT 1)
-
- (define p-filesz (elf32-word 0))
- (define p-memsz (elf32-word 0))
- (define PF-X 1)
- (define PF-W 2)
- (define PF-R 4)
- (define p-flags (elf32-word (logior PF-X PF-W PF-R)))
- (define p-align (elf32-word 1))
-
- (define (program-header type offset text)
-   (append
-    (elf32-word type)
-    (elf32-off offset)
-    (elf32-addr (+ vaddress offset))
-    (elf32-addr (+ vaddress offset))
-    (elf32-word (length text))
-    (elf32-word (length text))
-    p-flags
-    p-align
-    ))
-
- (define (section-header name type offset text)
-   (append
-    (elf32-word name)
-    (elf32-word type)
-    (elf32-word 3) ;; write/alloc must for data hmm
-    (elf32-addr (+ vaddress offset))
-    (elf32-off offset) 
-    (elf32-word (length text))
-    (elf32-word 0)
-    (elf32-word 0)
-    (elf32-word 1)
-    (elf32-word 0)))
-
-
- (define e-type (elf32-half ET-EXEC))
- (define e-machine (elf32-half EM-386))
- (define e-version (elf32-word EV-CURRENT))
- (define e-entry (elf32-addr 0))
- ;;(define e-entry (elf32-addr (+ vaddress text-offset)))
- ;;(define e-phoff (elf32-off 0))
- (define e-shoff (elf32-off 0))
- (define e-flags (elf32-word 0))
- ;;(define e-ehsize (elf32-half 0))
- (define e-phentsize (elf32-half (length (program-header 0 0 '()))))
- (define e-phnum (elf32-half 1))
- (define e-shentsize (elf32-half (length (section-header 0 0 0 '()))))
- (define e-shnum (elf32-half 5))
- (define e-shstrndx (elf32-half 4))
-
- (define (elf-header size entry sections)
-   (append
-    e-ident
-    e-type
-    e-machine
-    e-version
-    (elf32-addr (+ vaddress entry)) ;; e-entry
-    (elf32-off size) ;; e-phoff
-    (elf32-off sections) ;; e-shoff
-    e-flags
-    (elf32-half size) ;; e-ehsize
-    e-phentsize
-    e-phnum
-    e-shentsize
-    e-shnum
-    e-shstrndx
-    ))
-
- (define elf-header-size
-   (length (elf-header 0 0 0)))
-
- (define program-header-size
-   (length (program-header 0 0 '())))
-
- (define text-offset
-   (+ elf-header-size program-header-size))
-
- (define (program-headers)
-   (append
-    (program-header 1 text-offset (text 0))
-    ))
-
-
- (define note
-   (string->list
-    (string-append
-     "MES"
-     ;;"Mes -- Maxwell Equations of Software\n"
-     ;;"https://gitlab.com/janneke/mes"
-     )
-    ;; #x05 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x02 #x00 #x00 #x00
-    ;; #\i #\3 #\8 #\6 #x00 #x00 #x00 #x00
-    ))
-
- (define tab
-   `(
-     #x00 ,@(string->list ".shstrtab")
-          #x00 ,@(string->list ".text")
-          #x00 ,@(string->list ".data")
-          #x00 ,@(string->list ".note")
-          #x00 #x00 #x00 #x00
-          ))
-
- (define text-length
-   (length (text 0)))
-
- (define data-offset
-   (+ text-offset text-length))
-
- (define data-address (+ data-offset vaddress))
-
- (define data-length
-   (length data))
-
- (define note-length
-   (length note))
-
- (define note-offset
-   (+ data-offset data-length))
-
- (define tab-offset
-   (+ note-offset note-length))
-
- (define tab-length
-   (length tab))
-
- (define section-headers-offset
-   (+ tab-offset tab-length))
-
-
- (define SHT-PROGBITS 1)
- (define SHT-STRTAB 3)
- (define SHT-NOTE 7)
- (define (section-headers)
-   (append
-    (section-header 0 0 0 '())
-    (section-header 11 SHT-PROGBITS text-offset (text 0))
-    (section-header 17 SHT-PROGBITS data-offset data)
-    (section-header 23 SHT-NOTE note-offset note)
-    (section-header 1 SHT-STRTAB tab-offset tab)
-    ))
-
- (define exe
-   (append
-    (elf-header elf-header-size text-offset section-headers-offset)
-    (program-headers)
-    (text data-address)
-    data
-    note
-    tab
-    (section-headers)
-    ))
- exe)
diff --git a/lib/lalr.mes b/lib/lalr.mes
deleted file mode 100644 (file)
index 9e0d56b..0000000
+++ /dev/null
@@ -1,8 +0,0 @@
-
-(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)
diff --git a/lib/lalr.scm b/lib/lalr.scm
deleted file mode 100644 (file)
index 3a3b729..0000000
+++ /dev/null
@@ -1,2119 +0,0 @@
-;;;
-;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
-;;;
-;; Copyright 2014  Jan Nieuwenhuizen <janneke@gnu.org>
-;; Copyright 1993, 2010 Dominique Boucher
-;;
-;; This program 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 3 of
-;; the License, or (at your option) any later version.
-;;
-;; This program 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 General Public License
-;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
-
-
-(define *lalr-scm-version* "2.5.0")
-
-(cond-expand 
-
- ;; -- Gambit-C
- (gambit
-
-   (display "Gambit-C!")
-   (newline)
-   
-  (define-macro (def-macro form . body)
-    `(define-macro ,form (let () ,@body)))
-
-  (def-macro (BITS-PER-WORD) 28)
-  (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
-  (def-macro (lalr-error msg obj) `(error ,msg ,obj))
-
-  (define pprint pretty-print)
-  (define lalr-keyword? keyword?)
-  (define (note-source-location lvalue tok) lvalue))
- ;; -- 
- (bigloo
-  (define-macro (def-macro form . body)
-    `(define-macro ,form (let () ,@body)))
-
-  (define pprint (lambda (obj) (write obj) (newline)))
-  (define lalr-keyword? keyword?)
-  (def-macro (BITS-PER-WORD) 29)
-  (def-macro (logical-or x . y) `(bit-or ,x ,@y))
-  (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
-  (define (note-source-location lvalue tok) lvalue))
- ;; -- Chicken
- (chicken
-  
-  (define-macro (def-macro form . body)
-    `(define-macro ,form (let () ,@body)))
-
-  (define pprint pretty-print)
-  (define lalr-keyword? symbol?)
-  (def-macro (BITS-PER-WORD) 30)
-  (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
-  (def-macro (lalr-error msg obj) `(error ,msg ,obj))
-  (define (note-source-location lvalue tok) lvalue))
-
- ;; -- STKlos
- (stklos
-  (require "pp")
-
-  (define (pprint form) (pp form :port (current-output-port)))
-
-  (define lalr-keyword? keyword?)
-  (define-macro (BITS-PER-WORD) 30)
-  (define-macro (logical-or x . y) `(bit-or ,x ,@y))
-  (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj))
-  (define (note-source-location lvalue tok) lvalue))
-
- ;; -- Guile
- (guile
-  (use-modules (ice-9 pretty-print))
-  (use-modules (srfi srfi-9))
-
-  (define pprint pretty-print)
-  (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)
-    (if (and (supports-source-properties? lvalue)
-             (not (source-property lvalue 'loc))
-             (lexical-token? tok))
-        (set-source-property! lvalue 'loc (lexical-token-source tok)))
-    lvalue))
-
- ;; -- Mes
-  (mes
-   (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)
-  (define (BITS-PER-WORD) 30)
-  (define logical-or logior)
-  (define (lalr-keyword? obj) (keyword? obj))
-  (define (pprint obj) (pretty-print obj))
-  (define (lalr-error msg obj) (error msg obj))
-  (define (note-source-location lvalue tok) lvalue))
-
- ;; -- SISC
- (sisc
-  (import logicops)
-  (import record)
-       
-  (define pprint pretty-print)
-  (define lalr-keyword? symbol?)
-  (define-macro BITS-PER-WORD (lambda () 32))
-  (define-macro logical-or (lambda (x . y) `(logor ,x ,@y)))
-  (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj))
-  (define (note-source-location lvalue tok) lvalue))
-       
- ;; -- Gauche
- (gauche
-  (use gauche.record)
-  (define-macro (def-macro form . body)
-    `(define-macro ,form (let () ,@body)))
-  (define pprint (lambda (obj) (write obj) (newline)))
-  (define lalr-keyword? symbol?)
-  (def-macro (BITS-PER-WORD) 30)
-  (def-macro (logical-or x . y) `(logior ,x . ,y))
-  (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
-  (define (note-source-location lvalue tok) lvalue))
-
- (else
-  (error "Unsupported Scheme system")))
-
-
-(define-record-type lexical-token
-  (make-lexical-token category source value)
-  lexical-token?
-  (category lexical-token-category)
-  (source   lexical-token-source)
-  (value    lexical-token-value))
-
-
-(define-record-type source-location
-  (make-source-location input line column offset length)
-  source-location?
-  (input   source-location-input)
-  (line    source-location-line)
-  (column  source-location-column)
-  (offset  source-location-offset)
-  (length  source-location-length))
-
-
-
-      ;; - Macros pour la gestion des vecteurs de bits
-
-(define-macro (lalr-parser . arguments)
-  (define (set-bit v b)
-    (let ((x (quotient b (BITS-PER-WORD)))
-         (y (expt 2 (remainder b (BITS-PER-WORD)))))
-      (vector-set! v x (logical-or (vector-ref v x) y))))
-
-  (define (bit-union v1 v2 n)
-    (do ((i 0 (+ i 1)))
-       ((= i n))
-      (vector-set! v1 i (logical-or (vector-ref v1 i)
-                                   (vector-ref v2 i)))))
-
-  ;; - Macro pour les structures de donnees
-
-  (define (new-core)              (make-vector 4 0))
-  (define (set-core-number! c n)  (vector-set! c 0 n))
-  (define (set-core-acc-sym! c s) (vector-set! c 1 s))
-  (define (set-core-nitems! c n)  (vector-set! c 2 n))
-  (define (set-core-items! c i)   (vector-set! c 3 i))
-  (define (core-number c)         (vector-ref c 0))
-  (define (core-acc-sym c)        (vector-ref c 1))
-  (define (core-nitems c)         (vector-ref c 2))
-  (define (core-items c)          (vector-ref c 3))
-
-  (define (new-shift)              (make-vector 3 0))
-  (define (set-shift-number! c x)  (vector-set! c 0 x))
-  (define (set-shift-nshifts! c x) (vector-set! c 1 x))
-  (define (set-shift-shifts! c x)  (vector-set! c 2 x))
-  (define (shift-number s)         (vector-ref s 0))
-  (define (shift-nshifts s)        (vector-ref s 1))
-  (define (shift-shifts s)         (vector-ref s 2))
-
-  (define (new-red)                (make-vector 3 0))
-  (define (set-red-number! c x)    (vector-set! c 0 x))
-  (define (set-red-nreds! c x)     (vector-set! c 1 x))
-  (define (set-red-rules! c x)     (vector-set! c 2 x))
-  (define (red-number c)           (vector-ref c 0))
-  (define (red-nreds c)            (vector-ref c 1))
-  (define (red-rules c)            (vector-ref c 2))
-
-
-  (define (new-set nelem)
-    (make-vector nelem 0))
-
-
-  (define (vector-map f v)
-    (let ((vm-n (- (vector-length v) 1)))
-      (let loop ((vm-low 0) (vm-high vm-n))
-       (if (= vm-low vm-high)
-           (vector-set! v vm-low (f (vector-ref v vm-low) vm-low))
-           (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
-             (loop vm-low vm-middle)
-             (loop (+ vm-middle 1) vm-high))))))
-
-
-  ;; - Constantes
-  (define STATE-TABLE-SIZE 1009)
-
-
-  ;; - Tableaux 
-  (define rrhs         #f)
-  (define rlhs         #f)
-  (define ritem        #f)
-  (define nullable     #f)
-  (define derives      #f)
-  (define fderives     #f)
-  (define firsts       #f)
-  (define kernel-base  #f)
-  (define kernel-end   #f)
-  (define shift-symbol #f)
-  (define shift-set    #f)
-  (define red-set      #f)
-  (define state-table  #f)
-  (define acces-symbol #f)
-  (define reduction-table #f)
-  (define shift-table  #f)
-  (define consistent   #f)
-  (define lookaheads   #f)
-  (define LA           #f)
-  (define LAruleno     #f)
-  (define lookback     #f)
-  (define goto-map     #f)
-  (define from-state   #f)
-  (define to-state     #f)
-  (define includes     #f)
-  (define F            #f)
-  (define action-table #f)
-
-  ;; - Variables
-  (define nitems          #f)
-  (define nrules          #f)
-  (define nvars           #f)
-  (define nterms          #f)
-  (define nsyms           #f)
-  (define nstates         #f)
-  (define first-state     #f)
-  (define last-state      #f)
-  (define final-state     #f)
-  (define first-shift     #f)
-  (define last-shift      #f)
-  (define first-reduction #f)
-  (define last-reduction  #f)
-  (define nshifts         #f)
-  (define maxrhs          #f)
-  (define ngotos          #f)
-  (define token-set-size  #f)
-
-  (define driver-name     'lr-driver)
-
-  (define (glr-driver?)
-    (eq? driver-name 'glr-driver))
-  (define (lr-driver?)
-    (eq? driver-name 'lr-driver))
-
-  (define (gen-tables! tokens gram )
-    (initialize-all)
-    (rewrite-grammar
-     tokens
-     gram
-     (lambda (terms terms/prec vars gram gram/actions)
-       (set! the-terminals/prec (list->vector terms/prec))
-       (set! the-terminals (list->vector terms))
-       (set! the-nonterminals (list->vector vars))
-       (set! nterms (length terms))
-       (set! nvars  (length vars))
-       (set! nsyms  (+ nterms nvars))
-       (let ((no-of-rules (length gram/actions))
-            (no-of-items (let loop ((l gram/actions) (count 0))
-                           (if (null? l)
-                               count
-                               (loop (cdr l) (+ count (length (caar l))))))))
-        (pack-grammar no-of-rules no-of-items gram)
-        (set-derives)
-        (set-nullable)
-        (generate-states)
-        (lalr)
-        (build-tables)
-        (compact-action-table terms)
-        gram/actions))))
-
-
-  (define (initialize-all)
-    (set! rrhs         #f)
-    (set! rlhs         #f)
-    (set! ritem        #f)
-    (set! nullable     #f)
-    (set! derives      #f)
-    (set! fderives     #f)
-    (set! firsts       #f)
-    (set! kernel-base  #f)
-    (set! kernel-end   #f)
-    (set! shift-symbol #f)
-    (set! shift-set    #f)
-    (set! red-set      #f)
-    (set! state-table  (make-vector STATE-TABLE-SIZE '()))
-    (set! acces-symbol #f)
-    (set! reduction-table #f)
-    (set! shift-table  #f)
-    (set! consistent   #f)
-    (set! lookaheads   #f)
-    (set! LA           #f)
-    (set! LAruleno     #f)
-    (set! lookback     #f)
-    (set! goto-map     #f)
-    (set! from-state   #f)
-    (set! to-state     #f)
-    (set! includes     #f)
-    (set! F            #f)
-    (set! action-table #f)
-    (set! nstates         #f)
-    (set! first-state     #f)
-    (set! last-state      #f)
-    (set! final-state     #f)
-    (set! first-shift     #f)
-    (set! last-shift      #f)
-    (set! first-reduction #f)
-    (set! last-reduction  #f)
-    (set! nshifts         #f)
-    (set! maxrhs          #f)
-    (set! ngotos          #f)
-    (set! token-set-size  #f)
-    (set! rule-precedences '()))
-
-
-  (define (pack-grammar no-of-rules no-of-items gram)
-    (set! nrules (+  no-of-rules 1))
-    (set! nitems no-of-items)
-    (set! rlhs (make-vector nrules #f))
-    (set! rrhs (make-vector nrules #f))
-    (set! ritem (make-vector (+ 1 nitems) #f))
-
-    (let loop ((p gram) (item-no 0) (rule-no 1))
-      (if (not (null? p))
-         (let ((nt (caar p)))
-           (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
-             (if (null? prods)
-                 (loop (cdr p) it-no2 rl-no2)
-                 (begin
-                   (vector-set! rlhs rl-no2 nt)
-                   (vector-set! rrhs rl-no2 it-no2)
-                   (let loop3 ((rhs (car prods)) (it-no3 it-no2))
-                     (if (null? rhs)
-                         (begin
-                           (vector-set! ritem it-no3 (- rl-no2))
-                           (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
-                         (begin
-                           (vector-set! ritem it-no3 (car rhs))
-                           (loop3 (cdr rhs) (+ it-no3 1))))))))))))
-
-
-  (define (set-derives)
-    (define delts (make-vector (+ nrules 1) 0))
-    (define dset  (make-vector nvars -1))
-
-    (let loop ((i 1) (j 0))            ; i = 0
-      (if (< i nrules)
-         (let ((lhs (vector-ref rlhs i)))
-           (if (>= lhs 0)
-               (begin
-                 (vector-set! delts j (cons i (vector-ref dset lhs)))
-                 (vector-set! dset lhs j)
-                 (loop (+ i 1) (+ j 1)))
-               (loop (+ i 1) j)))))
-
-    (set! derives (make-vector nvars 0))
-
-    (let loop ((i 0))
-      (if (< i nvars)
-         (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
-                    (if (< j 0)
-                        s
-                        (let ((x (vector-ref delts j)))
-                          (loop2 (cdr x) (cons (car x) s)))))))
-           (vector-set! derives i q)
-           (loop (+ i 1))))))
-
-
-
-  (define (set-nullable)
-    (set! nullable (make-vector nvars #f))
-    (let ((squeue (make-vector nvars #f))
-         (rcount (make-vector (+ nrules 1) 0))
-         (rsets  (make-vector nvars #f))
-         (relts  (make-vector (+ nitems nvars 1) #f)))
-      (let loop ((r 0) (s2 0) (p 0))
-       (let ((*r (vector-ref ritem r)))
-         (if *r
-             (if (< *r 0)
-                 (let ((symbol (vector-ref rlhs (- *r))))
-                   (if (and (>= symbol 0)
-                            (not (vector-ref nullable symbol)))
-                       (begin
-                         (vector-set! nullable symbol #t)
-                         (vector-set! squeue s2 symbol)
-                         (loop (+ r 1) (+ s2 1) p))))
-                 (let loop2 ((r1 r) (any-tokens #f))
-                   (let* ((symbol (vector-ref ritem r1)))
-                     (if (> symbol 0)
-                         (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
-                         (if (not any-tokens)
-                             (let ((ruleno (- symbol)))
-                               (let loop3 ((r2 r) (p2 p))
-                                 (let ((symbol (vector-ref ritem r2)))
-                                   (if (> symbol 0)
-                                       (begin
-                                         (vector-set! rcount ruleno
-                                                      (+ (vector-ref rcount ruleno) 1))
-                                         (vector-set! relts p2
-                                                      (cons (vector-ref rsets symbol)
-                                                            ruleno))
-                                         (vector-set! rsets symbol p2)
-                                         (loop3 (+ r2 1) (+ p2 1)))
-                                       (loop (+ r2 1) s2 p2)))))
-                             (loop (+ r1 1) s2 p))))))
-             (let loop ((s1 0) (s3 s2))
-               (if (< s1 s3)
-                   (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
-                     (if p
-                         (let* ((x (vector-ref relts p))
-                                (ruleno (cdr x))
-                                (y (- (vector-ref rcount ruleno) 1)))
-                           (vector-set! rcount ruleno y)
-                           (if (= y 0)
-                               (let ((symbol (vector-ref rlhs ruleno)))
-                                 (if (and (>= symbol 0)
-                                          (not (vector-ref nullable symbol)))
-                                     (begin
-                                       (vector-set! nullable symbol #t)
-                                       (vector-set! squeue s4 symbol)
-                                       (loop2 (car x) (+ s4 1)))
-                                     (loop2 (car x) s4)))
-                               (loop2 (car x) s4))))
-                     (loop (+ s1 1) s4)))))))))
-
-
-
-  (define (set-firsts)
-    (set! firsts (make-vector nvars '()))
-
-    ;; -- initialization
-    (let loop ((i 0))
-      (if (< i nvars)
-         (let loop2 ((sp (vector-ref derives i)))
-           (if (null? sp)
-               (loop (+ i 1))
-               (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
-                 (if (< -1 sym nvars)
-                     (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
-                 (loop2 (cdr sp)))))))
-
-    ;; -- reflexive and transitive closure
-    (let loop ((continue #t))
-      (if continue
-         (let loop2 ((i 0) (cont #f))
-           (if (>= i nvars)
-               (loop cont)
-               (let* ((x (vector-ref firsts i))
-                      (y (let loop3 ((l x) (z x))
-                           (if (null? l)
-                               z
-                               (loop3 (cdr l)
-                                      (sunion (vector-ref firsts (car l)) z))))))
-                 (if (equal? x y)
-                     (loop2 (+ i 1) cont)
-                     (begin
-                       (vector-set! firsts i y)
-                       (loop2 (+ i 1) #t))))))))
-
-    (let loop ((i 0))
-      (if (< i nvars)
-         (begin
-           (vector-set! firsts i (sinsert i (vector-ref firsts i)))
-           (loop (+ i 1))))))
-
-
-
-
-  (define (set-fderives)
-    (set! fderives (make-vector nvars #f))
-
-    (set-firsts)
-
-    (let loop ((i 0))
-      (if (< i nvars)
-         (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
-                    (if (null? l)
-                        fd
-                        (loop2 (cdr l)
-                               (sunion (vector-ref derives (car l)) fd))))))
-           (vector-set! fderives i x)
-           (loop (+ i 1))))))
-
-
-  (define (closure core)
-    ;; Initialization
-    (define ruleset (make-vector nrules #f))
-
-    (let loop ((csp core))
-      (if (not (null? csp))
-         (let ((sym (vector-ref ritem (car csp))))
-           (if (< -1 sym nvars)
-               (let loop2 ((dsp (vector-ref fderives sym)))
-                 (if (not (null? dsp))
-                     (begin
-                       (vector-set! ruleset (car dsp) #t)
-                       (loop2 (cdr dsp))))))
-           (loop (cdr csp)))))
-
-    (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
-      (if (< ruleno nrules)
-         (if (vector-ref ruleset ruleno)
-             (let ((itemno (vector-ref rrhs ruleno)))
-               (let loop2 ((c csp) (itemsetv2 itemsetv))
-                 (if (and (pair? c)
-                          (< (car c) itemno))
-                     (loop2 (cdr c) (cons (car c) itemsetv2))
-                     (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
-             (loop (+ ruleno 1) csp itemsetv))
-         (let loop2 ((c csp) (itemsetv2 itemsetv))
-           (if (pair? c)
-               (loop2 (cdr c) (cons (car c) itemsetv2))
-               (reverse itemsetv2))))))
-
-
-
-  (define (allocate-item-sets)
-    (set! kernel-base (make-vector nsyms 0))
-    (set! kernel-end  (make-vector nsyms #f)))
-
-
-  (define (allocate-storage)
-    (allocate-item-sets)
-    (set! red-set (make-vector (+ nrules 1) 0)))
-
-                                       ; --
-
-
-  (define (initialize-states)
-    (let ((p (new-core)))
-      (set-core-number! p 0)
-      (set-core-acc-sym! p #f)
-      (set-core-nitems! p 1)
-      (set-core-items! p '(0))
-
-      (set! first-state (list p))
-      (set! last-state first-state)
-      (set! nstates 1)))
-
-
-
-  (define (generate-states)
-    (allocate-storage)
-    (set-fderives)
-    (initialize-states)
-    (let loop ((this-state first-state))
-      (if (pair? this-state)
-         (let* ((x (car this-state))
-                (is (closure (core-items x))))
-           (save-reductions x is)
-           (new-itemsets is)
-           (append-states)
-           (if (> nshifts 0)
-               (save-shifts x))
-           (loop (cdr this-state))))))
-
-
-  (define (new-itemsets itemset)
-    ;; - Initialization
-    (set! shift-symbol '())
-    (let loop ((i 0))
-      (if (< i nsyms)
-         (begin
-           (vector-set! kernel-end i '())
-           (loop (+ i 1)))))
-
-    (let loop ((isp itemset))
-      (if (pair? isp)
-         (let* ((i (car isp))
-                (sym (vector-ref ritem i)))
-           (if (>= sym 0)
-               (begin
-                 (set! shift-symbol (sinsert sym shift-symbol))
-                 (let ((x (vector-ref kernel-end sym)))
-                   (if (null? x)
-                       (begin
-                         (vector-set! kernel-base sym (cons (+ i 1) x))
-                         (vector-set! kernel-end sym (vector-ref kernel-base sym)))
-                       (begin
-                         (set-cdr! x (list (+ i 1)))
-                         (vector-set! kernel-end sym (cdr x)))))))
-           (loop (cdr isp)))))
-
-    (set! nshifts (length shift-symbol)))
-
-
-
-  (define (get-state sym)
-    (let* ((isp  (vector-ref kernel-base sym))
-          (n    (length isp))
-          (key  (let loop ((isp1 isp) (k 0))
-                  (if (null? isp1)
-                      (modulo k STATE-TABLE-SIZE)
-                      (loop (cdr isp1) (+ k (car isp1))))))
-          (sp   (vector-ref state-table key)))
-      (if (null? sp)
-         (let ((x (new-state sym)))
-           (vector-set! state-table key (list x))
-           (core-number x))
-         (let loop ((sp1 sp))
-           (if (and (= n (core-nitems (car sp1)))
-                    (let loop2 ((i1 isp) (t (core-items (car sp1))))
-                      (if (and (pair? i1)
-                               (= (car i1)
-                                  (car t)))
-                          (loop2 (cdr i1) (cdr t))
-                          (null? i1))))
-               (core-number (car sp1))
-               (if (null? (cdr sp1))
-                   (let ((x (new-state sym)))
-                     (set-cdr! sp1 (list x))
-                     (core-number x))
-                   (loop (cdr sp1))))))))
-
-
-  (define (new-state sym)
-    (let* ((isp  (vector-ref kernel-base sym))
-          (n    (length isp))
-          (p    (new-core)))
-      (set-core-number! p nstates)
-      (set-core-acc-sym! p sym)
-      (if (= sym nvars) (set! final-state nstates))
-      (set-core-nitems! p n)
-      (set-core-items! p isp)
-      (set-cdr! last-state (list p))
-      (set! last-state (cdr last-state))
-      (set! nstates (+ nstates 1))
-      p))
-
-
-                                       ; --
-
-  (define (append-states)
-    (set! shift-set
-         (let loop ((l (reverse shift-symbol)))
-           (if (null? l)
-               '()
-               (cons (get-state (car l)) (loop (cdr l)))))))
-
-                                       ; --
-
-  (define (save-shifts core)
-    (let ((p (new-shift)))
-      (set-shift-number! p (core-number core))
-      (set-shift-nshifts! p nshifts)
-      (set-shift-shifts! p shift-set)
-      (if last-shift
-         (begin
-           (set-cdr! last-shift (list p))
-           (set! last-shift (cdr last-shift)))
-         (begin
-           (set! first-shift (list p))
-           (set! last-shift first-shift)))))
-
-  (define (save-reductions core itemset)
-    (let ((rs (let loop ((l itemset))
-               (if (null? l)
-                   '()
-                   (let ((item (vector-ref ritem (car l))))
-                     (if (< item 0)
-                         (cons (- item) (loop (cdr l)))
-                         (loop (cdr l))))))))
-      (if (pair? rs)
-         (let ((p (new-red)))
-           (set-red-number! p (core-number core))
-           (set-red-nreds!  p (length rs))
-           (set-red-rules!  p rs)
-           (if last-reduction
-               (begin
-                 (set-cdr! last-reduction (list p))
-                 (set! last-reduction (cdr last-reduction)))
-               (begin
-                 (set! first-reduction (list p))
-                 (set! last-reduction first-reduction)))))))
-
-
-                                       ; --
-
-  (define (lalr)
-    (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
-    (set-accessing-symbol)
-    (set-shift-table)
-    (set-reduction-table)
-    (set-max-rhs)
-    (initialize-LA)
-    (set-goto-map)
-    (initialize-F)
-    (build-relations)
-    (digraph includes)
-    (compute-lookaheads))
-
-  (define (set-accessing-symbol)
-    (set! acces-symbol (make-vector nstates #f))
-    (let loop ((l first-state))
-      (if (pair? l)
-         (let ((x (car l)))
-           (vector-set! acces-symbol (core-number x) (core-acc-sym x))
-           (loop (cdr l))))))
-
-  (define (set-shift-table)
-    (set! shift-table (make-vector nstates #f))
-    (let loop ((l first-shift))
-      (if (pair? l)
-         (let ((x (car l)))
-           (vector-set! shift-table (shift-number x) x)
-           (loop (cdr l))))))
-
-  (define (set-reduction-table)
-    (set! reduction-table (make-vector nstates #f))
-    (let loop ((l first-reduction))
-      (if (pair? l)
-         (let ((x (car l)))
-           (vector-set! reduction-table (red-number x) x)
-           (loop (cdr l))))))
-
-  (define (set-max-rhs)
-    (let loop ((p 0) (curmax 0) (length 0))
-      (let ((x (vector-ref ritem p)))
-       (if x
-           (if (>= x 0)
-               (loop (+ p 1) curmax (+ length 1))
-               (loop (+ p 1) (max curmax length) 0))
-           (set! maxrhs curmax)))))
-
-  (define (initialize-LA)
-    (define (last l)
-      (if (null? (cdr l))
-         (car l)
-         (last (cdr l))))
-
-    (set! consistent (make-vector nstates #f))
-    (set! lookaheads (make-vector (+ nstates 1) #f))
-
-    (let loop ((count 0) (i 0))
-      (if (< i nstates)
-         (begin
-           (vector-set! lookaheads i count)
-           (let ((rp (vector-ref reduction-table i))
-                 (sp (vector-ref shift-table i)))
-             (if (and rp
-                      (or (> (red-nreds rp) 1)
-                          (and sp
-                               (not
-                                (< (vector-ref acces-symbol
-                                               (last (shift-shifts sp)))
-                                   nvars)))))
-                 (loop (+ count (red-nreds rp)) (+ i 1))
-                 (begin
-                   (vector-set! consistent i #t)
-                   (loop count (+ i 1))))))
-
-         (begin
-           (vector-set! lookaheads nstates count)
-           (let ((c (max count 1)))
-             (set! LA (make-vector c #f))
-             (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
-             (set! LAruleno (make-vector c -1))
-             (set! lookback (make-vector c #f)))
-           (let loop ((i 0) (np 0))
-             (if (< i nstates)
-                 (if (vector-ref consistent i)
-                     (loop (+ i 1) np)
-                     (let ((rp (vector-ref reduction-table i)))
-                       (if rp
-                           (let loop2 ((j (red-rules rp)) (np2 np))
-                             (if (null? j)
-                                 (loop (+ i 1) np2)
-                                 (begin
-                                   (vector-set! LAruleno np2 (car j))
-                                   (loop2 (cdr j) (+ np2 1)))))
-                           (loop (+ i 1) np))))))))))
-
-
-  (define (set-goto-map)
-    (set! goto-map (make-vector (+ nvars 1) 0))
-    (let ((temp-map (make-vector (+ nvars 1) 0)))
-      (let loop ((ng 0) (sp first-shift))
-       (if (pair? sp)
-           (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
-             (if (pair? i)
-                 (let ((symbol (vector-ref acces-symbol (car i))))
-                   (if (< symbol nvars)
-                       (begin
-                         (vector-set! goto-map symbol
-                                      (+ 1 (vector-ref goto-map symbol)))
-                         (loop2 (cdr i) (+ ng2 1)))
-                       (loop2 (cdr i) ng2)))
-                 (loop ng2 (cdr sp))))
-
-           (let loop ((k 0) (i 0))
-             (if (< i nvars)
-                 (begin
-                   (vector-set! temp-map i k)
-                   (loop (+ k (vector-ref goto-map i)) (+ i 1)))
-
-                 (begin
-                   (do ((i 0 (+ i 1)))
-                       ((>= i nvars))
-                     (vector-set! goto-map i (vector-ref temp-map i)))
-
-                   (set! ngotos ng)
-                   (vector-set! goto-map nvars ngotos)
-                   (vector-set! temp-map nvars ngotos)
-                   (set! from-state (make-vector ngotos #f))
-                   (set! to-state (make-vector ngotos #f))
-
-                   (do ((sp first-shift (cdr sp)))
-                       ((null? sp))
-                     (let* ((x (car sp))
-                            (state1 (shift-number x)))
-                       (do ((i (shift-shifts x) (cdr i)))
-                           ((null? i))
-                         (let* ((state2 (car i))
-                                (symbol (vector-ref acces-symbol state2)))
-                           (if (< symbol nvars)
-                               (let ((k (vector-ref temp-map symbol)))
-                                 (vector-set! temp-map symbol (+ k 1))
-                                 (vector-set! from-state k state1)
-                                 (vector-set! to-state k state2))))))))))))))
-
-
-  (define (map-goto state symbol)
-    (let loop ((low (vector-ref goto-map symbol))
-              (high (- (vector-ref goto-map (+ symbol 1)) 1)))
-      (if (> low high)
-         (begin
-           (display (list "Error in map-goto" state symbol)) (newline)
-           0)
-         (let* ((middle (quotient (+ low high) 2))
-                (s (vector-ref from-state middle)))
-           (cond
-            ((= s state)
-             middle)
-            ((< s state)
-             (loop (+ middle 1) high))
-            (else
-             (loop low (- middle 1))))))))
-
-
-  (define (initialize-F)
-    (set! F (make-vector ngotos #f))
-    (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
-
-    (let ((reads (make-vector ngotos #f)))
-
-      (let loop ((i 0) (rowp 0))
-       (if (< i ngotos)
-           (let* ((rowf (vector-ref F rowp))
-                  (stateno (vector-ref to-state i))
-                  (sp (vector-ref shift-table stateno)))
-             (if sp
-                 (let loop2 ((j (shift-shifts sp)) (edges '()))
-                   (if (pair? j)
-                       (let ((symbol (vector-ref acces-symbol (car j))))
-                         (if (< symbol nvars)
-                             (if (vector-ref nullable symbol)
-                                 (loop2 (cdr j) (cons (map-goto stateno symbol)
-                                                      edges))
-                                 (loop2 (cdr j) edges))
-                             (begin
-                               (set-bit rowf (- symbol nvars))
-                               (loop2 (cdr j) edges))))
-                       (if (pair? edges)
-                           (vector-set! reads i (reverse edges))))))
-             (loop (+ i 1) (+ rowp 1)))))
-      (digraph reads)))
-
-  (define (add-lookback-edge stateno ruleno gotono)
-    (let ((k (vector-ref lookaheads (+ stateno 1))))
-      (let loop ((found #f) (i (vector-ref lookaheads stateno)))
-       (if (and (not found) (< i k))
-           (if (= (vector-ref LAruleno i) ruleno)
-               (loop #t i)
-               (loop found (+ i 1)))
-
-           (if (not found)
-               (begin (display "Error in add-lookback-edge : ")
-                      (display (list stateno ruleno gotono)) (newline))
-               (vector-set! lookback i
-                            (cons gotono (vector-ref lookback i))))))))
-
-
-  (define (transpose r-arg n)
-    (let ((new-end (make-vector n #f))
-         (new-R  (make-vector n #f)))
-      (do ((i 0 (+ i 1)))
-         ((= i n))
-       (let ((x (list 'bidon)))
-         (vector-set! new-R i x)
-         (vector-set! new-end i x)))
-      (do ((i 0 (+ i 1)))
-         ((= i n))
-       (let ((sp (vector-ref r-arg i)))
-         (if (pair? sp)
-             (let loop ((sp2 sp))
-               (if (pair? sp2)
-                   (let* ((x (car sp2))
-                          (y (vector-ref new-end x)))
-                     (set-cdr! y (cons i (cdr y)))
-                     (vector-set! new-end x (cdr y))
-                     (loop (cdr sp2))))))))
-      (do ((i 0 (+ i 1)))
-         ((= i n))
-       (vector-set! new-R i (cdr (vector-ref new-R i))))
-
-      new-R))
-
-
-
-  (define (build-relations)
-
-    (define (get-state stateno symbol)
-      (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
-                (stno stateno))
-       (if (null? j)
-           stno
-           (let ((st2 (car j)))
-             (if (= (vector-ref acces-symbol st2) symbol)
-                 st2
-                 (loop (cdr j) st2))))))
-
-    (set! includes (make-vector ngotos #f))
-    (do ((i 0 (+ i 1)))
-       ((= i ngotos))
-      (let ((state1 (vector-ref from-state i))
-           (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
-       (let loop ((rulep (vector-ref derives symbol1))
-                  (edges '()))
-         (if (pair? rulep)
-             (let ((*rulep (car rulep)))
-               (let loop2 ((rp (vector-ref rrhs *rulep))
-                           (stateno state1)
-                           (states (list state1)))
-                 (let ((*rp (vector-ref ritem rp)))
-                   (if (> *rp 0)
-                       (let ((st (get-state stateno *rp)))
-                         (loop2 (+ rp 1) st (cons st states)))
-                       (begin
-
-                         (if (not (vector-ref consistent stateno))
-                             (add-lookback-edge stateno *rulep i))
-
-                         (let loop2 ((done #f)
-                                     (stp (cdr states))
-                                     (rp2 (- rp 1))
-                                     (edgp edges))
-                           (if (not done)
-                               (let ((*rp (vector-ref ritem rp2)))
-                                 (if (< -1 *rp nvars)
-                                     (loop2 (not (vector-ref nullable *rp))
-                                            (cdr stp)
-                                            (- rp2 1)
-                                            (cons (map-goto (car stp) *rp) edgp))
-                                     (loop2 #t stp rp2 edgp)))
-
-                               (loop (cdr rulep) edgp))))))))
-             (vector-set! includes i edges)))))
-    (set! includes (transpose includes ngotos)))
-
-
-
-  (define (compute-lookaheads)
-    (let ((n (vector-ref lookaheads nstates)))
-      (let loop ((i 0))
-       (if (< i n)
-           (let loop2 ((sp (vector-ref lookback i)))
-             (if (pair? sp)
-                 (let ((LA-i (vector-ref LA i))
-                       (F-j  (vector-ref F (car sp))))
-                   (bit-union LA-i F-j token-set-size)
-                   (loop2 (cdr sp)))
-                 (loop (+ i 1))))))))
-
-
-
-  (define (digraph relation)
-    (define infinity (+ ngotos 2))
-    (define INDEX (make-vector (+ ngotos 1) 0))
-    (define VERTICES (make-vector (+ ngotos 1) 0))
-    (define top 0)
-    (define R relation)
-
-    (define (traverse i)
-      (set! top (+ 1 top))
-      (vector-set! VERTICES top i)
-      (let ((height top))
-       (vector-set! INDEX i height)
-       (let ((rp (vector-ref R i)))
-         (if (pair? rp)
-             (let loop ((rp2 rp))
-               (if (pair? rp2)
-                   (let ((j (car rp2)))
-                     (if (= 0 (vector-ref INDEX j))
-                         (traverse j))
-                     (if (> (vector-ref INDEX i)
-                            (vector-ref INDEX j))
-                         (vector-set! INDEX i (vector-ref INDEX j)))
-                     (let ((F-i (vector-ref F i))
-                           (F-j (vector-ref F j)))
-                       (bit-union F-i F-j token-set-size))
-                     (loop (cdr rp2))))))
-         (if (= (vector-ref INDEX i) height)
-             (let loop ()
-               (let ((j (vector-ref VERTICES top)))
-                 (set! top (- top 1))
-                 (vector-set! INDEX j infinity)
-                 (if (not (= i j))
-                     (begin
-                       (bit-union (vector-ref F i)
-                                  (vector-ref F j)
-                                  token-set-size)
-                       (loop)))))))))
-
-    (let loop ((i 0))
-      (if (< i ngotos)
-         (begin
-           (if (and (= 0 (vector-ref INDEX i))
-                    (pair? (vector-ref R i)))
-               (traverse i))
-           (loop (+ i 1))))))
-
-
-  ;; ----------------------------------------------------------------------
-  ;; operator precedence management
-  ;; ----------------------------------------------------------------------
-      
-  ;; a vector of precedence descriptors where each element
-  ;; is of the form (terminal type precedence)
-  (define the-terminals/prec #f)   ; terminal symbols with precedence 
-                                       ; the precedence is an integer >= 0
-  (define (get-symbol-precedence sym)
-    (caddr (vector-ref the-terminals/prec sym)))
-                                       ; the operator type is either 'none, 'left, 'right, or 'nonassoc
-  (define (get-symbol-assoc sym)
-    (cadr (vector-ref the-terminals/prec sym)))
-
-  (define rule-precedences '())
-  (define (add-rule-precedence! rule sym)
-    (set! rule-precedences
-         (cons (cons rule sym) rule-precedences)))
-
-  (define (get-rule-precedence ruleno)
-    (cond
-     ((assq ruleno rule-precedences)
-      => (lambda (p)
-          (get-symbol-precedence (cdr p))))
-     (else
-      ;; process the rule symbols from left to right
-      (let loop ((i    (vector-ref rrhs ruleno))
-                (prec 0))
-       (let ((item (vector-ref ritem i)))
-         ;; end of rule
-         (if (< item 0)
-             prec
-             (let ((i1 (+ i 1)))
-               (if (>= item nvars)
-                   ;; it's a terminal symbol
-                   (loop i1 (get-symbol-precedence (- item nvars)))
-                   (loop i1 prec)))))))))
-
-  ;; ----------------------------------------------------------------------
-  ;; Build the various tables
-  ;; ----------------------------------------------------------------------
-
-  (define expected-conflicts 0)
-
-  (define (build-tables)
-
-    (define (resolve-conflict sym rule)
-      (let ((sym-prec   (get-symbol-precedence sym))
-           (sym-assoc  (get-symbol-assoc sym))
-           (rule-prec  (get-rule-precedence rule)))
-       (cond
-        ((> sym-prec rule-prec)     'shift)
-        ((< sym-prec rule-prec)     'reduce)
-        ((eq? sym-assoc 'left)      'reduce)
-        ((eq? sym-assoc 'right)     'shift)
-        (else                       'none))))
-
-    (define conflict-messages '())
-
-    (define (add-conflict-message . l)
-      (set! conflict-messages (cons l conflict-messages)))
-
-    (define (log-conflicts)
-      (if (> (length conflict-messages) expected-conflicts)
-         (for-each
-          (lambda (message)
-            (for-each display message)
-            (newline))
-          conflict-messages)))
-
-    ;; --- Add an action to the action table
-    (define (add-action state symbol new-action)
-      (let* ((state-actions (vector-ref action-table state))
-            (actions       (assv symbol state-actions)))
-       (if (pair? actions)
-           (let ((current-action (cadr actions)))
-             (if (not (= new-action current-action))
-                 ;; -- there is a conflict 
-                 (begin
-                   (if (and (<= current-action 0) (<= new-action 0))
-                       ;; --- reduce/reduce conflict
-                       (begin
-                         (add-conflict-message
-                          "%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action) 
-                          ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
-                         (if (glr-driver?)
-                             (set-cdr! (cdr actions) (cons new-action (cddr actions)))
-                             (set-car! (cdr actions) (max current-action new-action))))
-                       ;; --- shift/reduce conflict
-                       ;; can we resolve the conflict using precedences?
-                       (case (resolve-conflict symbol (- current-action))
-                         ;; -- shift
-                         ((shift)   (if (glr-driver?)
-                                        (set-cdr! (cdr actions) (cons new-action (cddr actions)))
-                                        (set-car! (cdr actions) new-action)))
-                         ;; -- reduce
-                         ((reduce)  #f) ; well, nothing to do...
-                         ;; -- signal a conflict!
-                         (else      (add-conflict-message
-                                     "%% Shift/Reduce conflict (shift " new-action ", reduce " (- current-action)
-                                     ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
-                                    (if (glr-driver?)
-                                        (set-cdr! (cdr actions) (cons new-action (cddr actions)))
-                                        (set-car! (cdr actions) new-action))))))))
-          
-           (vector-set! action-table state (cons (list symbol new-action) state-actions)))
-       ))
-
-    (define (add-action-for-all-terminals state action)
-      (do ((i 1 (+ i 1)))
-         ((= i nterms))
-       (add-action state i action)))
-
-    (set! action-table (make-vector nstates '()))
-
-    (do ((i 0 (+ i 1)))                        ; i = state
-       ((= i nstates))
-      (let ((red (vector-ref reduction-table i)))
-       (if (and red (>= (red-nreds red) 1))
-           (if (and (= (red-nreds red) 1) (vector-ref consistent i))
-               (if (glr-driver?)
-                   (add-action-for-all-terminals i (- (car (red-rules red))))
-                   (add-action i 'default (- (car (red-rules red)))))
-               (let ((k (vector-ref lookaheads (+ i 1))))
-                 (let loop ((j (vector-ref lookaheads i)))
-                   (if (< j k)
-                       (let ((rule (- (vector-ref LAruleno j)))
-                             (lav  (vector-ref LA j)))
-                         (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
-                           (if (< token nterms)
-                               (begin
-                                 (let ((in-la-set? (modulo x 2)))
-                                   (if (= in-la-set? 1)
-                                       (add-action i token rule)))
-                                 (if (= y (BITS-PER-WORD))
-                                     (loop2 (+ token 1)
-                                            (vector-ref lav (+ z 1))
-                                            1
-                                            (+ z 1))
-                                     (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
-                         (loop (+ j 1)))))))))
-
-      (let ((shiftp (vector-ref shift-table i)))
-       (if shiftp
-           (let loop ((k (shift-shifts shiftp)))
-             (if (pair? k)
-                 (let* ((state (car k))
-                        (symbol (vector-ref acces-symbol state)))
-                   (if (>= symbol nvars)
-                       (add-action i (- symbol nvars) state))
-                   (loop (cdr k))))))))
-
-    (add-action final-state 0 'accept)
-    (log-conflicts))
-
-  (define (compact-action-table terms)
-    (define (most-common-action acts)
-      (let ((accums '()))
-       (let loop ((l acts))
-         (if (pair? l)
-             (let* ((x (cadar l))
-                    (y (assv x accums)))
-               (if (and (number? x) (< x 0))
-                   (if y
-                       (set-cdr! y (+ 1 (cdr y)))
-                       (set! accums (cons `(,x . 1) accums))))
-               (loop (cdr l)))))
-
-       (let loop ((l accums) (max 0) (sym #f))
-         (if (null? l)
-             sym
-             (let ((x (car l)))
-               (if (> (cdr x) max)
-                   (loop (cdr l) (cdr x) (car x))
-                   (loop (cdr l) max sym)))))))
-
-    (define (translate-terms acts)
-      (map (lambda (act)
-            (cons (list-ref terms (car act))
-                  (cdr act)))
-          acts))
-
-    (do ((i 0 (+ i 1)))
-       ((= i nstates))
-      (let ((acts (vector-ref action-table i)))
-       (if (vector? (vector-ref reduction-table i))
-           (let ((act (most-common-action acts)))
-             (vector-set! action-table i
-                          (cons `(*default* ,(if act act '*error*))
-                                (translate-terms
-                                 (lalr-filter (lambda (x)
-                                                (not (and (= (length x) 2)
-                                                          (eq? (cadr x) act))))
-                                              acts)))))
-           (vector-set! action-table i
-                        (cons `(*default* *error*)
-                              (translate-terms acts)))))))
-
-
-
-  ;; --
-
-  (define (rewrite-grammar tokens grammar k)
-
-    (define eoi '*eoi*)
-
-    (define (check-terminal term terms)
-      (cond
-       ((not (valid-terminal? term))
-       (lalr-error "invalid terminal: " term))
-       ((member term terms)
-       (lalr-error "duplicate definition of terminal: " term))))
-
-    (define (prec->type prec)
-      (cdr (assq prec '((left:     . left)
-                       (right:    . right)
-                       (nonassoc: . nonassoc)))))
-
-    (cond
-     ;; --- a few error conditions
-     ((not (list? tokens))
-      (lalr-error "Invalid token list: " tokens))
-     ((not (pair? grammar))
-      (lalr-error "Grammar definition must have a non-empty list of productions" '()))
-
-     (else
-      ;; --- check the terminals
-      (let loop1 ((lst            tokens)
-                 (rev-terms      '())
-                 (rev-terms/prec '())
-                 (prec-level     0))
-       (if (pair? lst)
-           (let ((term (car lst)))
-             (cond
-              ((pair? term)
-               (if (and (memq (car term) '(left: right: nonassoc:))
-                        (not (null? (cdr term))))
-                   (let ((prec    (+ prec-level 1))
-                         (optype  (prec->type (car term))))
-                     (let loop-toks ((l             (cdr term))
-                                     (rev-terms      rev-terms)
-                                     (rev-terms/prec rev-terms/prec))
-                       (if (null? l)
-                           (loop1 (cdr lst) rev-terms rev-terms/prec prec)
-                           (let ((term (car l)))
-                             (check-terminal term rev-terms)
-                             (loop-toks
-                              (cdr l)
-                              (cons term rev-terms)
-                              (cons (list term optype prec) rev-terms/prec))))))
-
-                   (lalr-error "invalid operator precedence specification: " term)))
-
-              (else
-               (check-terminal term rev-terms)
-               (loop1 (cdr lst)
-                      (cons term rev-terms)
-                      (cons (list term 'none 0) rev-terms/prec)
-                      prec-level))))
-
-           ;; --- check the grammar rules
-           (let loop2 ((lst grammar) (rev-nonterm-defs '()))
-             (if (pair? lst)
-                 (let ((def (car lst)))
-                   (if (not (pair? def))
-                       (lalr-error "Nonterminal definition must be a non-empty list" '())
-                       (let ((nonterm (car def)))
-                         (cond ((not (valid-nonterminal? nonterm))
-                                (lalr-error "Invalid nonterminal:" nonterm))
-                               ((or (member nonterm rev-terms)
-                                    (assoc nonterm rev-nonterm-defs))
-                                (lalr-error "Nonterminal previously defined:" nonterm))
-                               (else
-                                (loop2 (cdr lst)
-                                       (cons def rev-nonterm-defs)))))))
-                 (let* ((terms        (cons eoi            (cons 'error          (reverse rev-terms))))
-                        (terms/prec   (cons '(eoi none 0)  (cons '(error none 0) (reverse rev-terms/prec))))
-                        (nonterm-defs (reverse rev-nonterm-defs))
-                        (nonterms     (cons '*start* (map car nonterm-defs))))
-                   (if (= (length nonterms) 1)
-                       (lalr-error "Grammar must contain at least one nonterminal" '())
-                       (let loop-defs ((defs      (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
-                                                        nonterm-defs))
-                                       (ruleno    0)
-                                       (comp-defs '()))
-                         (if (pair? defs)
-                             (let* ((nonterm-def  (car defs))
-                                    (compiled-def (rewrite-nonterm-def
-                                                   nonterm-def
-                                                   ruleno
-                                                   terms nonterms)))
-                               (loop-defs (cdr defs)
-                                          (+ ruleno (length compiled-def))
-                                          (cons compiled-def comp-defs)))
-
-                             (let ((compiled-nonterm-defs (reverse comp-defs)))
-                               (k terms
-                                  terms/prec
-                                  nonterms
-                                  (map (lambda (x) (cons (caaar x) (map cdar x)))
-                                       compiled-nonterm-defs)
-                                  (apply append compiled-nonterm-defs))))))))))))))
-
-
-  (define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
-
-    (define No-NT (length nonterms))
-
-    (define (encode x)
-      (let ((PosInNT (pos-in-list x nonterms)))
-       (if PosInNT
-           PosInNT
-           (let ((PosInT (pos-in-list x terms)))
-             (if PosInT
-                 (+ No-NT PosInT)
-                 (lalr-error "undefined symbol : " x))))))
-
-    (define (process-prec-directive rhs ruleno)
-      (let loop ((l rhs))
-       (if (null? l)
-           '()
-           (let ((first (car l))
-                 (rest  (cdr l)))
-             (cond
-              ((or (member first terms) (member first nonterms))
-               (cons first (loop rest)))
-              ((and (pair? first)
-                    (eq? (car first) 'prec:))
-               (if (and (pair? (cdr first))
-                        (null? (cddr first))
-                        (member (cadr first) terms))
-                   (if (null? rest)
-                       (begin
-                         (add-rule-precedence! ruleno (pos-in-list (cadr first) terms))
-                         (loop rest))
-                       (lalr-error "prec: directive should be at end of rule: " rhs))
-                   (lalr-error "Invalid prec: directive: " first)))
-              (else
-               (lalr-error "Invalid terminal or nonterminal: " first)))))))
-
-    (define (check-error-production rhs)
-      (let loop ((rhs rhs))
-       (if (pair? rhs)
-           (begin
-             (if (and (eq? (car rhs) 'error)
-                      (or (null? (cdr rhs))
-                          (not (member (cadr rhs) terms))
-                          (not (null? (cddr rhs)))))
-                 (lalr-error "Invalid 'error' production. A single terminal symbol must follow the 'error' token.:" rhs))
-             (loop (cdr rhs))))))
-
-
-    (if (not (pair? (cdr nonterm-def)))
-       (lalr-error "At least one production needed for nonterminal:" (car nonterm-def))
-       (let ((name (symbol->string (car nonterm-def))))
-         (let loop1 ((lst (cdr nonterm-def))
-                     (i 1)
-                     (rev-productions-and-actions '()))
-           (if (not (pair? lst))
-               (reverse rev-productions-and-actions)
-               (let* ((rhs  (process-prec-directive (car lst) (+ ruleno i -1)))
-                      (rest (cdr lst))
-                      (prod (map encode (cons (car nonterm-def) rhs))))
-                 ;; -- check for undefined tokens
-                 (for-each (lambda (x)
-                             (if (not (or (member x terms) (member x nonterms)))
-                                 (lalr-error "Invalid terminal or nonterminal:" x)))
-                           rhs)
-                 ;; -- check 'error' productions
-                 (check-error-production rhs)
-
-                 (if (and (pair? rest)
-                          (eq? (car rest) ':)
-                          (pair? (cdr rest)))
-                     (loop1 (cddr rest)
-                            (+ i 1)
-                            (cons (cons prod (cadr rest))
-                                  rev-productions-and-actions))
-                     (let* ((rhs-length (length rhs))
-                            (action
-                             (cons 'vector
-                                   (cons (list 'quote (string->symbol
-                                                       (string-append
-                                                        name
-                                                        "-"
-                                                        (number->string i))))
-                                         (let loop-j ((j 1))
-                                           (if (> j rhs-length)
-                                               '()
-                                               (cons (string->symbol
-                                                      (string-append
-                                                       "$"
-                                                       (number->string j)))
-                                                     (loop-j (+ j 1)))))))))
-                       (loop1 rest
-                              (+ i 1)
-                              (cons (cons prod action)
-                                    rev-productions-and-actions))))))))))
-
-  (define (valid-nonterminal? x)
-    (symbol? x))
-
-  (define (valid-terminal? x)
-    (symbol? x))                       ; DB 
-
-  ;; ----------------------------------------------------------------------
-  ;; Miscellaneous
-  ;; ----------------------------------------------------------------------
-  (define (pos-in-list x lst)
-    (let loop ((lst lst) (i 0))
-      (cond ((not (pair? lst))    #f)
-           ((equal? (car lst) x) i)
-           (else                 (loop (cdr lst) (+ i 1))))))
-
-  (define (sunion lst1 lst2)           ; union of sorted lists
-    (let loop ((L1 lst1)
-              (L2 lst2))
-      (cond ((null? L1)    L2)
-           ((null? L2)    L1)
-           (else
-            (let ((x (car L1)) (y (car L2)))
-              (cond
-               ((> x y)
-                (cons y (loop L1 (cdr L2))))
-               ((< x y)
-                (cons x (loop (cdr L1) L2)))
-               (else
-                (loop (cdr L1) L2))
-               ))))))
-
-  (define (sinsert elem lst)
-    (let loop ((l1 lst))
-      (if (null? l1)
-         (cons elem l1)
-         (let ((x (car l1)))
-           (cond ((< elem x)
-                  (cons elem l1))
-                 ((> elem x)
-                  (cons x (loop (cdr l1))))
-                 (else
-                  l1))))))
-
-  (define (lalr-filter p lst)
-    (let loop ((l lst))
-      (if (null? l)
-         '()
-         (let ((x (car l)) (y (cdr l)))
-           (if (p x)
-               (cons x (loop y))
-               (loop y))))))
-      
-  ;; ----------------------------------------------------------------------
-  ;; Debugging tools ...
-  ;; ----------------------------------------------------------------------
-  (define the-terminals #f)            ; names of terminal symbols
-  (define the-nonterminals #f)         ; non-terminals
-
-  (define (print-item item-no)
-    (let loop ((i item-no))
-      (let ((v (vector-ref ritem i)))
-       (if (>= v 0)
-           (loop (+ i 1))
-           (let* ((rlno    (- v))
-                  (nt      (vector-ref rlhs rlno)))
-             (display (vector-ref the-nonterminals nt)) (display " --> ")
-             (let loop ((i (vector-ref rrhs rlno)))
-               (let ((v (vector-ref ritem i)))
-                 (if (= i item-no)
-                     (display ". "))
-                 (if (>= v 0)
-                     (begin
-                       (display (get-symbol v))
-                       (display " ")
-                       (loop (+ i 1)))
-                     (begin
-                       (display "   (rule ")
-                       (display (- v))
-                       (display ")")
-                       (newline))))))))))
-
-  (define (get-symbol n)
-    (if (>= n nvars)
-       (vector-ref the-terminals (- n nvars))
-       (vector-ref the-nonterminals n)))
-
-
-  (define (print-states)
-    (define (print-action act)
-      (cond
-       ((eq? act '*error*)
-       (display " : Error"))
-       ((eq? act 'accept)
-       (display " : Accept input"))
-       ((< act 0)
-       (display " : reduce using rule ")
-       (display (- act)))
-       (else
-       (display " : shift and goto state ")
-       (display act)))
-      (newline)
-      #t)
-
-    (define (print-actions acts)
-      (let loop ((l acts))
-       (if (null? l)
-           #t
-           (let ((sym (caar l))
-                 (act (cadar l)))
-             (display "   ")
-             (cond
-              ((eq? sym 'default)
-               (display "default action"))
-              (else
-               (if (number? sym)
-                   (display (get-symbol (+ sym nvars)))
-                   (display sym))))
-             (print-action act)
-             (loop (cdr l))))))
-
-    (if (not action-table)
-       (begin
-         (display "No generated parser available!")
-         (newline)
-         #f)
-       (begin
-         (display "State table") (newline)
-         (display "-----------") (newline) (newline)
-
-         (let loop ((l first-state))
-           (if (null? l)
-               #t
-               (let* ((core  (car l))
-                      (i     (core-number core))
-                      (items (core-items core))
-                      (actions (vector-ref action-table i)))
-                 (display "state ") (display i) (newline)
-                 (newline)
-                 (for-each (lambda (x) (display "   ") (print-item x))
-                           items)
-                 (newline)
-                 (print-actions actions)
-                 (newline)
-                 (loop (cdr l))))))))
-
-
-
-  ;; ----------------------------------------------------------------------
-      
-  (define build-goto-table
-    (lambda ()
-      `(vector
-       ,@(map
-          (lambda (shifts)
-            (list 'quote
-                  (if shifts
-                      (let loop ((l (shift-shifts shifts)))
-                        (if (null? l)
-                            '()
-                            (let* ((state  (car l))
-                                   (symbol (vector-ref acces-symbol state)))
-                              (if (< symbol nvars)
-                                  (cons `(,symbol . ,state)
-                                        (loop (cdr l)))
-                                  (loop (cdr l))))))
-                      '())))
-          (vector->list shift-table)))))
-
-
-  (define build-reduction-table
-    (lambda (gram/actions)
-      `(vector
-       '()
-       ,@(map
-          (lambda (p)
-            (let ((act (cdr p)))
-              `(lambda ,(if (eq? driver-name 'lr-driver)
-                            '(___stack ___sp ___goto-table ___push yypushback)
-                            '(___sp ___goto-table ___push))
-                 ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
-                    `(let* (,@(if act
-                                  (let loop ((i 1) (l rhs))
-                                    (if (pair? l)
-                                        (let ((rest (cdr l))
-                                               (ns (number->string (+ (- n i) 1))))
-                                           (cons
-                                            `(tok ,(if (eq? driver-name 'lr-driver)
-                                                       `(vector-ref ___stack (- ___sp ,(- (* i 2) 1)))
-                                                       `(list-ref ___sp ,(+ (* (- i 1) 2) 1))))
-                                            (cons
-                                             `(,(string->symbol (string-append "$" ns))
-                                               (if (lexical-token? tok) (lexical-token-value tok) tok))
-                                             (cons
-                                              `(,(string->symbol (string-append "@" ns))
-                                                (if (lexical-token? tok) (lexical-token-source tok) tok))
-                                              (loop (+ i 1) rest)))))
-                                        '()))
-                                  '()))
-                       ,(if (= nt 0)
-                            '$1
-                            `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp)) 
-                                       ,(if (eq? driver-name 'lr-driver)
-                                            `(vector-ref ___stack (- ___sp ,(length rhs)))
-                                            `(list-ref ___sp ,(length rhs))))))))))
-
-          gram/actions))))
-
-
-
-  ;; Options
-
-  (define *valid-options*
-    (list
-     (cons 'out-table:
-          (lambda (option)
-            (and (list? option)
-                 (= (length option) 2)
-                 (string? (cadr option)))))
-     (cons 'output:
-          (lambda (option)
-            (and (list? option)
-                 (= (length option) 3)
-                 (symbol? (cadr option))
-                 (string? (caddr option)))))
-     (cons 'expect:
-          (lambda (option)
-            (and (list? option)
-                 (= (length option) 2)
-                 (integer? (cadr option))
-                 (>= (cadr option) 0))))
-
-     (cons 'driver:
-          (lambda (option)
-            (and (list? option)
-                 (= (length option) 2)
-                 (symbol? (cadr option))
-                 (memq (cadr option) '(lr glr)))))))
-
-
-  (define (validate-options options)
-    (for-each
-     (lambda (option)
-       (let ((p (assoc (car option) *valid-options*)))
-        (if (or (not p)
-                (not ((cdr p) option)))
-            (lalr-error "Invalid option:" option))))
-     options))
-
-
-  (define (output-parser! options code)
-    (let ((option (assq 'output: options)))
-      (if option
-         (let ((parser-name (cadr option))
-               (file-name   (caddr option)))
-           (with-output-to-file file-name
-             (lambda ()
-               (pprint `(define ,parser-name ,code))
-               (newline)))))))
-
-
-  (define (output-table! options)
-    (let ((option (assq 'out-table: options)))
-      (if option
-         (let ((file-name (cadr option)))
-           (with-output-to-file file-name print-states)))))
-
-
-  (define (set-expected-conflicts! options)
-    (let ((option (assq 'expect: options)))
-      (set! expected-conflicts (if option (cadr option) 0))))
-
-  (define (set-driver-name! options)
-    (let ((option (assq 'driver: options)))
-      (if option
-         (let ((driver-type (cadr option)))
-           (set! driver-name (if (eq? driver-type 'glr) 'glr-driver 'lr-driver))))))
-
-
-  ;; -- arguments
-
-  (define (extract-arguments lst proc)
-    (let loop ((options '())
-              (tokens  '())
-              (rules   '())
-              (lst     lst))
-      (if (pair? lst)
-         (let ((p (car lst)))
-           (cond
-            ((and (pair? p)
-                  (lalr-keyword? (car p))
-                  (assq (car p) *valid-options*))
-             (loop (cons p options) tokens rules (cdr lst)))
-            (else
-             (proc options p (cdr lst)))))
-         (lalr-error "Malformed lalr-parser form" lst))))
-
-
-  (define (build-driver options tokens rules)
-    (validate-options options)
-    (set-expected-conflicts! options)
-    (set-driver-name! options)
-    (let* ((gram/actions (gen-tables! tokens rules))
-          (code         `(,driver-name ',action-table ,(build-goto-table) ,(build-reduction-table gram/actions))))
-    
-      (output-table! options)
-      (output-parser! options code)
-      code))
-
-  (extract-arguments arguments build-driver))
-   
-
-
-;;;
-;;;; --
-;;;; Implementation of the lr-driver
-;;;
-
-
-(cond-expand
- (gambit
-  (declare
-   (standard-bindings)
-   (fixnum)
-   (block)
-   (not safe)))
- (chicken
-  (declare
-   (uses extras)
-   (usual-integrations)
-   (fixnum)
-   (not safe)))
- (else))
-
-
-;;;
-;;;; Source location utilities
-;;;
-
-
-;; This function assumes that src-location-1 and src-location-2 are source-locations
-;; Returns #f if they are not locations for the same input 
-(define (combine-locations src-location-1 src-location-2)
-  (let ((offset-1 (source-location-offset src-location-1))
-        (offset-2 (source-location-offset src-location-2))
-        (length-1 (source-location-length src-location-1))
-        (length-2 (source-location-length src-location-2)))
-
-    (cond ((not (equal? (source-location-input src-location-1)
-                        (source-location-input src-location-2)))
-           #f)
-          ((or (not (number? offset-1)) (not (number? offset-2))
-               (not (number? length-1)) (not (number? length-2))
-               (< offset-1 0) (< offset-2 0)
-               (< length-1 0) (< length-2 0))
-           (make-source-location (source-location-input src-location-1)
-                                 (source-location-line src-location-1)
-                                 (source-location-column src-location-1)
-                                 -1 -1))
-          ((<= offset-1 offset-2)
-           (make-source-location (source-location-input src-location-1)
-                                 (source-location-line src-location-1)
-                                 (source-location-column src-location-1)
-                                 offset-1
-                                 (- (+ offset-2 length-2) offset-1)))
-          (else
-           (make-source-location (source-location-input src-location-1)
-                                 (source-location-line src-location-1)
-                                 (source-location-column src-location-1)
-                                 offset-2
-                                 (- (+ offset-1 length-1) offset-2))))))
-
-
-;;;
-;;;;  LR-driver
-;;;
-
-
-(define *max-stack-size* 500)
-
-(define (lr-driver action-table goto-table reduction-table)
-  (define ___atable action-table)
-  (define ___gtable goto-table)
-  (define ___rtable reduction-table)
-
-  (define ___lexerp #f)
-  (define ___errorp #f)
-  
-  (define ___stack  #f)
-  (define ___sp     0)
-  
-  (define ___curr-input #f)
-  (define ___reuse-input #f)
-  
-  (define ___input #f)
-  (define (___consume)
-    (set! ___input (if ___reuse-input ___curr-input (___lexerp)))
-    (set! ___reuse-input #f)
-    (set! ___curr-input ___input))
-  
-  (define (___pushback)
-    (set! ___reuse-input #t))
-  
-  (define (___initstack)
-    (set! ___stack (make-vector *max-stack-size* 0))
-    (set! ___sp 0))
-  
-  (define (___growstack)
-    (let ((new-stack (make-vector (* 2 (vector-length ___stack)) 0)))
-      (let loop ((i (- (vector-length ___stack) 1)))
-        (if (>= i 0)
-           (begin
-             (vector-set! new-stack i (vector-ref ___stack i))
-             (loop (- i 1)))))
-      (set! ___stack new-stack)))
-  
-  (define (___checkstack)
-    (if (>= ___sp (vector-length ___stack))
-        (___growstack)))
-  
-  (define (___push delta new-category lvalue tok)
-    (set! ___sp (- ___sp (* delta 2)))
-    (let* ((state     (vector-ref ___stack ___sp))
-           (new-state (cdr (assoc new-category (vector-ref ___gtable state)))))
-      (set! ___sp (+ ___sp 2))
-      (___checkstack)
-      (vector-set! ___stack ___sp new-state)
-      (vector-set! ___stack (- ___sp 1) (note-source-location lvalue tok))))
-  
-  (define (___reduce st)
-    ((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback))
-  
-  (define (___shift token attribute)
-    (set! ___sp (+ ___sp 2))
-    (___checkstack)
-    (vector-set! ___stack (- ___sp 1) attribute)
-    (vector-set! ___stack ___sp token))
-  
-  (define (___action x l)
-    (let ((y (assoc x l)))
-      (if y (cadr y) (cadar l))))
-  
-  (define (___recover tok)
-    (let find-state ((sp ___sp))
-      (if (< sp 0)
-          (set! ___sp sp)
-          (let* ((state (vector-ref ___stack sp))
-                 (act   (assoc 'error (vector-ref ___atable state))))
-            (if act
-                (begin
-                  (set! ___sp sp)
-                  (___sync (cadr act) tok))
-                (find-state (- sp 2)))))))
-  
-  (define (___sync state tok)
-    (let ((sync-set (map car (cdr (vector-ref ___atable state)))))
-      (set! ___sp (+ ___sp 4))
-      (___checkstack)
-      (vector-set! ___stack (- ___sp 3) #f)
-      (vector-set! ___stack (- ___sp 2) state)
-      (let skip ()
-        (let ((i (___category ___input)))
-          (if (eq? i '*eoi*)
-              (set! ___sp -1)
-              (if (memq i sync-set)
-                  (let ((act (assoc i (vector-ref ___atable state))))
-                    (vector-set! ___stack (- ___sp 1) #f)
-                    (vector-set! ___stack ___sp (cadr act)))
-                  (begin
-                    (___consume)
-                    (skip))))))))
-  
-  (define (___category tok)
-    (if (lexical-token? tok)
-        (lexical-token-category tok)
-        tok))
-
-  (define (___run)
-    (let loop ()
-      (if ___input
-          (let* ((state (vector-ref ___stack ___sp))
-                 (i     (___category ___input))
-                 (act   (___action i (vector-ref ___atable state))))
-            
-            (cond ((not (symbol? i))
-                   (___errorp "Syntax error: invalid token: " ___input)
-                   #f)
-             
-                  ;; Input succesfully parsed
-                  ((eq? act 'accept)
-                   (vector-ref ___stack 1))
-                  
-                  ;; Syntax error in input
-                  ((eq? act '*error*)
-                   (if (eq? i '*eoi*)
-                       (begin
-                         (___errorp "Syntax error: unexpected end of input")
-                         #f)
-                       (begin
-                         (___errorp "Syntax error: unexpected token : " ___input)
-                         (___recover i)
-                         (if (>= ___sp 0)
-                             (set! ___input #f)
-                             (begin
-                               (set! ___sp 0)
-                               (set! ___input '*eoi*)))
-                         (loop))))
-             
-                  ;; Shift current token on top of the stack
-                  ((>= act 0)
-                   (___shift act ___input)
-                   (set! ___input (if (eq? i '*eoi*) '*eoi* #f))
-                   (loop))
-             
-                  ;; Reduce by rule (- act)
-                  (else
-                   (___reduce (- act))
-                   (loop))))
-          
-          ;; no lookahead, so check if there is a default action
-          ;; that does not require the lookahead
-          (let* ((state  (vector-ref ___stack ___sp))
-                 (acts   (vector-ref ___atable state))
-                 (defact (if (pair? acts) (cadar acts) #f)))
-            (if (and (= 1 (length acts)) (< defact 0))
-                (___reduce (- defact))
-                (___consume))
-            (loop)))))
-  
-
-  (lambda (lexerp errorp)
-    (set! ___errorp errorp)
-    (set! ___lexerp lexerp)
-    (___initstack)
-    (___run)))
-
-
-;;;
-;;;;  Simple-minded GLR-driver
-;;;
-
-
-(define (glr-driver action-table goto-table reduction-table)
-  (define ___atable action-table)
-  (define ___gtable goto-table)
-  (define ___rtable reduction-table)
-
-  (define ___lexerp #f)
-  (define ___errorp #f)
-  
-  ;; -- Input handling 
-  
-  (define *input* #f)
-  (define (initialize-lexer lexer)
-    (set! ___lexerp lexer)
-    (set! *input* #f))
-  (define (consume)
-    (set! *input* (___lexerp)))
-  
-  (define (token-category tok)
-    (if (lexical-token? tok)
-        (lexical-token-category tok)
-        tok))
-
-  (define (token-attribute tok)
-    (if (lexical-token? tok)
-        (lexical-token-value tok)
-        tok))
-
-  ;; -- Processes (stacks) handling
-  
-  (define *processes* '())
-  
-  (define (initialize-processes)
-    (set! *processes* '()))
-  (define (add-process process)
-    (set! *processes* (cons process *processes*)))
-  (define (get-processes)
-    (reverse *processes*))
-  
-  (define (for-all-processes proc)
-    (let ((processes (get-processes)))
-      (initialize-processes)
-      (for-each proc processes)))
-  
-  ;; -- parses
-  (define *parses* '())
-  (define (get-parses)
-    *parses*)
-  (define (initialize-parses)
-    (set! *parses* '()))
-  (define (add-parse parse)
-    (set! *parses* (cons parse *parses*)))
-    
-
-  (define (push delta new-category lvalue stack tok)
-    (let* ((stack     (drop stack (* delta 2)))
-           (state     (car stack))
-           (new-state (cdr (assv new-category (vector-ref ___gtable state)))))
-        (cons new-state (cons (note-source-location lvalue tok) stack))))
-  
-  (define (reduce state stack)
-    ((vector-ref ___rtable state) stack ___gtable push))
-  
-  (define (shift state symbol stack)
-    (cons state (cons symbol stack)))
-  
-  (define (get-actions token action-list)
-    (let ((pair (assoc token action-list)))
-      (if pair 
-          (cdr pair)
-          (cdar action-list)))) ;; get the default action
-  
-
-  (define (run)
-    (let loop-tokens ()
-      (consume)
-      (let ((symbol (token-category *input*)))
-        (for-all-processes
-         (lambda (process)
-           (let loop ((stacks (list process)) (active-stacks '()))
-             (cond ((pair? stacks)
-                    (let* ((stack   (car stacks))
-                           (state   (car stack)))
-                      (let actions-loop ((actions      (get-actions symbol (vector-ref ___atable state)))
-                                         (active-stacks active-stacks))
-                        (if (pair? actions)
-                            (let ((action        (car actions))
-                                  (other-actions (cdr actions)))
-                              (cond ((eq? action '*error*)
-                                     (actions-loop other-actions active-stacks))
-                                    ((eq? action 'accept)
-                                     (add-parse (car (take-right stack 2)))
-                                     (actions-loop other-actions active-stacks))
-                                    ((>= action 0)
-                                     (let ((new-stack (shift action *input* stack)))
-                                       (add-process new-stack))
-                                     (actions-loop other-actions active-stacks))
-                                    (else
-                                     (let ((new-stack (reduce (- action) stack)))
-                                      (actions-loop other-actions (cons new-stack active-stacks))))))
-                            (loop (cdr stacks) active-stacks)))))
-                   ((pair? active-stacks)
-                    (loop (reverse active-stacks) '())))))))
-      (if (pair? (get-processes))
-          (loop-tokens))))
-
-  
-  (lambda (lexerp errorp)
-    (set! ___errorp errorp)
-    (initialize-lexer lexerp)
-    (initialize-processes)
-    (initialize-parses)
-    (add-process '(0))
-    (run)
-    (get-parses)))
-
-
-(define (drop l n)
-  (cond ((and (> n 0) (pair? l))
-        (drop (cdr l) (- n 1)))
-       (else
-        l)))
-
-(define (take-right l n)
-  (drop l (- (length l) n)))
diff --git a/lib/match.scm b/lib/match.scm
deleted file mode 100644 (file)
index 5fec7f9..0000000
+++ /dev/null
@@ -1,934 +0,0 @@
-;;;; match.scm -- portable hygienic pattern matcher -*- coding: utf-8 -*-
-;;
-;; This code is written by Alex Shinn and placed in the
-;; Public Domain.  All warranties are disclaimed.
-
-;;> @example-import[(srfi 9)]
-
-;;> This is a full superset of the popular @hyperlink[
-;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match}
-;;> package by Andrew Wright, written in fully portable @scheme{syntax-rules}
-;;> and thus preserving hygiene.
-
-;;> The most notable extensions are the ability to use @emph{non-linear}
-;;> patterns - patterns in which the same identifier occurs multiple
-;;> times, tail patterns after ellipsis, and the experimental tree patterns.
-
-;;> @subsubsection{Patterns}
-
-;;> Patterns are written to look like the printed representation of
-;;> the objects they match.  The basic usage is
-
-;;> @scheme{(match expr (pat body ...) ...)}
-
-;;> where the result of @var{expr} is matched against each pattern in
-;;> turn, and the corresponding body is evaluated for the first to
-;;> succeed.  Thus, a list of three elements matches a list of three
-;;> elements.
-
-;;> @example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))}
-
-;;> If no patterns match an error is signalled.
-
-;;> Identifiers will match anything, and make the corresponding
-;;> binding available in the body.
-
-;;> @example{(match (list 1 2 3) ((a b c) b))}
-
-;;> If the same identifier occurs multiple times, the first instance
-;;> will match anything, but subsequent instances must match a value
-;;> which is @scheme{equal?} to the first.
-
-;;> @example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))}
-
-;;> The special identifier @scheme{_} matches anything, no matter how
-;;> many times it is used, and does not bind the result in the body.
-
-;;> @example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))}
-
-;;> To match a literal identifier (or list or any other literal), use
-;;> @scheme{quote}.
-
-;;> @example{(match 'a ('b 1) ('a 2))}
-
-;;> Analogous to its normal usage in scheme, @scheme{quasiquote} can
-;;> be used to quote a mostly literally matching object with selected
-;;> parts unquoted.
-
-;;> @example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}|
-
-;;> Often you want to match any number of a repeated pattern.  Inside
-;;> a list pattern you can append @scheme{...} after an element to
-;;> match zero or more of that pattern (like a regexp Kleene star).
-
-;;> @example{(match (list 1 2) ((1 2 3 ...) #t))}
-;;> @example{(match (list 1 2 3) ((1 2 3 ...) #t))}
-;;> @example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))}
-
-;;> Pattern variables matched inside the repeated pattern are bound to
-;;> a list of each matching instance in the body.
-
-;;> @example{(match (list 1 2) ((a b c ...) c))}
-;;> @example{(match (list 1 2 3) ((a b c ...) c))}
-;;> @example{(match (list 1 2 3 4 5) ((a b c ...) c))}
-
-;;> More than one @scheme{...} may not be used in the same list, since
-;;> this would require exponential backtracking in the general case.
-;;> However, @scheme{...} need not be the final element in the list,
-;;> and may be succeeded by a fixed number of patterns.
-
-;;> @example{(match (list 1 2 3 4) ((a b c ... d e) c))}
-;;> @example{(match (list 1 2 3 4 5) ((a b c ... d e) c))}
-;;> @example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))}
-
-;;> @scheme{___} is provided as an alias for @scheme{...} when it is
-;;> inconvenient to use the ellipsis (as in a syntax-rules template).
-
-;;> The @scheme{..1} syntax is exactly like the @scheme{...} except
-;;> that it matches one or more repetitions (like a regexp "+").
-
-;;> @example{(match (list 1 2) ((a b c ..1) c))}
-;;> @example{(match (list 1 2 3) ((a b c ..1) c))}
-
-;;> The boolean operators @scheme{and}, @scheme{or} and @scheme{not}
-;;> can be used to group and negate patterns analogously to their
-;;> Scheme counterparts.
-
-;;> The @scheme{and} operator ensures that all subpatterns match.
-;;> This operator is often used with the idiom @scheme{(and x pat)} to
-;;> bind @var{x} to the entire value that matches @var{pat}
-;;> (c.f. "as-patterns" in ML or Haskell).  Another common use is in
-;;> conjunction with @scheme{not} patterns to match a general case
-;;> with certain exceptions.
-
-;;> @example{(match 1 ((and) #t))}
-;;> @example{(match 1 ((and x) x))}
-;;> @example{(match 1 ((and x 1) x))}
-
-;;> The @scheme{or} operator ensures that at least one subpattern
-;;> matches.  If the same identifier occurs in different subpatterns,
-;;> it is matched independently.  All identifiers from all subpatterns
-;;> are bound if the @scheme{or} operator matches, but the binding is
-;;> only defined for identifiers from the subpattern which matched.
-
-;;> @example{(match 1 ((or) #t) (else #f))}
-;;> @example{(match 1 ((or x) x))}
-;;> @example{(match 1 ((or x 2) x))}
-
-;;> The @scheme{not} operator succeeds if the given pattern doesn't
-;;> match.  None of the identifiers used are available in the body.
-
-;;> @example{(match 1 ((not 2) #t))}
-
-;;> The more general operator @scheme{?} can be used to provide a
-;;> predicate.  The usage is @scheme{(? predicate pat ...)} where
-;;> @var{predicate} is a Scheme expression evaluating to a predicate
-;;> called on the value to match, and any optional patterns after the
-;;> predicate are then matched as in an @scheme{and} pattern.
-
-;;> @example{(match 1 ((? odd? x) x))}
-
-;;> The field operator @scheme{=} is used to extract an arbitrary
-;;> field and match against it.  It is useful for more complex or
-;;> conditional destructuring that can't be more directly expressed in
-;;> the pattern syntax.  The usage is @scheme{(= field pat)}, where
-;;> @var{field} can be any expression, and should result in a
-;;> procedure of one argument, which is applied to the value to match
-;;> to generate a new value to match against @var{pat}.
-
-;;> Thus the pattern @scheme{(and (= car x) (= cdr y))} is equivalent
-;;> to @scheme{(x . y)}, except it will result in an immediate error
-;;> if the value isn't a pair.
-
-;;> @example{(match '(1 . 2) ((= car x) x))}
-;;> @example{(match 4 ((= sqrt x) x))}
-
-;;> The record operator @scheme{$} is used as a concise way to match
-;;> records defined by SRFI-9 (or SRFI-99).  The usage is
-;;> @scheme{($ rtd field ...)}, where @var{rtd} should be the record
-;;> type descriptor specified as the first argument to
-;;> @scheme{define-record-type}, and each @var{field} is a subpattern
-;;> matched against the fields of the record in order.  Not all fields
-;;> must be present.
-
-;;> @example{
-;;> (let ()
-;;>   (define-record-type employee
-;;>     (make-employee name title)
-;;>     employee?
-;;>     (name get-name)
-;;>     (title get-title))
-;;>   (match (make-employee "Bob" "Doctor")
-;;>     (($ employee n t) (list t n))))
-;;> }
-
-;;> The @scheme{set!} and @scheme{get!} operators are used to bind an
-;;> identifier to the setter and getter of a field, respectively.  The
-;;> setter is a procedure of one argument, which mutates the field to
-;;> that argument.  The getter is a procedure of no arguments which
-;;> returns the current value of the field.
-
-;;> @example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))}
-;;> @example{(match '(1 . 2) ((1 . (get! g)) (g)))}
-
-;;> The new operator @scheme{***} can be used to search a tree for
-;;> subpatterns.  A pattern of the form @scheme{(x *** y)} represents
-;;> the subpattern @var{y} located somewhere in a tree where the path
-;;> from the current object to @var{y} can be seen as a list of the
-;;> form @scheme{(x ...)}.  @var{y} can immediately match the current
-;;> object in which case the path is the empty list.  In a sense it's
-;;> a 2-dimensional version of the @scheme{...} pattern.
-
-;;> As a common case the pattern @scheme{(_ *** y)} can be used to
-;;> search for @var{y} anywhere in a tree, regardless of the path
-;;> used.
-
-;;> @example{(match '(a (a (a b))) ((x *** 'b) x))}
-;;> @example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))}
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Notes
-
-;; The implementation is a simple generative pattern matcher - each
-;; pattern is expanded into the required tests, calling a failure
-;; continuation if the tests fail.  This makes the logic easy to
-;; follow and extend, but produces sub-optimal code in cases where you
-;; have many similar clauses due to repeating the same tests.
-;; Nonetheless a smart compiler should be able to remove the redundant
-;; tests.  For MATCH-LET and DESTRUCTURING-BIND type uses there is no
-;; performance hit.
-
-;; The original version was written on 2006/11/29 and described in the
-;; following Usenet post:
-;;   http://groups.google.com/group/comp.lang.scheme/msg/0941234de7112ffd
-;; and is still available at
-;;   http://synthcode.com/scheme/match-simple.scm
-;; It's just 80 lines for the core MATCH, and an extra 40 lines for
-;; MATCH-LET, MATCH-LAMBDA and other syntactic sugar.
-;;
-;; A variant of this file which uses COND-EXPAND in a few places for
-;; performance can be found at
-;;   http://synthcode.com/scheme/match-cond-expand.scm
-;;
-;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns
-;; 2011/09/25 - fixing bug when directly matching an identifier repeated in
-;;              the pattern (thanks to Stefan Israelsson Tampe)
-;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
-;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès)
-;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
-;; 2009/11/25 - adding `***' tree search patterns
-;; 2008/03/20 - fixing bug where (a ...) matched non-lists
-;; 2008/03/15 - removing redundant check in vector patterns
-;; 2008/03/06 - you can use `...' portably now (thanks to Taylor Campbell)
-;; 2007/09/04 - fixing quasiquote patterns
-;; 2007/07/21 - allowing ellipse patterns in non-final list positions
-;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
-;;              (thanks to Taylor Campbell)
-;; 2007/04/08 - clean up, commenting
-;; 2006/12/24 - bugfixes
-;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; force compile-time syntax errors with useful messages
-
-(define-syntax match-syntax-error
-  (syntax-rules ()
-    ((_) (match-syntax-error "invalid match-syntax-error usage"))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;> @subsubsection{Syntax}
-
-;;> @subsubsubsection{@rawcode{(match expr (pattern . body) ...)@br{}
-;;> (match expr (pattern (=> failure) . body) ...)}}
-
-;;> The result of @var{expr} is matched against each @var{pattern} in
-;;> turn, according to the pattern rules described in the previous
-;;> section, until the the first @var{pattern} matches.  When a match is
-;;> found, the corresponding @var{body}s are evaluated in order,
-;;> and the result of the last expression is returned as the result
-;;> of the entire @scheme{match}.  If a @var{failure} is provided,
-;;> then it is bound to a procedure of no arguments which continues,
-;;> processing at the next @var{pattern}.  If no @var{pattern} matches,
-;;> an error is signalled.
-
-;; The basic interface.  MATCH just performs some basic syntax
-;; validation, binds the match expression to a temporary variable `v',
-;; and passes it on to MATCH-NEXT.  It's a constant throughout the
-;; code below that the binding `v' is a direct variable reference, not
-;; an expression.
-
-(define-syntax match
-  (syntax-rules ()
-    ((match)
-     (match-syntax-error "missing match expression"))
-    ((match atom)
-     (match-syntax-error "no match clauses"))
-    ((match (app ...) (pat . body) ...)
-     (let ((v (app ...)))
-       (match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
-    ((match #(vec ...) (pat . body) ...)
-     (let ((v #(vec ...)))
-       (match-next v (v (set! v)) (pat . body) ...)))
-    ((match atom (pat . body) ...)
-     (let ((v atom))
-       (match-next v (atom (set! atom)) (pat . body) ...)))
-    ))
-
-;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
-;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
-;; clauses.  `g+s' is a list of two elements, the get! and set!
-;; expressions respectively.
-
-(define-syntax match-next
-  (syntax-rules (=>)
-    ;; no more clauses, the match failed
-    ((match-next v g+s)
-     ;; Here we call error in non-tail context, so that the backtrace
-     ;; can show the source location of the failing match form.
-     (begin
-       (error 'match "no matching pattern" v)
-       #f))
-    ;; named failure continuation
-    ((match-next v g+s (pat (=> failure) . body) . rest)
-     (let ((failure (lambda () (match-next v g+s . rest))))
-       ;; match-one analyzes the pattern for us
-       (match-one v pat g+s (match-drop-ids (begin . body)) (failure) ())))
-    ;; anonymous failure continuation, give it a dummy name
-    ((match-next v g+s (pat . body) . rest)
-     (match-next v g+s (pat (=> failure) . body) . rest))))
-
-;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
-;; MATCH-TWO.
-
-(define-syntax match-one
-  (syntax-rules ()
-    ;; If it's a list of two or more values, check to see if the
-    ;; second one is an ellipse and handle accordingly, otherwise go
-    ;; to MATCH-TWO.
-    ((match-one v (p q . r) g+s sk fk i)
-     (match-check-ellipse
-      q
-      (match-extract-vars p (match-gen-ellipses v p r  g+s sk fk i) i ())
-      (match-two v (p q . r) g+s sk fk i)))
-    ;; Go directly to MATCH-TWO.
-    ((match-one . x)
-     (match-two . x))))
-
-;; This is the guts of the pattern matcher.  We are passed a lot of
-;; information in the form:
-;;
-;;   (match-two var pattern getter setter success-k fail-k (ids ...))
-;;
-;; usually abbreviated
-;;
-;;   (match-two v p g+s sk fk i)
-;;
-;; where VAR is the symbol name of the current variable we are
-;; matching, PATTERN is the current pattern, getter and setter are the
-;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
-;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
-;; continuation (which is just a thunk call and is thus safe to expand
-;; multiple times) and IDS are the list of identifiers bound in the
-;; pattern so far.
-
-(define-syntax match-two
-  (syntax-rules (_ ___ ..1 *** quote quasiquote ? $ = and or not set! get!)
-    ((match-two v () g+s (sk ...) fk i)
-     (if (null? v) (sk ... i) fk))
-    ((match-two v (quote p) g+s (sk ...) fk i)
-     (if (equal? v 'p) (sk ... i) fk))
-    ((match-two v (quasiquote p) . x)
-     (match-quasiquote v p . x))
-    ((match-two v (and) g+s (sk ...) fk i) (sk ... i))
-    ((match-two v (and p q ...) g+s sk fk i)
-     (match-one v p g+s (match-one v (and q ...) g+s sk fk) fk i))
-    ((match-two v (or) g+s sk fk i) fk)
-    ((match-two v (or p) . x)
-     (match-one v p . x))
-    ((match-two v (or p ...) g+s sk fk i)
-     (match-extract-vars (or p ...) (match-gen-or v (p ...) g+s sk fk i) i ()))
-    ((match-two v (not p) g+s (sk ...) fk i)
-     (match-one v p g+s (match-drop-ids fk) (sk ... i) i))
-    ((match-two v (get! getter) (g s) (sk ...) fk i)
-     (let ((getter (lambda () g))) (sk ... i)))
-    ((match-two v (set! setter) (g (s ...)) (sk ...) fk i)
-     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
-    ((match-two v (? pred . p) g+s sk fk i)
-     (if (pred v) (match-one v (and . p) g+s sk fk i) fk))
-    ((match-two v (= proc p) . x)
-     (let ((w (proc v))) (match-one w p . x))
-     ;;(let ((W (proc v))) (match-one W p . x))
-     )
-    ((match-two v (p ___ . r) g+s sk fk i)
-     (match-extract-vars p (match-gen-ellipses v p r g+s sk fk i) i ()))
-    ((match-two v (p) g+s sk fk i)
-     (if (and (pair? v) (null? (cdr v)))
-         (let ;;((w (car v)))
-             ((W (car v)))
-           ;;(match-one w p ((car v) (set-car! v)) sk fk i)
-           (match-one W p ((car v) (set-car! v)) sk fk i)
-           )
-         fk))
-    ((match-two v (p *** q) g+s sk fk i)
-     (match-extract-vars p (match-gen-search v p q g+s sk fk i) i ()))
-    ((match-two v (p *** . q) g+s sk fk i)
-     (match-syntax-error "invalid use of ***" (p *** . q)))
-    ((match-two v (p ..1) g+s sk fk i)
-     (if (pair? v)
-         (match-one v (p ___) g+s sk fk i)
-         fk))
-    ((match-two v ($ rec p ...) g+s sk fk i)
-     (if (is-a? v rec)
-         (match-record-refs v rec 0 (p ...) g+s sk fk i)
-         fk))
-    ((match-two v (p . q) g+s sk fk i)
-     (if (pair? v)
-         (let ;;((w (car v)) (x (cdr v)))
-             ((W (car v)) (X (cdr v)))
-           (match-one ;;w p ((car v) (set-car! v))
-                      W p ((car v) (set-car! v))
-                      ;;(match-one x q ((cdr v) (set-cdr! v)) sk fk)
-                      (match-one X q ((cdr v) (set-cdr! v)) sk fk)
-                      fk
-                      i))
-         fk))
-    ((match-two v #(p ...) g+s . x)
-     (match-vector v 0 () (p ...) . x))
-    ((match-two v _ g+s (sk ...) fk i) (sk ... i))
-    ;; Not a pair or vector or special literal, test to see if it's a
-    ;; new symbol, in which case we just bind it, or if it's an
-    ;; already bound symbol or some other literal, in which case we
-    ;; compare it with EQUAL?.
-    (;;(match-two v x g+s (sk ...) fk (id ...))
-     (match-two V X g+s (sk ...) fk (id ...))
-     (let-syntax
-         ((new-sym?
-           (syntax-rules (id ...)
-             ;;((new-sym? x sk2 fk2) sk2)
-             ((new-sym? X sk2 fk2) sk2)
-             ((new-sym? y sk2 fk2) fk2))))
-       (new-sym? random-sym-to-match
-                 ;;(let ((x v)) (sk ... (id ... x)))
-                 (let ((X V)) (sk ... (id ... X)))
-                 ;;(if (equal? v x) (sk ... (id ...)) fk)
-                 (if (equal? V X) (sk ... (id ...)) fk)
-                 )))
-    ))
-
-;; QUASIQUOTE patterns
-
-(define-syntax match-quasiquote
-  (syntax-rules (unquote unquote-splicing quasiquote)
-    ((_ v (unquote p) g+s sk fk i)
-     (match-one v p g+s sk fk i))
-    ((_ v ((unquote-splicing p) . rest) g+s sk fk i)
-     (if (pair? v)
-       (match-one v
-                  (p . tmp)
-                  (match-quasiquote tmp rest g+s sk fk)
-                  fk
-                  i)
-       fk))
-    ((_ v (quasiquote p) g+s sk fk i . depth)
-     (match-quasiquote v p g+s sk fk i #f . depth))
-    ((_ v (unquote p) g+s sk fk i x . depth)
-     (match-quasiquote v p g+s sk fk i . depth))
-    ((_ v (unquote-splicing p) g+s sk fk i x . depth)
-     (match-quasiquote v p g+s sk fk i . depth))
-    ((_ v (p . q) g+s sk fk i . depth)
-     (if (pair? v)
-         (let ;;((w (car v)) (x (cdr v)))
-             ((W (car v)) (X (cdr v)))
-         (match-quasiquote
-          ;;w p g+s
-          W p g+s
-          ;;(match-quasiquote-step x q g+s sk fk depth)
-          (match-quasiquote-step X q g+s sk fk depth)
-          fk i . depth))
-       fk))
-    ((_ v #(elt ...) g+s sk fk i . depth)
-     (if (vector? v)
-         (let ((ls (vector->list v)))
-           (match-quasiquote ls (elt ...) g+s sk fk i . depth))
-       fk))
-    ((_ v x g+s sk fk i . depth)
-     (match-one v 'x g+s sk fk i))))
-
-(define-syntax match-quasiquote-step
-  (syntax-rules ()
-    ((match-quasiquote-step x q g+s sk fk depth i)
-     (match-quasiquote x q g+s sk fk i . depth))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Utilities
-
-;; Takes two values and just expands into the first.
-(define-syntax match-drop-ids
-  (syntax-rules ()
-    ((_ expr ids ...) expr)))
-
-(define-syntax match-tuck-ids
-  (syntax-rules ()
-    ((_ (letish args (expr ...)) ids ...)
-     (letish args (expr ... ids ...)))))
-
-(define-syntax match-drop-first-arg
-  (syntax-rules ()
-    ((_ arg expr) expr)))
-
-;; To expand an OR group we try each clause in succession, passing the
-;; first that succeeds to the success continuation.  On failure for
-;; any clause, we just try the next clause, finally resorting to the
-;; failure continuation fk if all clauses fail.  The only trick is
-;; that we want to unify the identifiers, so that the success
-;; continuation can refer to a variable from any of the OR clauses.
-
-(define-syntax match-gen-or
-  (syntax-rules ()
-    ((_ v p g+s (sk ...) fk (i ...) ((id id-ls) ...))
-     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
-       (match-gen-or-step v p g+s (match-drop-ids (sk2 id ...)) fk (i ...))))))
-
-(define-syntax match-gen-or-step
-  (syntax-rules ()
-    ((_ v () g+s sk fk . x)
-     ;; no OR clauses, call the failure continuation
-     fk)
-    ((_ v (p) . x)
-     ;; last (or only) OR clause, just expand normally
-     (match-one v p . x))
-    ((_ v (p . q) g+s sk fk i)
-     ;; match one and try the remaining on failure
-     (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i))))
-       (match-one v p g+s sk (fk2) i)))
-    ))
-
-;; We match a pattern (p ...) by matching the pattern p in a loop on
-;; each element of the variable, accumulating the bound ids into lists.
-
-;; Look at the body of the simple case - it's just a named let loop,
-;; matching each element in turn to the same pattern.  The only trick
-;; is that we want to keep track of the lists of each extracted id, so
-;; when the loop recurses we cons the ids onto their respective list
-;; variables, and on success we bind the ids (what the user input and
-;; expects to see in the success body) to the reversed accumulated
-;; list IDs.
-
-(define-syntax match-gen-ellipses
-  (syntax-rules ()
-    (;;(_ v p () g+s (sk ...) fk i ((id id-ls) ...))
-     (_ v P () g+s (sk ...) fk i ((id id-ls) ...))
-     (match-check-identifier
-      ;;p
-      P
-      ;; simplest case equivalent to (p ...), just bind the list
-      (let ;;((p v))
-          ((P v))
-        (if ;;(list? p)
-         (list? P)
-             (sk ... i)
-             fk))
-       ;; simple case, match all elements of the list
-       (let loop ((ls v) (id-ls '()) ...)
-         (cond
-           ((null? ls)
-            (let ((id (reverse id-ls)) ...) (sk ... i)))
-           ((pair? ls)
-            (let ;;((w (car ls)))
-                ((W (car ls)))
-              (match-one ;;w p ((car ls) (set-car! ls))
-                         W p ((car ls) (set-car! ls))
-                         (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
-                         fk i)))
-           (else
-            fk)))))
-    ((_ v p r g+s (sk ...) fk i ((id id-ls) ...))
-     ;; general case, trailing patterns to match, keep track of the
-     ;; remaining list length so we don't need any backtracking
-     (match-verify-no-ellipses
-      r
-      (let* ((tail-len (length 'r))
-             (ls v)
-             (len (and (list? ls) (length ls))))
-        (if (or (not len) (< len tail-len))
-            fk
-            (let loop ((ls ls) (n len) (id-ls '()) ...)
-              (cond
-                ((= n tail-len)
-                 (let ((id (reverse id-ls)) ...)
-                   (match-one ls r (#f #f) (sk ...) fk i)))
-                ((pair? ls)
-                 (let ((w (car ls)))
-                   (match-one w p ((car ls) (set-car! ls))
-                              (match-drop-ids
-                               (loop (cdr ls) (- n 1) (cons id id-ls) ...))
-                              fk
-                              i)))
-                (else
-                 fk)))))))))
-
-;; This is just a safety check.  Although unlike syntax-rules we allow
-;; trailing patterns after an ellipses, we explicitly disable multiple
-;; ellipses at the same level.  This is because in the general case
-;; such patterns are exponential in the number of ellipses, and we
-;; don't want to make it easy to construct very expensive operations
-;; with simple looking patterns.  For example, it would be O(n^2) for
-;; patterns like (a ... b ...) because we must consider every trailing
-;; element for every possible break for the leading "a ...".
-
-(define-syntax match-verify-no-ellipses
-  (syntax-rules ()
-    ((_ (x . y) sk)
-     (match-check-ellipse
-      x
-      (match-syntax-error
-       "multiple ellipse patterns not allowed at same level")
-      (match-verify-no-ellipses y sk)))
-    ((_ () sk)
-     sk)
-    ((_ x sk)
-     (match-syntax-error "dotted tail not allowed after ellipse" x))))
-
-;; To implement the tree search, we use two recursive procedures.  TRY
-;; attempts to match Y once, and on success it calls the normal SK on
-;; the accumulated list ids as in MATCH-GEN-ELLIPSES.  On failure, we
-;; call NEXT which first checks if the current value is a list
-;; beginning with X, then calls TRY on each remaining element of the
-;; list.  Since TRY will recursively call NEXT again on failure, this
-;; effects a full depth-first search.
-;;
-;; The failure continuation throughout is a jump to the next step in
-;; the tree search, initialized with the original failure continuation
-;; FK.
-
-(define-syntax match-gen-search
-  (syntax-rules ()
-    ((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
-     (letrec ((try (lambda (w fail id-ls ...)
-                     (match-one w q g+s
-                                (match-tuck-ids
-                                 (let ((id (reverse id-ls)) ...)
-                                   sk))
-                                (next w fail id-ls ...) i)))
-              (next (lambda (w fail id-ls ...)
-                      (if (not (pair? w))
-                          (fail)
-                          (let ((u (car w)))
-                            (match-one
-                             u p ((car w) (set-car! w))
-                             (match-drop-ids
-                              ;; accumulate the head variables from
-                              ;; the p pattern, and loop over the tail
-                              (let ((id-ls (cons id id-ls)) ...)
-                                (let lp ((ls (cdr w)))
-                                  (if (pair? ls)
-                                      (try (car ls)
-                                           (lambda () (lp (cdr ls)))
-                                           id-ls ...)
-                                      (fail)))))
-                             (fail) i))))))
-       ;; the initial id-ls binding here is a dummy to get the right
-       ;; number of '()s
-       (let ((id-ls '()) ...)
-         (try v (lambda () fk) id-ls ...))))))
-
-;; Vector patterns are just more of the same, with the slight
-;; exception that we pass around the current vector index being
-;; matched.
-
-(define-syntax match-vector
-  (syntax-rules (___)
-    ((_ v n pats (p q) . x)
-     (match-check-ellipse q
-                          (match-gen-vector-ellipses v n pats p . x)
-                          (match-vector-two v n pats (p q) . x)))
-    ((_ v n pats (p ___) sk fk i)
-     (match-gen-vector-ellipses v n pats p sk fk i))
-    ((_ . x)
-     (match-vector-two . x))))
-
-;; Check the exact vector length, then check each element in turn.
-
-(define-syntax match-vector-two
-  (syntax-rules ()
-    ((_ v n ((pat index) ...) () sk fk i)
-     (if (vector? v)
-         (let ((len (vector-length v)))
-           (if (= len n)
-               (match-vector-step v ((pat index) ...) sk fk i)
-               fk))
-         fk))
-    ((_ v n (pats ...) (p . q) . x)
-     (match-vector v (+ n 1) (pats ... (p n)) q . x))))
-
-(define-syntax match-vector-step
-  (syntax-rules ()
-    ((_ v () (sk ...) fk i) (sk ... i))
-    ((_ v ((pat index) . rest) sk fk i)
-     (let ((w (vector-ref v index)))
-       (match-one w pat ((vector-ref v index) (vector-set! v index))
-                  (match-vector-step v rest sk fk)
-                  fk i)))))
-
-;; With a vector ellipse pattern we first check to see if the vector
-;; length is at least the required length.
-
-(define-syntax match-gen-vector-ellipses
-  (syntax-rules ()
-    ((_ v n ((pat index) ...) p sk fk i)
-     (if (vector? v)
-       (let ((len (vector-length v)))
-         (if (>= len n)
-           (match-vector-step v ((pat index) ...)
-                              (match-vector-tail v p n len sk fk)
-                              fk i)
-           fk))
-       fk))))
-
-(define-syntax match-vector-tail
-  (syntax-rules ()
-    ((_ v p n len sk fk i)
-     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
-
-(define-syntax match-vector-tail-two
-  (syntax-rules ()
-    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
-     (let loop ((j n) (id-ls '()) ...)
-       (if (>= j len)
-         (let ((id (reverse id-ls)) ...) (sk ... i))
-         (let ((w (vector-ref v j)))
-           (match-one w p ((vector-ref v j) (vetor-set! v j))
-                      (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
-                      fk i)))))))
-
-(define-syntax match-record-refs
-  (syntax-rules ()
-    ((_ v rec n (p . q) g+s sk fk i)
-     (let ((w (slot-ref rec v n)))
-       (match-one w p ((slot-ref rec v n) (slot-set! rec v n))
-                  (match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
-    ((_ v rec n () g+s (sk ...) fk i)
-     (sk ... i))))
-
-;; Extract all identifiers in a pattern.  A little more complicated
-;; than just looking for symbols, we need to ignore special keywords
-;; and non-pattern forms (such as the predicate expression in ?
-;; patterns), and also ignore previously bound identifiers.
-;;
-;; Calls the continuation with all new vars as a list of the form
-;; ((orig-var tmp-name) ...), where tmp-name can be used to uniquely
-;; pair with the original variable (e.g. it's used in the ellipse
-;; generation for list variables).
-;;
-;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
-
-(define-syntax match-extract-vars
-  (syntax-rules (_ ___ ..1 *** ? $ = quote quasiquote and or not get! set!)
-    ((match-extract-vars (? pred . p) . x)
-     (match-extract-vars p . x))
-    ((match-extract-vars ($ rec . p) . x)
-     (match-extract-vars p . x))
-    ((match-extract-vars (= proc p) . x)
-     (match-extract-vars p . x))
-    ((match-extract-vars (quote x) (k ...) i v)
-     (k ... v))
-    ((match-extract-vars (quasiquote x) k i v)
-     (match-extract-quasiquote-vars x k i v (#t)))
-    ((match-extract-vars (and . p) . x)
-     (match-extract-vars p . x))
-    ((match-extract-vars (or . p) . x)
-     (match-extract-vars p . x))
-    ((match-extract-vars (not . p) . x)
-     (match-extract-vars p . x))
-    ;; A non-keyword pair, expand the CAR with a continuation to
-    ;; expand the CDR.
-    ((match-extract-vars (p q . r) k i v)
-     (match-check-ellipse
-      q
-      (match-extract-vars (p . r) k i v)
-      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
-    ((match-extract-vars (p . q) k i v)
-     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
-    ((match-extract-vars #(p ...) . x)
-     (match-extract-vars (p ...) . x))
-    ((match-extract-vars _ (k ...) i v)    (k ... v))
-    ((match-extract-vars ___ (k ...) i v)  (k ... v))
-    ((match-extract-vars *** (k ...) i v)  (k ... v))
-    ((match-extract-vars ..1 (k ...) i v)  (k ... v))
-    ;; This is the main part, the only place where we might add a new
-    ;; var if it's an unbound symbol.
-    ((match-extract-vars p (k ...) (i ...) v)
-     (let-syntax
-         ((new-sym?
-           (syntax-rules (i ...)
-             ((new-sym? p sk fk) sk)
-             ((new-sym? any sk fk) fk))))
-       (new-sym? random-sym-to-match
-                 (k ... ((p p-ls) . v))
-                 (k ... v))))
-    ))
-
-;; Stepper used in the above so it can expand the CAR and CDR
-;; separately.
-
-(define-syntax match-extract-vars-step
-  (syntax-rules ()
-    ((_ p k i v ((v2 v2-ls) ...))
-     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
-    ))
-
-(define-syntax match-extract-quasiquote-vars
-  (syntax-rules (quasiquote unquote unquote-splicing)
-    ((match-extract-quasiquote-vars (quasiquote x) k i v d)
-     (match-extract-quasiquote-vars x k i v (#t . d)))
-    ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
-     (match-extract-quasiquote-vars (unquote x) k i v d))
-    ((match-extract-quasiquote-vars (unquote x) k i v (#t))
-     (match-extract-vars x k i v))
-    ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
-     (match-extract-quasiquote-vars x k i v d))
-    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
-     (match-extract-quasiquote-vars
-      x
-      (match-extract-quasiquote-vars-step y k i v d) i ()))
-    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
-     (match-extract-quasiquote-vars (x ...) k i v d))
-    ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
-     (k ... v))
-    ))
-
-(define-syntax match-extract-quasiquote-vars-step
-  (syntax-rules ()
-    ((_ x k i v d ((v2 v2-ls) ...))
-     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
-    ))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Gimme some sugar baby.
-
-;;> Shortcut for @scheme{lambda} + @scheme{match}.  Creates a
-;;> procedure of one argument, and matches that argument against each
-;;> clause.
-
-(define-syntax match-lambda
-  (syntax-rules ()
-    ((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...)))))
-
-;;> Similar to @scheme{match-lambda}.  Creates a procedure of any
-;;> number of arguments, and matches the argument list against each
-;;> clause.
-
-(define-syntax match-lambda*
-  (syntax-rules ()
-    ((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...)))))
-
-;;> Matches each var to the corresponding expression, and evaluates
-;;> the body with all match variables in scope.  Raises an error if
-;;> any of the expressions fail to match.  Syntax analogous to named
-;;> let can also be used for recursive functions which match on their
-;;> arguments as in @scheme{match-lambda*}.
-
-(define-syntax match-let
-  (syntax-rules ()
-    ((_ ((var value) ...) . body)
-     (match-let/helper let () () ((var value) ...) . body))
-    ((_ loop ((var init) ...) . body)
-     (match-named-let loop ((var init) ...) . body))))
-
-;;> Similar to @scheme{match-let}, but analogously to @scheme{letrec}
-;;> matches and binds the variables with all match variables in scope.
-
-(define-syntax match-letrec
-  (syntax-rules ()
-    ((_ ((var value) ...) . body)
-     (match-let/helper letrec () () ((var value) ...) . body))))
-
-(define-syntax match-let/helper
-  (syntax-rules ()
-    ((_ let ((var expr) ...) () () . body)
-     (let ((var expr) ...) . body))
-    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
-     (let ((var expr) ...)
-       (match-let* ((pat tmp) ...)
-         . body)))
-    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
-     (match-let/helper
-      let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
-    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
-     (match-let/helper
-      let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
-    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
-     (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
-
-(define-syntax match-named-let
-  (syntax-rules ()
-    ((_ loop ((pat expr var) ...) () . body)
-     (let loop ((var expr) ...)
-       (match-let ((pat var) ...)
-         . body)))
-    ((_ loop (v ...) ((pat expr) . rest) . body)
-     (match-named-let loop (v ... (pat expr tmp)) rest . body))))
-
-;;> @subsubsubsection{@rawcode{(match-let* ((var value) ...) body ...)}}
-
-;;> Similar to @scheme{match-let}, but analogously to @scheme{let*}
-;;> matches and binds the variables in sequence, with preceding match
-;;> variables in scope.
-
-(define-syntax match-let*
-  (syntax-rules ()
-    ((_ () . body)
-     (begin . body))
-    ((_ ((pat expr) . rest) . body)
-     (match expr (pat (match-let* rest . body))))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Otherwise COND-EXPANDed bits.
-
-;; This *should* work, but doesn't :(
-;;   (define-syntax match-check-ellipse
-;;     (syntax-rules (...)
-;;       ((_ ... sk fk) sk)
-;;       ((_ x sk fk) fk)))
-
-;; This is a little more complicated, and introduces a new let-syntax,
-;; but should work portably in any R[56]RS Scheme.  Taylor Campbell
-;; originally came up with the idea.
-(define-syntax match-check-ellipse
-  (syntax-rules ()
-    ;; these two aren't necessary but provide fast-case failures
-    ((match-check-ellipse (a . b) success-k failure-k) failure-k)
-    ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
-    ;; matching an atom
-    ((match-check-ellipse id success-k failure-k)
-     (let-syntax ((ellipse? (syntax-rules ()
-                              ;; iff `id' is `...' here then this will
-                              ;; match a list of any length
-                              ((ellipse? (foo id) sk fk) sk)
-                              ((ellipse? other sk fk) fk))))
-       ;; this list of three elements will only many the (foo id) list
-       ;; above if `id' is `...'
-       (ellipse? (a b c) success-k failure-k)))))
-
-;; This is portable but can be more efficient with non-portable
-;; extensions.  This trick was originally discovered by Oleg Kiselyov.
-
-(define-syntax match-check-identifier
-  (syntax-rules ()
-    ;; fast-case failures, lists and vectors are not identifiers
-    ((_ (x . y) success-k failure-k) failure-k)
-    ((_ #(x ...) success-k failure-k) failure-k)
-    ;; x is an atom
-    ((_ x success-k failure-k)
-     (let-syntax
-         ((sym?
-           (syntax-rules ()
-             ;; if the symbol `abracadabra' matches x, then x is a
-             ;; symbol
-             ((sym? x sk fk) sk)
-             ;; otherwise x is a non-symbol datum
-             ((sym? y sk fk) fk))))
-       (sym? abracadabra success-k failure-k)))))
diff --git a/lib/record.mes b/lib/record.mes
deleted file mode 100644 (file)
index aca0586..0000000
+++ /dev/null
@@ -1,6 +0,0 @@
-(define (unspecific) (if #f #f))
-(define make-record make-vector)
-(define record-set! vector-set!)
-(define record? vector?)
-(define (record-type x) (vector-ref x 0))
-(define record-ref vector-ref)
diff --git a/lib/record.scm b/lib/record.scm
deleted file mode 100644 (file)
index 92a047f..0000000
+++ /dev/null
@@ -1,203 +0,0 @@
-; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-;;;; Records
-
-; Every record in the image is assumed to be made either by MAKE-RECORD-TYPE
-; or by a procedure returned by record-constructor.  A record-type is a
-; record that describes a type of record.  At the end of the file we create
-; a record type that describes record types.
-
-; We number the record types for debugging purposes.
-
-(define *record-type-uid* -1)
-
-; This is the record type that describes record types.  It is set a the end
-; of the file.  Its first slot points to itself.
-
-(define *record-type* #f)
-
-; Make a record type from a name, used for printing and debugging, and
-; a list of field names.
-;
-; The VM references both the record type and the resumer, so their offsets
-; should not be changed.
-
-(define (make-record-type name field-names)
-  (set! *record-type-uid* (+ *record-type-uid* 1))
-  (let ((r (make-record 7 (unspecific))))
-    (record-set! r 0 *record-type*)
-    (record-set! r 1 default-record-resumer)
-    (record-set! r 2 *record-type-uid*)
-    (record-set! r 3 name)
-    (record-set! r 4 field-names)
-    (record-set! r 5 (length field-names))
-    (record-set! r 6 (make-default-record-discloser name))
-    r))
-
-(define (record-type? obj)
-  (and (record? obj)
-       (eq? (record-type obj) *record-type*)))
-
-; The various fields in a record type.
-
-(define (record-type-resumer rt)          (record-ref rt 1))
-(define (set-record-type-resumer! rt r)   (record-set! rt 1 r))
-(define (record-type-uid rt)              (record-ref rt 2))
-(define (record-type-name rt)             (record-ref rt 3))
-(define (record-type-field-names rt)      (record-ref rt 4))
-(define (record-type-number-of-fields rt) (record-ref rt 5))
-(define (record-type-discloser rt)        (record-ref rt 6))
-(define (set-record-type-discloser! rt d) (record-set! rt 6 d))
-
-; This is a hack; it is read by the script that makes c/scheme48.h.
-
-(define record-type-fields
-  '(resumer uid name field-names number-of-fields discloser))
-
-;----------------
-; Given a record type and the name of a field, return the field's index.
-
-(define (record-field-index rt name)
-  (let loop ((names (record-type-field-names rt))
-             (i 1))
-    (cond ((null? names)
-           (error "unknown field"
-                  (record-type-name rt)
-                  name))
-          ((eq? name (car names))
-           i)
-          (else
-           (loop (cdr names) (+ i 1))))))
-
-; Return procedure for contstruction records of type RT.  NAMES is a list of
-; field names which the constructor will take as arguments.  Other fields are
-; uninitialized.
-
-(define (record-constructor rt names)
-  (let ((indexes (map (lambda (name)
-                        (record-field-index rt name))
-                      names))
-        (size (+ 1 (record-type-number-of-fields rt))))
-    (lambda args
-      (let ((r (make-record size (unspecific))))
-        (record-set! r 0 rt)
-        (let loop ((is indexes) (as args))
-          (if (null? as)
-              (if (null? is)
-                  r
-                  (error "too few arguments to record constructor"
-                         rt names args))
-              (if (null? is)
-                  (error "too many arguments to record constructor"
-                         rt names args)
-                  (begin (record-set! r (car is) (car as))
-                         (loop (cdr is) (cdr as))))))))))
-
-; Making accessors, modifiers, and predicates for record types.
-
-(define (record-accessor rt name)
-  (let ((index (record-field-index rt name))
-        (error-cruft `(record-accessor ,rt ',name)))
-    (lambda (r)
-      (if (eq? (record-type r) rt)
-          (record-ref r index)
-          (call-error "invalid record access" error-cruft r)))))
-
-(define (record-modifier rt name)
-  (let ((index (record-field-index rt name))
-        (error-cruft `(record-modifier ,rt ',name)))
-    (lambda (r x)
-      (if (eq? (record-type r) rt)
-          (record-set! r index x)
-          (call-error "invalid record modification" error-cruft r x)))))
-
-(define (record-predicate rt)
-  (lambda (x)
-    (and (record? x)
-         (eq? (record-type x) rt))))
-
-;----------------
-; A discloser is a procedure that takes a record of a particular type and
-; returns a list whose head is a string or symbol and whose tail is other
-; stuff.
-;
-; Set the discloser for record type RT.
-
-(define (define-record-discloser rt proc)
-  (if (and (record-type? rt)
-           (procedure? proc))
-      (set-record-type-discloser! rt proc)
-      (call-error "invalid argument" define-record-discloser rt proc)))
-
-; By default we just return the name of the record type.
-
-(define (make-default-record-discloser record-type-name)
-  (lambda (r)
-    (list record-type-name)))
-
-; DISCLOSE-RECORD calls the record's discloser procedure to obtain a list.
-
-(define (disclose-record r)
-  (if (record? r)
-      (let ((rt (record-type r)))
-        (if (record-type? rt)
-            ((record-type-discloser rt) r)
-            #f))
-      #f))
-
-;----------------
-; A resumer is a procedure that the VM calls on all records of a given
-; type on startup.
-;
-; A resumer may be:
-;  #t -> do nothing on startup.
-;  #f -> records of this type do not survive a dump/resume; in images they
-;        are replaced by their first slot (so we make sure they have one)
-;  a one-argument procedure -> pass the record to this procedure
-;
-; Resumers are primarily intended for use by external code which keeps
-; fields in records which do not survive a dump under their own power.
-; For example, a record may contain a reference to a OS-dependent value.
-;
-; Resumers are called by the VM on startup.
-
-(define (define-record-resumer rt resumer)
-  (if (and (record-type? rt)
-           (or (eq? #t resumer)
-               (and (eq? #f resumer)
-                    (< 0 (record-type-number-of-fields rt)))
-               (procedure? resumer)))
-      (set-record-type-resumer! rt resumer)
-      (call-error "invalid argument" define-record-resumer rt resumer)))
-
-; By default we leave records alone.
-
-(define default-record-resumer
-  #t)
-
-(define (initialize-records! resumer-records)
-  (if (vector? resumer-records)
-      (do ((i 0 (+ i 1)))
-          ((= i (vector-length resumer-records)))
-        (resume-record (vector-ref resumer-records i)))))
-
-(define (resume-record record)
-  ((record-type-resumer (record-type record))
-     record))
-
-;----------------
-; Initializing *RECORD-TYPE* and making a type.
-
-(set! *record-type*
-      (make-record-type 'record-type record-type-fields))
-
-(record-set! *record-type* 0 *record-type*)
-
-(define :record-type *record-type*)
-
-(define-record-discloser :record-type
-  (lambda (rt)
-    (list 'record-type
-          (record-type-uid rt)
-          (record-type-name rt))))
-
diff --git a/lib/rnrs/bytevectors.scm b/lib/rnrs/bytevectors.scm
deleted file mode 100644 (file)
index dce1ed8..0000000
+++ /dev/null
@@ -1,22 +0,0 @@
-;; rnrs compatibility
-(define (bytevector-u32-native-set! bv index value)
-  (when (not (= 0 index)) (error "bytevector-u32-native-set! index not zero: " index " value: " value))
-  (let ((x (list
-            (modulo value #x100)
-            (quotient (modulo value #x10000) #x100)
-            (quotient (modulo value #x1000000) #x10000)
-            (quotient value #x1000000))))
-    (set-car! bv (car x))
-    (set-cdr! bv (cdr x))
-    x))
-
-(define (bytevector-u16-native-set! bv index value)
-  (when (not (= 0 index)) (error "bytevector-u16-native-set! index not zero: " index " value: " value))
-  (let ((x (list (modulo value #x100)
-                 (quotient (modulo value #x10000) #x100))))
-    (set-car! bv (car x))
-    (set-cdr! bv (cdr x))
-    x))
-
-(define (make-bytevector length)
-  (make-list length 0))
diff --git a/lib/srfi/srfi-0.scm b/lib/srfi/srfi-0.scm
deleted file mode 100644 (file)
index be71317..0000000
+++ /dev/null
@@ -1,13 +0,0 @@
-(define mes '(0 1))
-
-(define-macro (defined? x)
-  `(assq ,x (cddr (current-module))))
-
-(define (cond-expand-expander clauses)
-  (let loop ((clauses clauses))
-    (if (defined? (caar clauses))
-        (eval (cons 'begin (cdar clauses)) (current-module))
-        (loop (cdr clauses)))))
-
-(define-macro (cond-expand . clauses)
-  `(cond-expand-expander (quote ,clauses)))
diff --git a/lib/srfi/srfi-1.scm b/lib/srfi/srfi-1.scm
deleted file mode 100644 (file)
index 8bc8d83..0000000
+++ /dev/null
@@ -1,15 +0,0 @@
-(define (find pred lst)
-  (let loop ((lst lst))
-    (if (null? lst) #f
-        (if (pred (car lst)) (car lst)
-            (loop (cdr lst))))))
-
-(define (filter pred lst)
-  (let loop ((lst lst))
-    (if (null? lst) '()
-        (if (pred (car lst))
-            (cons (car lst) (loop (cdr lst)))
-            (loop (cdr lst))))))
-
-(define (append-map f lst)
-  (apply append (map f lst)))
diff --git a/lib/srfi/srfi-9.scm b/lib/srfi/srfi-9.scm
deleted file mode 100644 (file)
index 43fc45f..0000000
+++ /dev/null
@@ -1,44 +0,0 @@
-;; Copyright (c) 1993 by Richard Kelsey and Jonathan Rees.  See file COPYING.
-
-;; There's no implicit name concatenation, so it can be defined
-;; entirely using syntax-rules.  Example:
-;;  (define-record-type foo
-;;    (make-foo x y)
-;;    foo?              - predicate name is optional
-;;    (x foo-x)
-;;    (y foo-y)
-;;    (z foo-z set-foo-z!))
-
-;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
-
-(define-syntax define-record-type
-  (syntax-rules ()
-    ((define-record-type type
-       (constructor arg ...)
-       (field . field-stuff)
-       ...)
-     (begin (define type (make-record-type 'type '(field ...)))
-            (define constructor (record-constructor type '(arg ...)))
-            (define-accessors type (field . field-stuff) ...)))
-    ((define-record-type type
-       (constructor arg ...)
-       pred
-       more ...)
-     (begin (define-record-type type
-              (constructor arg ...)
-              more ...)
-            (define pred (record-predicate type))))))
-
-;; Straightforward version
-(define-syntax define-accessors
-  (syntax-rules ()
-    ((define-accessors type field-spec ...)
-     (begin (define-accessor type . field-spec) ...))))
-
-(define-syntax define-accessor
-  (syntax-rules ()
-    ((define-accessor type field accessor)
-     (define accessor (record-accessor type 'field)))
-    ((define-accessor type field accessor modifier)
-     (begin (define accessor (record-accessor type 'field))
-            (define modifier (record-modifier type 'field))))))
diff --git a/lib/test.mes b/lib/test.mes
deleted file mode 100644 (file)
index e39cf2d..0000000
+++ /dev/null
@@ -1,71 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; test.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-(define guile? (not (pair? (current-module))))
-
-(define result
-  (let ((pass 0)
-        (fail 0))
-    (lambda (. t)
-      (cond ((or (null? t) (eq? (car t) result)) (list pass fail))
-            ((eq? (car t) 'report)
-             (newline)
-             (display "passed: ") (display pass) (newline)
-             (display "failed: ") (display fail) (newline)
-             (display "total: ") (display (+ pass fail)) (newline)
-             (exit fail))
-            ((car t) (display ": pass") (newline) (set! pass (+ pass 1)))
-            (#t (display ": fail") (newline) (set! fail (+ fail 1)))))))
-
-(define (seq? a b)
-  (or (eq? a b)
-      (begin
-        (display ": fail")
-        (newline)
-        (display "expected: ")
-        (display b) (newline)
-        (display "actual: ")
-        (display a)
-        (newline)
-        #f)))
-
-(define (sequal? a b)
-  (or (equal? a b)
-      (begin
-        (display ": fail")
-        (newline)
-        (display "expected: ")
-        (display b) (newline)
-        (display "actual: ")
-        (display a)
-        (newline)
-        #f)))
-
-(define-macro (pass-if name t)
-  (list
-   'begin
-   (list display "test: ") (list display name)
-   (list result t)))
-
-(define-macro (pass-if-not name f)
-  (list
-   'begin
-   (list display "test: ") (list display name)
-   (list result (list not f))))
diff --git a/loop2.mes b/loop2.mes
deleted file mode 100644 (file)
index b73fd80..0000000
--- a/loop2.mes
+++ /dev/null
@@ -1,53 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; loop.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;; The Maxwell Equations of Software -- John McCarthy page 13
-;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
-
-(define (scm-define x a)
-  (cond ((atom? (cadr x)) (cons (cadr x) (eval (caddr x) a)))
-        (#t (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))))
-
-(define (scm-define-macro x a)
-  (cons '*macro*
-        (cons (cons (caadr e) (cons 'lambda (cons (cdadr e) (cddr e))))
-              (cdr (assq '*macro* a)))))
-
-(define (loop2 r e a)
-  ;; (display '____loop2)
-  ;; (newline)
-  ;; (display 'e:)
-  ;; (display e)  
-  ;; (newline)
-  (cond ((null? e) r)
-        ((eq? e 'EOF2)
-         (display 'loop2-exiting...)
-         (newline))
-        ((atom? e)
-         (loop2 (eval e a) (readenv a) a))
-        ((eq? (car e) 'define)
-         (loop2 *unspecified* (readenv a) (cons (scm-define e a) a)))
-        ((eq? (car e) 'define-macro)
-         (loop2 *unspecified* (readenv a) (cons (scm-define-macro e a) a)))
-        ((eq? (car e) 'set!)
-         (loop2 (set-cdr! (assq (cadr e) a) (eval (caddr e) a)) (readenv a) a))
-        (#t (loop2 (eval e a) (readenv a) a))))
-
-'EOF
diff --git a/main.c b/main.c
deleted file mode 100644 (file)
index 929df2b..0000000
--- a/main.c
+++ /dev/null
@@ -1,8 +0,0 @@
-int main ()
-{
-  int i; // = 0;
-  puts ("Hi Mes!\n");
-  for (i = 0; i < 4; ++i)
-    puts ("  Hello, world!\n");
-  return 1;
-}
diff --git a/mes.mes b/mes.mes
deleted file mode 100644 (file)
index bb56be8..0000000
--- a/mes.mes
+++ /dev/null
@@ -1,232 +0,0 @@
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; mes.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;; The Maxwell Equations of Software -- John McCarthy page 13
-;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
-
-;; (define (caar x) (car (car x)))
-;; (define (cadr x) (car (cdr x)))
-;; (define (cdar x) (cdr (car x)))
-;; (define (cddr x) (cdr (cdr x)))
-;; (define (caadr x) (car (car (cdr x))))
-;; (define (caddr x) (car (cdr (cdr x))))
-;; (define (cddar x) (cdr (cdr (car x))))
-;; (define (cdadr x) (cdr (car (cdr x))))
-;; (define (cadar x) (car (cdr (car x))))
-;; (define (cdddr x) (cdr (cdr (cdr x))))
-
-;; ;; Page 12
-;; (define (pairlis x y a)
-;;   ;;(debug "pairlis x=~a y=~a a=~a\n" x y a)
-;;   (cond
-;;    ((null? x) a)
-;;    ((atom? x) (cons (cons x y) a))
-;;    (#t (cons (cons (car x) (car y))
-;;              (pairlis (cdr x) (cdr y) a)))))
-
-;; (define (assq x a)
-;;   ;;(stderr "assq x=~a\n" x)
-;;   ;;(debug "assq x=~a a=~a\n" x a)
-;;   (cond
-;;    ((null? a) #f)
-;;    ((eq? (caar a) x) (car a))
-;;    (#t (assq x (cdr a)))))
-
-;; ;; Page 13
-;; (define (eval-quote fn x)
-;;   ;(debug "eval-quote fn=~a x=~a" fn x)
-;;   (apply-env fn x '()))
-
-(define (evcon c a)
-  ;;(debug "evcon c=~a a=~a\n" c a)
-  (cond
-   ((null? c) *unspecified*)
-   ;; single-statement cond
-   ;; ((eval (caar c) a) (eval (cadar c) a))
-   ((eval (caar c) a)
-    (cond ((null? (cddar c)) (eval (cadar c) a))
-          (#t (eval (cadar c) a)
-              (evcon
-               (cons (cons #t (cddar c)) '())
-               a))))
-   (#t (evcon (cdr c) a))))
-
-(define (evlis m a)
-  ;;(debug "evlis m=~a a=~a\n" m a)
-  ;; (display 'mes-evlis:)
-  ;; (display m)
-  ;; (newline)
-  (cond
-   ((null? m) '())
-   (#t (cons (eval (car m) a) (evlis (cdr m) a)))))
-
-
-(define (apply-env fn x a) 
-  ;; (display 'mes-apply-env:)
-  ;; (newline)
-  ;; (display 'fn:)
-  ;; (display fn)
-  ;; (newline)
-  ;; (display 'builtin:)
-  ;; (display (builtin? fn))
-  ;; (newline)
-  ;; (display 'x:)
-  ;; (display x)
-  ;; (newline)
-  (cond
-   ((atom? fn)
-    (cond
-     ((eq? fn 'current-module)
-      (c:apply-env current-module '() a))
-     ((eq? fn 'call-with-values)
-      (c:apply-env 'call-with-values x a))
-     ((builtin? fn)
-      (call fn x))
-     (#t (apply-env (eval fn a) x a))))
-   ((eq? (car fn) 'lambda)
-    (begin-env (cddr fn) (pairlis (cadr fn) x a)))
-   ((eq? (car fn) 'label) (apply-env (caddr fn) x (cons (cons (cadr fn)
-                                                         (caddr fn)) a)))))
-
-(define (begin-env body a)
-  (cond ((null? body) *unspecified*)
-        ((null? (cdr body)) (eval (car body) a))
-        (#t (eval (car body) a)
-            (begin-env (cdr body) a))))
-
-(define (set-env! x e a)
-  (set-cdr! (assq x a) e))
-
-(define (eval e a)
-  ;;(debug "eval e=~a a=~a\n" e a)
-  ;;(debug "eval (atom? ~a)=~a\n" e (atom? e))
-  ;; (display 'mes-eval:)
-  ;; (display e)
-  ;; (newline)
-  ;; (display 'a:)
-  ;; (display a)
-  ;; (newline)
-  (cond
-   ((eq? e #t) #t)
-   ((eq? e #f) #f)
-   ((char? e) e)
-   ((number? e) e)
-   ((string? e) e)
-   ((vector? e) e)
-   ((atom? e) (cdr (assq e a)))
-   ((builtin? e) e)
-   ((atom? (car e))
-    (cond
-     ((eq? (car e) 'quote) (cadr e))
-     ((eq? (car e) 'lambda) e)
-     ((eq? (car e) 'set!) (set-env! (cadr e) (caddr e) a))
-     ((eq? (car e) 'unquote) (eval (cadr e) a))
-     ((eq? (car e) 'quasiquote) (eval-quasiquote (cadr e) a))
-     ((eq? (car e) 'cond) (evcon (cdr e) a))
-     ((pair? (assq (car e) (cdr (assq '*macro* a))))
-      (c:eval
-       (c:apply-env
-        (cdr (assq (car e) (cdr (assq '*macro* a))))
-        (cdr e)
-        a)
-       a))
-     (#t (apply-env (car e) (evlis (cdr e) a) a))))
-   (#t (apply-env (car e) (evlis (cdr e) a) a))))
-
-(define (eval-quasiquote e a)
-  ;; (display 'mes-eval-quasiquote:)
-  ;; (display e)
-  ;; (newline)
-  (cond ((null? e) e)
-        ((atom? e) e)
-        ((atom? (car e)) (cons (car e) (eval-quasiquote (cdr e) a)))
-        ((eq? (caar e) 'unquote) (cons (eval (cadar e) a) '()))
-        ((eq? (caar e) 'quote) (cons (cadar e) '()))
-        ((eq? (caar e) 'quasiquote) (cons (cadar e) '()))
-        (#t (cons (car e) (eval-quasiquote (cdr e) a)))))
-
-;; readenv et al works, but slows down dramatically
-(define (DISABLED-readenv a)
-  (readword (read-char) '() a))
-
-(define (readword c w a)
-  ;; (display 'mes-readword:)
-  ;; (display c)
-  ;; (newline)
-  (cond ((eq? c -1) ;; eof
-         (cond ((eq? w '()) '())
-               (#t (lookup w a))))
-        ((eq? c 10) ;; \n
-         (cond ((eq? w '()) (readword (read-char) w a))
-               ;; DOT ((eq? w '(*dot*)) (car (readword (read-char) '() a)))
-               (#t (lookup w a))))
-        ((eq? c 32) ;; \space
-         (readword 10 w a))
-        ((eq? c 40) ;; (
-         (cond ((eq? w '()) (readlist a))
-               (#t (unread-char c) (lookup w a))))
-        ((eq? c 41) ;; )
-         (cond ((eq? w '()) (unread-char c) w)
-               (#t (unread-char c) (lookup w a))))
-        ((eq? c 39) ;; '
-         (cond ((eq? w '())
-                (cons (lookup (cons c '()) a)
-                      (cons (readword (read-char) w a) '())))
-               (#t (unread-char c) (lookup w a))))
-        ((eq? c 59) ;; ;
-         (readcomment c)
-         (readword 10 w a))
-        ((eq? c 35) ;; #
-         (cond ((eq? (peek-char) 33) ;; !
-                (read-char)
-                (readblock (read-char))
-                (readword 10 w a))
-               ;; TODO: char, vector
-               (#t (readword (read-char) (append w (cons c '())) a))))
-        (#t (readword (read-char) (append w (cons c '())) a))))
-
-(define (readblock c)
-  ;; (display 'mes-readblock:)
-  ;; (display c)
-  ;; (newline)
-  (cond ((eq? c 33) (cond ((eq? (peek-char) 35) (read-char))
-                         (#t (readblock (read-char)))))
-        (#t (readblock (read-char)))))
-
-(define (eat-whitespace)
-  (cond ((eq? (peek-char) 10) (read-char) (eat-whitespace))
-        ((eq? (peek-char) 32) (read-char) (eat-whitespace))
-        ((eq? (peek-char) 35) (read-char) (eat-whitespace))
-        (#t #t)))
-
-(define (readlist a)
-  ;; (display 'mes-readlist:)
-  ;; (newline)
-  (eat-whitespace)
-  (cond ((eq? (peek-char) 41) ;; )
-         (read-char)
-         '())
-        ;; TODO *dot*
-        (#t (cons (readword (read-char) '() a) (readlist a)))))
-
-(define (readcomment c)
-  (cond ((eq? c 10) ;; \n
-         c)
-        (#t (readcomment (read-char)))))
diff --git a/mes.scm b/mes.scm
deleted file mode 100755 (executable)
index 6ec751e..0000000
--- a/mes.scm
+++ /dev/null
@@ -1,224 +0,0 @@
-#! /bin/sh
-# -*-scheme-*-
-exec guile -L $(pwd) -e '(mes)' -s "$0" "$@"
-!#
-
-;;; Mes --- The Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; This file is part of GNU Guix.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes 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 General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
-
-;; The Maxwell Equations of Software -- John McCarthy page 13
-;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
-
-(define-module (mes)
-  #:export (main))
-
-(set-current-module
- (make-module 10 `(,(resolve-interface
-                     '(guile)
-                     #:select '(
-                                ;; Debugging
-                                apply
-                                cons*
-                                current-error-port
-                                current-output-port
-                                display
-                                eof-object?
-                                exit
-                                force-output
-                                format
-                                newline
-                                read
-                                with-input-from-string
-
-                                ;; Guile admin
-                                module-define!
-                                resolve-interface
-
-                                ;; PRIMITIVES
-                                car
-                                cdr
-                                cons
-                                eq?
-                                null?
-                                pair?
-
-                                ;; ADDITIONAL PRIMITIVES
-                                number?
-                                procedure?
-                                <
-                                -
-                                )
-                     #:renamer (symbol-prefix-proc 'guile:)))))
-
-(define (logf port string . rest)
-  (guile:apply guile:format (guile:cons* port string rest))
-  (guile:force-output port)
-  #t)
-
-(define (stderr string . rest)
-  (guile:apply logf (guile:cons* (guile:current-error-port) string rest)))
-
-(define (stdout string . rest)
-  (guile:apply logf (guile:cons* (guile:current-output-port) string rest)))
-
-(define (debug . x) #t)
-;;(define debug stderr)
-
-;; TODO
-(define (atom? x)
-  (cond
-   ((guile:pair? x) #f)
-   ((guile:null? x) #f)
-   (#t x)))
-
-;; PRIMITIVES
-(define car guile:car)
-(define cdr guile:cdr)
-(define cons guile:cons)
-(define eq? guile:eq?)
-(define null? guile:null?)
-(define pair? guile:pair?)
-(define builtin? guile:procedure?)
-(define number? guile:number?)
-(define call guile:apply)
-
-(include "mes.mes")
-
-(define (pairlis x y a)
-  ;;(debug "pairlis x=~a y=~a a=~a\n" x y a)
-  (cond
-   ((null? x) a)
-   ((atom? x) (cons (cons x y) a))
-   (#t (cons (cons (car x) (car y))
-             (pairlis (cdr x) (cdr y) a)))))
-
-(define (assq x a)
-  ;;(stderr "assq x=~a\n" x)
-  ;;(debug "assq x=~a a=~a\n" x a)
-  (cond
-   ((null? a) #f)
-   ((eq? (caar a) x) (car a))
-   (#t (assq x (cdr a)))))
-
-(define (append x y)
-  (cond ((null? x) y)
-        (#t (cons (car x) (append (cdr x) y)))))
-
-(define (eval-environment e a)
-  (eval e (append a environment)))
-
-(define (apply-environment fn e a)
-  (apply-env fn e (append a environment)))
-
-(define (readenv a)
-  (let ((x (guile:read)))
-    (if (guile:eof-object? x) '()
-        x)))
-
-(define environment
-  `(
-    (() . ())
-    (#t . #t)
-    (#f . #f)
-    
-    (*unspecified* . ,*unspecified*)
-
-    (atom? . ,atom?)
-    (car . ,car)
-    (cdr . ,cdr)
-    (cons . ,cons)
-    (cond . ,evcon)
-    (eq? . ,eq?)
-
-    (null? . ,null?)
-    (pair? . ,guile:pair?)
-    ;;(quote . ,quote)
-
-    (evlis . ,evlis)
-    (evcon . ,evcon)
-    (pairlis . ,pairlis)
-    (assq . ,assq)
-
-    (eval . ,eval-environment)
-    (apply-env . ,apply-environment)
-
-    (readenv . ,readenv)
-    (display . ,guile:display)
-    (newline . ,guile:newline)
-
-    (builtin? . ,builtin?)
-    (number? . ,number?)
-    (call . ,call)
-
-    (< . ,guile:<)
-    (- . ,guile:-)
-
-    ;; DERIVED
-    (caar . ,caar)
-    (cadr . ,cadr)
-    (cdar . ,cdar)
-    (cddr . ,cddr)
-    (caadr . ,caadr)
-    (caddr . ,caddr)
-    (cdadr . ,cdadr)
-    (cadar . ,cadar)
-    (cddar . ,cddar)
-    (cdddr . ,cdddr)
-
-    (append . ,append)
-    (exit . ,guile:exit)
-
-    (*macro* . ())
-
-    ;;
-    (stderr . ,stderr)))
-
-(define (mes-define-lambda x a)
-  (cons (caadr x) (cons 'lambda (cons (cdadr x) (cddr x)))))
-
-(define (mes-define x a)
-  (if (atom? (cadr x))
-      (cons (cadr x) (eval (caddr x) a))
-      (mes-define-lambda x a)))
-
-(define (mes-define-macro x a)
-  (cons '*macro*
-        (cons (mes-define-lambda x a)
-              (cdr (assq '*macro* a)))))
-
-(define (loop r e a)
-  (cond ((null? e) r)
-        ((eq? e 'exit)
-         (apply-env (cdr (assq 'loop a))
-                    (cons *unspecified* (cons #t (cons a '())))
-                    a))
-        ((atom? e) (loop (eval e a) (readenv a) a))
-        ((eq? (car e) 'define)
-         (loop *unspecified* (readenv a) (cons (mes-define e a) a)))
-        ((eq? (car e) 'define-macro)
-         (loop *unspecified* (readenv a) (cons (mes-define-macro e a) a)))
-        (#t (loop (eval e a) (readenv a) a))))
-
-(define (main arguments)
-  (let ((a (append environment `((*a* . ,environment)))))
-    ;;(guile:display (eval (readenv a) a))
-    (guile:display (loop *unspecified* (readenv a) a))
-    )
-  (guile:newline))
-
-(guile:module-define! (guile:resolve-interface '(mes)) 'main main)
diff --git a/mes.test b/mes.test
deleted file mode 100755 (executable)
index debeb60..0000000
--- a/mes.test
+++ /dev/null
@@ -1,22 +0,0 @@
-#! /bin/sh
-#set -x
-mes=${1-./mes.scm}
-echo 0 | $mes
-echo 1 | $mes
-echo "(car '(0 1))" | $mes
-echo "(car (quote (0 1)))" | $mes
-echo "(car '(0 1))" | $mes
-echo "(cdr '(0 1))" | $mes
-echo "(cons 0 1)" | $mes
-echo "((lambda (x y) (cons x y)) 0 1)" | $mes
-echo "(< 0 0)" | $mes
-echo "(< 0 1)" | $mes
-# LISP-1.5 label dropped for now
-# echo "((label fun\
-#        (lambda (x) (cons x\
-#                          (cond ((< 0 x) (fun (- x 1)))\
-#                                (#t '())))))\
-#        3)" | $mes
-echo "'(0 . 1)" | $mes
-echo "(cdr '(0 . 1))" | $mes
-echo "(define (list . rest) rest)" | $mes
diff --git a/mescc.scm b/mescc.scm
deleted file mode 100644 (file)
index 15788d3..0000000
--- a/mescc.scm
+++ /dev/null
@@ -1,576 +0,0 @@
-(cond-expand
-  (guile
-   ;;(use-modules ((system base lalr)))
-   )
-  (mes
-   ))
-
-(define c-parser
-  (lalr-parser
-
-   (lbrace rbrace lparen rparen lbracket rbracket semicolon colon dot comma
-           =
-           Identifier NumericLiteral StringLiteral
-           break case continue goto label
-           return switch
-           for
-           if else
-           (left: or && ! * / + -)
-           (left: bool double float enum void int struct)
-           (left: < > <= >=)
-           (left: ++ --)
-           (nonassoc: == !=)
-           )
-   
-   (program
-    (translation-unit *eoi*) : `(root ,@$1))
-
-   (translation-unit
-    (external-declaration) : `(,$1)
-    (translation-unit external-declaration) : `(,@$1 ,@$2))
-
-   (external-declaration
-    (function-definition) : $1
-    (declaration) : $1
-    (error semicolon) : (begin (syntax-error "external declaration" @1 $1) '()))
-
-   (function-definition
-    (declarator compound-statement) : `(function ,$1 (signature int (formals)) ,$2)
-    (declaration-specifiers declarator compound-statement) : `(function ,$2 (signature ,$1 (formals)) ,$3)
-    (declaration-specifiers declarator declaration-list compound-statement) : `(function ,$2 (signature ,$1 ,$3) ,$4))
-
-   (declaration
-    (declaration-specifiers semicolon) : `(,$1)
-    (declaration-specifiers init-declarator-list semicolon): `((,@$1 ,@$2))
-    )
-
-   (declaration-list
-    (declaration) : `(formals ,@$1)
-    (declaration-list declaration) : `(,@$1 ,@(cdr $2)))
-
-   (declaration-specifiers
-    ;;(storage-class-specifier) : `(,$1)
-    (type-specifier) : `(,$1)
-    ;;(type-qualifier) : `($1)
-    ;;(storage-class-specifier declaration-specifiers) : (cons $1 $2)
-    (type-specifier declaration-specifiers) : `(,$1 ,$2)
-    ;;(type-qualifier declaration-specifiers) : (cons $1 $2)
-    )
-
-   ;; (storage_class_specifier
-   ;;  (auto)
-   ;;  (extern)
-   ;;  (register)
-   ;;  (static)
-   ;;  (typedef))
-   
-   (type-specifier
-    ;; (char) : $1
-    ;; (double) : $1
-    ;; (void) : $1
-    ;; (float)
-    (int) : 'int
-    ;; (long)
-    ;; (short)
-    ;; (unsigned)
-    ;; (struct-or-enum-specifier)
-    ;; (enum-specifier)
-    ;; (type-name)
-    )
-
-   ;; (type-qualifier
-   ;;  (const)
-   ;;  (volatile))
-
-   ;; struct_or_union_specifier:
-   ;;             struct_or_union_ident lbrace struct_declaration_list rbrace
-   ;;          |  struct_or_union_ident
-   ;;          ;
-
-   ;; struct_or_union_ident: struct_or_union
-   ;;          | struct_or_union Identifier
-   ;;          ;
-
-   ;; struct_or_union:   STRUCT                                { ; }
-   ;;          |  UNION                                { ; }
-   ;;          ;
-   
-   ;; struct_declaration_list: struct_declaration
-   ;;          |  struct_declaration_list struct_declaration
-   ;;          ;
-
-   (init-declarator-list
-    ;; (init-declarator %prec comma) : `(,$1) HUH?
-    (init-declarator) : `(,$1)
-    (init-declarator-list comma init-declarator) : `(,$1)
-    )
-   ;; init_declarator_list:     init_declarator %prec comma
-   ;;          |  init_declarator_list comma init_declarator
-   ;;          ;
-
-   (init-declarator
-    (declarator) : $1
-    (declarator = initializer) : `(= ,$1 ,$3)
-    ;;                 | error { yyerror("init declarator error"); }
-    )
-
-   ;; struct_declaration: specifier_qualifier_list struct_declarator_list semicolon
-   ;;          ;
-
-   ;; specifier_qualifier_list: type_specifier
-   ;;          |  type_qualifier
-   ;;          |  type_specifier specifier_qualifier_list
-   ;;          | type_qualifier specifier_qualifier_list
-   ;;          ;
-
-   ;; struct_declarator_list: struct_declarator
-   ;;          |  struct_declarator_list comma struct_declarator
-   ;;          ;
-
-   ;; struct_declarator: declarator
-   ;;          |  COLON constant_expression            { ; }
-   ;;          |  declarator COLON constant_expression
-   ;;          ;
-
-   ;; enum_specifier:     ENUM Identifier lbrace enumerator_list rbrace        { ; }
-   ;;          |  ENUM lbrace enumerator_list rbrace           { ; }
-   ;;          |  ENUM Identifier                              { ; }
-   ;;          ;
-
-   ;; enumerator_list:   enumerator
-   ;;          |  enumerator_list comma enumerator
-   ;;          ;
-
-   ;; enumerator:                 Identifier
-   ;;          |  Identifier EQ constant_expression
-   ;;          ;
-
-   (declarator
-    (direct-declarator) : $1
-    ;;(pointer direct-declarator)
-    )
-
-   (direct-declarator
-    (Identifier) : $1
-    ;; (lparen declarator rparen)
-    ;; (direct-declarator lbracket rbracket)
-    ;; (direct-declarator lbracket constant-expression rbracket)
-    ;; (lbracket constant-expression rbracket)
-    ;; (direct-declarator lparen parameter-type-list rparen)
-    (direct-declarator lparen rparen) : $1
-    ;; (direct-declarator lparen identifier-list rparen)
-    )
-
-   ;; pointer:    STAR                                 { ; }
-   ;;          |  STAR pointer                         { ; }
-   ;;          |  STAR type_qualifier_list             { ; }
-   ;;          |  STAR type_qualifier_list pointer     { ; }
-   ;;          ;
-
-   ;; type_qualifier_list: type_qualifier
-   ;;          |  type_qualifier_list type_qualifier
-   ;;          ;
-
-   ;; parameter_type_list: parameter_list
-   ;;          | parameter_list comma ELLIPSIS
-   ;;          ;
-
-   ;; parameter_list:     parameter_declaration
-   ;;          |  parameter_list comma parameter_declaration
-   ;;          ;
-
-   ;; parameter_declaration:
-   ;;             declaration_specifiers declarator
-   ;;          |  declaration_specifiers
-   ;;          |  declaration_specifiers abstract_declarator
-   ;;          ;
-
-   ;; identifier_list:        Identifier
-   ;;          |  identifier_list comma Identifier
-   ;;          |  error { yyerror("identifier list error"); }
-   ;;          ;
-
-   (initializer
-    ;;(assignment-expression %prec comma) HUH?
-    (assignment-expression) : $1
-    ;; initializer:       assignment_expression %prec comma
-    ;;                 |  lbrace initializer_list rbrace               { ; }
-    ;;                 |  lbrace initializer_list comma rbrace         { ; }
-    ;;                 ;
-    )
-
-   ;; initializer_list:         initializer %prec comma
-   ;;          |  initializer_list comma initializer
-   ;;          ;
-
-   ;; type_name:          specifier_qualifier_list
-   ;;          |  specifier_qualifier_list abstract_declarator
-   ;;          ;
-
-   ;; abstract_declarator:     pointer
-   ;;          |  direct_abstract_declarator
-   ;;          |  pointer direct_abstract_declarator
-   ;;          ;
-
-   ;; direct_abstract_declarator:
-   ;;             lparen abstract_declarator rparen            { ; }
-   ;;          |  lbrace rbrace                                { ; }
-   ;;          |  direct_abstract_declarator lbrace rbrace
-   ;;          |  lbrace constant_expression rbrace            { ; }
-   ;;          |  direct_abstract_declarator lbrace constant_expression rbrace
-   ;;          |  lparen rparen                                { ; }
-   ;;          |  direct_abstract_declarator lparen rparen
-   ;;          |  lparen parameter_list rparen                 { ; }
-   ;;          |  direct_abstract_declarator lparen parameter_list rparen
-   ;;          ;
-
-   
-   (statement
-    ;;(labeled-statement) 
-    (expression-statement) : $1
-    (compound-statement) : $1
-    ;;(selection-statement)
-    (iteration-statement) : $1
-    (jump-statement) : $1
-    (semicolon) : '()
-    (error semicolon) : (begin (syntax-error "statement error" @1 $1) '())
-    (error rbrace) : (begin (syntax-error "statement error" @1 $1) '()))
-               
-
-   ;; labeled_statement:
-   ;;             Identifier COLON statement
-   ;;          |  CASE x COLON statement               { ; }
-   ;;          |  DEFAULT COLON statement              { ; }
-   ;;          ;
-
-   (expression-statement
-    (x semicolon) : $1)
-
-   (compound-statement
-    (lbrace rbrace) : '(compound)
-    (lbrace declaration-list rbrace) : `(compound ,$2)
-    (lbrace statement-list rbrace) :  `(compound ,@$2)
-    (lbrace declaration-list statement-list rbrace) : `(compound ,$2 ,@$3))
-
-   (statement-list
-    (statement) : `(,$1)
-    (statement-list statement) : `(,@$1 ,$2))
-   
-   ;; selection_statement:
-   ;;             IF lparen x rparen statement                 { ; }
-   ;;          |  IF lparen x rparen statement ELSE statement  { ; }
-   ;;          |  SWITCH lparen x rparen statement             { ; }
-   ;;          ;
-
-   (iteration-statement
-    ;; iteration_statement:
-    ;;                    WHILE lparen x rparen statement              { ; }
-    ;;                 |  DO statement WHILE lparen x rparen semicolon { ; }
-    (for lparen forcntrl rparen statement) : `(for ,@$3 ,$5))
-   
-   (forcntrl
-    ;;                 | semicolon semicolon x                         { ; }
-    ;;                 | semicolon x semicolon                         { ; }
-    ;;                 | semicolon x semicolon x                               { ; }
-    ;;                 | x semicolon semicolon
-    ;;                 | x semicolon semicolon x
-    ;;                 | x semicolon x semicolon
-    (x semicolon x semicolon x) : `((start ,$1) (test ,$3) (step ,$5)))
-
-   (jump-statement
-    (goto Identifier semicolon) : `(goto ,$2)
-    (continue semicolon) : '(continue)
-    (break semicolon) : '(break)
-    (return semicolon) : '(return)
-    (return x semicolon) : `(return ,$2))
-
-   (x
-    (assignment-expression) : $1
-    (x comma assignment-expression) : `(,$1 ,@$3))
-               
-   (assignment-expression
-    (equality-expression) : $1 ;; skip some
-    ;;(conditional-expression) : $1
-    (unary-expression assignment-operator assignment-expression) : `(,$2 ,$1 ,$3))
-
-   (assignment-operator
-    (=) : '=)
-   ;;          |  PLUSEQ                               { ; }
-   ;;          |  MINUSEQ                              { ; }
-   ;;          |  MUEQ                                 { ; }
-   ;;          |  DIVEQ                                { ; }
-   ;;          |  MODEQ                                { ; }
-   ;;          |  SLEQ                         { ; }
-   ;;          |  SREQ                         { ; }
-   ;;          |  ANEQ                         { ; }
-   ;;          |  OREQ                         { ; }
-   ;;          |  XOREQ                                { ; }
-   ;;          ;
-
-   ;; conditional_expression: logical_or_expression
-   ;;          |  logical_or_expression IF_THEN x COLON conditional_expression
-   ;;          ;
-
-   ;; constant_expression: conditional_expression
-   ;;          ;
-
-   ;; logical_or_expression: logical_and_expression
-   ;;          |  logical_or_expression OROR logical_and_expression
-   ;;          ;
-
-   ;; logical_and_expression: inclusive_or_expression
-   ;;          |  logical_and_expression ANDAND inclusive_or_expression
-   ;;          ;
-
-   ;; inclusive_or_expression: exclusive_or_expression
-   ;;          |  inclusive_or_expression OR exclusive_or_expression
-   ;;          ;
-
-   ;; exclusive_or_expression: and_expression
-   ;;          |  exclusive_or_expression XOR and_expression
-   ;;          ;
-
-   ;; and_expression: equality_expression
-   ;;          |  and_expression AND equality_expression
-   ;;          ;
-
-   (equality-expression
-    (relational-expression) : $1
-    (equality-expression == relational-expression) : `(== ,$1 ,$3)
-    (equality-expression != relational-expression) : `(!= ,$1 ,$3))
-
-   (relational-expression
-    (shift-expression) : $1
-    (relational-expression < shift-expression) : `(< ,$1 ,$3)
-    (relational-expression <= shift-expression) : `(<= ,$1 ,$3)
-    (relational-expression > shift-expression) : `(> ,$1 ,$3)
-    (relational-expression >= shift-expression) : `(>= ,$1 ,$3))
-
-   (shift-expression
-    (unary-expression) : $1 ;; skip some
-    ;; shift_expression: additive_expression
-    ;;                 |  shift_expression LTLT additive_expression
-    ;;                 |  shift_expression GTGT additive_expression
-    ;;                 ;
-    )
-   ;; additive_expression: multiplicative_expression
-   ;;          |  additive_expression PLUS multiplicative_expression
-   ;;          |  additive_expression MINUS multiplicative_expression
-   ;;          ;
-
-   ;; multiplicative_expression: cast_expression
-   ;;          |  multiplicative_expression STAR cast_expression
-   ;;          |  multiplicative_expression DIV cast_expression
-   ;;          |  multiplicative_expression MOD cast_expression
-   ;;          ;
-
-   ;; cast_expression:   unary_expression
-   ;;          |  lparen type_name rparen cast_expression      { ; }
-   ;;          ;
-
-   (unary-expression
-    (postfix-expression) : $1
-    (++ unary-expression) : `(++x ,$2)
-    (-- unary-expression) : `(--x ,$2)
-   ;;          |  SIZEOF unary_expression              { ; }
-   ;;          |  SIZEOF lparen type_name rparen %prec SIZEOF  { ; }
-   ;;          |  STAR cast_expression                 { ; }
-   ;;          |  AND cast_expression                  { ; }
-   ;;          |  MINUS cast_expression                { ; }
-   ;;          |  PLUS cast_expression                 { ; }
-   ;;          |  NEG cast_expression                  { ; }
-   ;;          |  NOT cast_expression                  { ; }
-   ;;          ;
-    )
-
-   (postfix-expression
-    (primary-expression) : $1
-    ;;                 |  postfix_expression lbracket x rbracket
-    (postfix-expression lparen rparen) : `(call ,$1 (arguments))
-    (postfix-expression lparen argument-expression-list rparen) : `(call ,$1 ,$3)
-    ;;                 |  postfix_expression FOLLOW Identifier
-    ;;                 |  postfix_expression DOT Identifier
-    (postfix-expression ++) : `(x++ ,$1)
-    (postfix-expression --) : `(x-- ,$1)
-    )
-
-   (primary-expression
-    (Identifier): $1
-    (NumericLiteral) : $1
-    ;; INT_LITERAL
-    ;; CHAR_LITERAL
-    ;; FLOAT_LITERAL
-    ;; STRING_LITERAL
-    (StringLiteral) : $1
-    ;; lparen x rparen
-    )
-   ;;          
-
-   (argument-expression-list
-    (assignment-expression) : `(arguments ,$1)
-    (argument-expression-list comma assignment-expression): `(,@$1 ,@(cdr $3)))))
-
-(define (i386:exit code)
-  `(
-    #xbb ,@(int->bv32 code)        ;; mov    $code,%ebx
-         #xb8 #x01 #x00 #x00 #x00       ;; mov    $0x1,%eax
-         #xcd #x80                      ;; int    $0x80
-         ))
-
-(define (i386:puts data length)
-  `(
-     #xba ,@(int->bv32 length)           ;; mov    $length,%edx
-          #xb9 ,@(int->bv32 data)        ;; mov    $data,%ecx
-          #xbb #x01 #x00 #x00 #x00       ;; mov    $0x1,%ebx
-          #xb8 #x04 #x00 #x00 #x00       ;; mov    $0x4,%eax
-          #xcd #x80                      ;; int    $0x80
-          ))
-
-(define (i386:for start test step statement)
-`(
-
-  ;;   b:
-  #x89 #xe5                    ;; mov    %esp,%ebp
-       ;;21:
-       #xc7 #x45 #xf4 ,@(int->bv32 start) ;;   movl   $start,-0xc(%ebp)
-       ;;28:
-       #xeb ,(+ (length statement) 9) ;;x14    jmp    3e <main+0x3e>
-       ;;2a:
-       ;;#x83 #xec #x0c             ;; sub    $0xc,%esp
-       
-       ;;   9:
-       #x55   ;;                       push   %ebp
-       
-       ,@statement
-       #x5d   ;;                       pop   %ebp
-       ;;2d:
- ;;;;;;#x68 #x09 #x00 #x00 #x00       ;;       push   $0x9
-       ;;32:
- ;;;;;;#xe8 #xfc #xff #xff #xff       ;;       call   33 <main+0x33>
-       ;;37:
- ;;;;;;#x83 #xc4 #x10             ;;   add    $0x10,%esp
-       ;;3a:
-       ;;;;#x83 #x45 #xf4 ,step          ;;    addl   $step,-0xc(%ebp)
-       ;;3e:
-       ;;;;#x83 #x7d #xf4 ,test          ;;    cmpl   $test,-0xc(%ebp)
-       #x81 #x45 #xf4 ,@(int->bv32 step)       ;;addl   $step,-0xc(%ebp)
-       #x81 #x7d #xf4 ,@(int->bv32 test) ;;cmpl   $0x7cff,-0xc(%ebp)
-       ;;42:
-       ;;;;#x7e ,(- 0 (length statement) 18) ;;#xe6 ;; jle    2a <main+0x2a>
-       #x75 ,(- 0 (length statement) 18) ;;#xe6 ;;     jne    2a <main+0x2a>
-))
-
-
-(define mescc
-  (let ((errorp
-         (lambda args
-           (for-each display args)
-             (newline))))
-    (lambda ()
-      (c-parser (c-lexer errorp) errorp))))
-
-(define (write-any x) (write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
-
-(define (ast:function? o)
-  (and (pair? o) (eq? (car o) 'function)))
-
-(define (.name o)
-  (cadr o))
-
-;; (define (.statement o)
-;;   (match o
-;;     (('function name signature statement) statement)
-;;     (_ #f)))
-
-;; (define (statement->data o)
-;;   (match o
-;;     (('call 'puts ('arguments string)) (string->list string))
-;;     (_ '())))
-
-;; (define (statement->text o)
-;;   (match o
-;;     (('call 'puts ('arguments string)) (list (lambda (data) (i386:puts data (string-length string)))))
-;;     (('return code) (list (lambda (data) (i386:exit code))))
-;;     (_ '())))
-
-(define (.statement o)
-  (and (pair? o)
-       (eq? (car o) 'function)
-       (cadddr o)))
-
-(define (statement->data o)
-  (or (and (pair? o)
-           (eq? (car o) 'call)
-           (string->list (cadr (caddr o))))
-      (and (pair? o) (eq? (car o) 'for)
-           (let ((statement (cadr (cdddr o))))
-             (statement->data statement)))
-      '()))
-
-(define (statement->text data o)
-  (cond
-   ((and (pair? o) (eq? (car o) 'call))
-    (let ((string (cadr (caddr o)))
-          (offset (length data)))
-      (list (lambda (data) (i386:puts (+ data offset) (string-length string))))))
-   ((and (pair? o) (eq? (car o) 'for))
-    (let ((start (cadr o))
-          (test (caddr o))
-          (step (cadddr o))
-          (statement (cadr (cdddr o))))
-      (display "start:" (current-error-port))
-      (display start (current-error-port))
-      (newline (current-error-port))
-
-      (display "test:" (current-error-port))
-      (display test (current-error-port))
-      (newline (current-error-port))
-
-      (display "step:" (current-error-port))
-      (display step (current-error-port))
-      (newline (current-error-port))
-
-      (display "for-statement:" (current-error-port))
-      (display statement (current-error-port))
-      (newline (current-error-port))
-
-      (let ((start (cadr (cdadr start)))
-            (test (cadr (cdadr test)))
-            ;;(step (cadr (cdadr step)))
-            (step 1)
-            (statement (car (statement->text data statement)))
-            )
-        (display "2start:" (current-error-port))
-        (display start (current-error-port))
-        (newline (current-error-port))
-
-      (display "2for-statement:" (current-error-port))
-      (display statement (current-error-port))
-      (newline (current-error-port))
-
-        (list (lambda (d) (i386:for start test step (statement d)))))))
-   ((and (pair? o) (eq? (car o) 'return))
-    (list (lambda (data) (i386:exit (cadr o)))))
-   (else '())))
-
-(let* ((ast (mescc))
-       (functions (filter ast:function? (cdr ast)))
-       (main (find (lambda (x) (eq? (.name x) 'main)) functions))
-       (statements (cdr (.statement main))))
-  (display "program: " (current-error-port))
-  (display ast (current-error-port))
-  (newline (current-error-port))
-  (let loop ((statements statements) (text '()) (data '()))
-    (display "text:" (current-error-port))
-    (display text (current-error-port))
-    (newline (current-error-port))
-    (if (null? statements)
-        (map write-any (make-elf (lambda (data)
-                                   (append-map (lambda (f) (f data)) text)) data))
-        (let* ((statement (car statements)))
-          (display "statement:" (current-error-port))
-          (display statement (current-error-port))
-          (newline (current-error-port))
-          (loop (cdr statements)
-                (append text (statement->text data statement))
-                (append data (statement->data statement)))))))
diff --git a/module/language/c/compiler.mes b/module/language/c/compiler.mes
new file mode 100644 (file)
index 0000000..2cd88d7
--- /dev/null
@@ -0,0 +1,144 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; compiler.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; compiler.mes produces an i386 binary from the C produced by
+;;; c-parser.
+
+;;; Code:
+
+(define mescc
+  (let ((errorp
+         (lambda args
+           (for-each display args)
+             (newline))))
+    (lambda ()
+      (c-parser (c-lexer errorp) errorp))))
+
+(define (write-any x) (write-char (if (char? x) x (integer->char (if (>= x 0) x (+ x 256))))))
+
+(define (ast:function? o)
+  (and (pair? o) (eq? (car o) 'function)))
+
+(define (.name o)
+  (cadr o))
+
+;; (define (.statement o)
+;;   (match o
+;;     (('function name signature statement) statement)
+;;     (_ #f)))
+
+;; (define (statement->data o)
+;;   (match o
+;;     (('call 'puts ('arguments string)) (string->list string))
+;;     (_ '())))
+
+;; (define (statement->text o)
+;;   (match o
+;;     (('call 'puts ('arguments string)) (list (lambda (data) (i386:puts data (string-length string)))))
+;;     (('return code) (list (lambda (data) (i386:exit code))))
+;;     (_ '())))
+
+(define (.statement o)
+  (and (pair? o)
+       (eq? (car o) 'function)
+       (cadddr o)))
+
+(define (statement->data o)
+  (or (and (pair? o)
+           (eq? (car o) 'call)
+           (string->list (cadr (caddr o))))
+      (and (pair? o) (eq? (car o) 'for)
+           (let ((statement (cadr (cdddr o))))
+             (statement->data statement)))
+      '()))
+
+(define (statement->text data o)
+  (cond
+   ((and (pair? o) (eq? (car o) 'call))
+    (let ((string (cadr (caddr o)))
+          (offset (length data)))
+      (list (lambda (data) (i386:puts (+ data offset) (string-length string))))))
+   ((and (pair? o) (eq? (car o) 'for))
+    (let ((start (cadr o))
+          (test (caddr o))
+          (step (cadddr o))
+          (statement (cadr (cdddr o))))
+      (display "start:" (current-error-port))
+      (display start (current-error-port))
+      (newline (current-error-port))
+
+      (display "test:" (current-error-port))
+      (display test (current-error-port))
+      (newline (current-error-port))
+
+      (display "step:" (current-error-port))
+      (display step (current-error-port))
+      (newline (current-error-port))
+
+      (display "for-statement:" (current-error-port))
+      (display statement (current-error-port))
+      (newline (current-error-port))
+
+      (let ((start (cadr (cdadr start)))
+            (test (cadr (cdadr test)))
+            ;;(step (cadr (cdadr step)))
+            (step 1)
+            (statement (car (statement->text data statement)))
+            )
+        (display "2start:" (current-error-port))
+        (display start (current-error-port))
+        (newline (current-error-port))
+
+      (display "2for-statement:" (current-error-port))
+      (display statement (current-error-port))
+      (newline (current-error-port))
+
+        (list (lambda (d) (i386:for start test step (statement d)))))))
+   ((and (pair? o) (eq? (car o) 'return))
+    (list (lambda (data) (i386:exit (cadr o)))))
+   (else '())))
+
+(define (compile)
+  (let* ((ast (mescc))
+         (functions (filter ast:function? (cdr ast)))
+         (main (find (lambda (x) (eq? (.name x) 'main)) functions))
+         (statements (cdr (.statement main))))
+    (display "program: " (current-error-port))
+    (display ast (current-error-port))
+    (newline (current-error-port))
+    (let loop ((statements statements) (text '()) (data '()))
+      (display "text:" (current-error-port))
+      (display text (current-error-port))
+      (newline (current-error-port))
+      (if (null? statements)
+          (begin
+            (display "dumping to a.out:\n" (current-error-port))
+            (map write-any (make-elf (lambda (data)
+                                       (append-map (lambda (f) (f data)) text)) data)))
+          (let* ((statement (car statements)))
+            (display "statement:" (current-error-port))
+            (display statement (current-error-port))
+            (newline (current-error-port))
+            (loop (cdr statements)
+                  (append text (statement->text data statement))
+                  (append data (statement->data statement))))))))
+
diff --git a/module/language/c/lexer.mes b/module/language/c/lexer.mes
new file mode 100644 (file)
index 0000000..84bab1f
--- /dev/null
@@ -0,0 +1,442 @@
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; lexer.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; lexer.mes WIP rudimentary c-lexer based on Guile ECMAScript
+
+;;; Code:
+
+
+
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+
+;;;; 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 3 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+;; (define-module (language ecmascript tokenize)
+;;   #:use-module (ice-9 rdelim)
+;;   #:use-module ((srfi srfi-1) #:select (unfold-right))
+;;   #:use-module (system base lalr)
+;;   #:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))
+
+(cond-expand
+  (guile
+   ;; (use-modules (ice-9 rdelim))
+
+   (define (syntax-error what loc form . args)
+     (throw 'syntax-error #f what
+            ;;(and=> loc source-location->source-properties)
+            loc
+            form #f args))
+   
+   )
+  (mes
+
+      
+   )
+  )
+
+(define (read-delimited delims port handle-delim)
+     (let ((stop (string->list delims)))
+       (let loop ((c (peek-char)) (lst '()))
+         (if (member c stop)
+             (list->string lst)
+             (begin
+               (read-char)
+               (loop (peek-char) (append lst (list c))))))))
+
+(define (read-line . rest ;; port handle-delim
+         )
+  (let ((line (read-delimited "\n\r" (current-input-port) 'peek)))
+    (read-char)
+    line))
+
+(define (port-source-location port)
+  (make-source-location (port-filename port)
+                        (port-line port)
+                        (port-column port)
+                        (false-if-exception (ftell port))
+                        #f))
+
+;; taken from SSAX, sorta
+(define (read-until delims loc)
+  (if (eof-object? (peek-char))
+      (syntax-error "EOF while reading a token" loc #f)
+      (let ((token (read-delimited delims (current-input-port) 'peek)))
+        (if (eof-object? (peek-char))
+            (syntax-error "EOF while reading a token" loc token)
+            token))))
+
+(define (char-hex? c)
+  (and (not (eof-object? c))
+       (or (char-numeric? c)
+           (memv c '(#\a #\b #\c #\d #\e #\f))
+           (memv c '(#\A #\B #\C #\D #\E #\F)))))
+
+(define (digit->number c)
+  (- (char->integer c) (char->integer #\0)))
+
+(define (hex->number c)
+  (if (char-numeric? c)
+      (digit->number c)
+      (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
+
+(define (read-slash loc div?)
+  (let ((c1 (begin
+              (read-char)
+              (peek-char))))
+    (cond
+     ((eof-object? c1)
+      ;; hmm. error if we're not looking for a div? ?
+      (make-lexical-token '/ loc #f))
+     ((char=? c1 #\/)
+      (read-line)
+      (next-token div?))
+     ((char=? c1 #\*)
+      (read-char)
+      (let lp ((c (read-char)))
+        (cond
+         ((eof-object? c)
+          (syntax-error "EOF while in multi-line comment" loc #f))
+         ((char=? c #\*)
+          (if (eqv? (peek-char) #\/)
+              (begin
+                (read-char)
+                (next-token div?))
+              (lp (read-char))))
+         (else
+          (lp (read-char))))))
+     (div?
+      (case c1
+        ((#\=) (read-char) (make-lexical-token '/= loc #f))
+        (else (make-lexical-token '/ loc #f))))
+     (else
+      ;;;(read-regexp loc)
+      (make-lexical-token '/ loc #f)))))
+
+(define (read-string loc)
+  (let ((c (read-char)))
+    (let ((terms (string c #\\ #\newline #\return)))
+      (define (read-escape)
+        (let ((c (read-char)))
+          (case c
+            ((#\' #\" #\\) c)
+            ((#\b) #\backspace)
+            ((#\f) #\page)
+            ((#\n) #\newline)
+            ((#\r) #\return)
+            ((#\t) #\tab)
+            ((#\v) #\vt)
+            ((#\0)
+             (let ((next (peek-char)))
+               (cond
+                ((eof-object? next) #\nul)
+                ((char-numeric? next)
+                 (syntax-error "octal escape sequences are not supported"
+                               loc #f))
+                (else #\nul))))
+            ((#\x)
+             (let* ((a (read-char))
+                    (b (read-char)))
+               (cond
+                ((and (char-hex? a) (char-hex? b))
+                 (integer->char (+ (* 16 (hex->number a)) (hex->number b))))
+                (else
+                 (syntax-error "bad hex character escape" loc (string a b))))))
+            ((#\u)
+             (let* ((a (read-char))
+                    (b (read-char))
+                    (c (read-char))
+                    (d (read-char)))
+               (integer->char (string->number (string a b c d) 16))))
+            (else
+             c))))
+      (let lp ((str (read-until terms loc)))
+        (let ((terminator (peek-char)))
+          (cond
+           ((char=? terminator c)
+            (read-char)
+            (make-lexical-token 'StringLiteral loc str))
+           ((char=? terminator #\\)
+            (read-char)
+            (let ((echar (read-escape)))
+              (lp (string-append str (string echar)
+                                 (read-until terms loc)))))
+           (else
+            (syntax-error "string literals may not contain newlines"
+                          loc str))))))))
+
+(define *keywords*
+  '(("break" . break)
+    ("case" . case)
+    ("continue" . continue)
+    ("else" . else)
+    ("goto" . goto)
+
+    ("char" . char)
+    ("double" . double)
+    ("float" . float)
+    ("int" . int)
+    ("long" . long)
+    ("short" . short)
+    ("unsigned" . unsigned)
+    
+    ("return" . return)
+    ("void" . void)
+    ("for" . for)
+    ("switch" . switch)
+    ("while" . while)
+    ("continue" . continue)
+    ("default" . default)
+    ("if" . if)
+    ("do" . do)
+
+    ;; these aren't exactly keywords, but hey
+    ("true" . true)
+    ("false" . false)))
+
+(define (read-identifier loc)
+  (let lp ((c (peek-char)) (chars '()))
+    (if (or (eof-object? c)
+            (not (or (char-alphabetic? c)
+                     (char-numeric? c)
+                     (char=? c #\$)
+                     (char=? c #\_))))
+        (let ((word (list->string (reverse chars))))
+          (cond ((assoc-ref *keywords* word)
+                 (make-lexical-token (assoc-ref *keywords* word) loc #f))
+                (else (make-lexical-token 'Identifier loc
+                                          (string->symbol word)))))
+        (begin (read-char)
+               (lp (peek-char) (cons c chars))))))
+
+(define (read-numeric loc)
+  (let* ((c0 (if (char=? (peek-char) #\.)
+                 #\0
+                 (read-char)))
+         (c1 (peek-char)))
+    (cond
+     ((eof-object? c1) (digit->number c0))
+     ((and (char=? c0 #\0) (or (char=? c1 #\x) (char=? c1 #\X)))
+      (read-char)
+      (let ((c (peek-char)))
+        (if (not (char-hex? c))
+            (syntax-error "bad digit reading hexadecimal number"
+                          loc c))
+        (let lp ((c c) (acc 0))
+          (cond ((char-hex? c)
+                 (read-char)
+                 (lp (peek-char)
+                     (+ (* 16 acc) (hex->number c))))
+                (else
+                 acc)))))
+     ((and (char=? c0 #\0) (char-numeric? c1))
+      (let lp ((c c1) (acc 0))
+        (cond ((eof-object? c) acc)
+              ((char-numeric? c)
+               (if (or (char=? c #\8) (char=? c #\9))
+                   (syntax-error "invalid digit in octal sequence"
+                                 loc c))
+               (read-char)
+               (lp (peek-char)
+                   (+ (* 8 acc) (digit->number c))))
+              (else
+               acc))))
+     (else
+      (let lp ((c1 c1) (acc (digit->number c0)))
+        (cond
+         ((eof-object? c1) acc)
+         ((char-numeric? c1)
+          (read-char)
+          (lp (peek-char)
+              (+ (* 10 acc) (digit->number c1))))
+         ((or (char=? c1 #\e) (char=? c1 #\E))
+          (read-char)
+          (let ((add (let ((c (peek-char)))
+                       (cond ((eof-object? c)
+                              (syntax-error "error reading exponent: EOF"
+                                            loc #f))
+                             ((char=? c #\+) (read-char) +)
+                             ((char=? c #\-) (read-char) -)
+                             ((char-numeric? c) +)
+                             (else
+                              (syntax-error "error reading exponent: non-digit"
+                                            loc c))))))
+            (let lp ((c (peek-char)) (e 0))
+              (cond ((and (not (eof-object? c)) (char-numeric? c))
+                     (read-char)
+                     (lp (peek-char) (add (* 10 e) (digit->number c))))
+                    (else
+                     (* (if (negative? e) (* acc 1.0) acc) (expt 10 e)))))))
+         ((char=? c1 #\.)
+          (read-char)
+          (let lp2 ((c (peek-char)) (dec 0.0) (n -1))
+            (cond ((and (not (eof-object? c)) (char-numeric? c))
+                   (read-char)
+                   (lp2 (peek-char)
+                        (+ dec (* (digit->number c) (expt 10 n)))
+                        (1- n)))
+                  (else
+                   ;; loop back to catch an exponential part
+                   (lp c (+ acc dec))))))
+         (else
+          acc)))))))
+           
+(define *punctuation*
+  '(("{" . lbrace)
+    ("}" . rbrace)
+    ("(" . lparen)
+    (")" . rparen)
+    ("[" . lbracket)
+    ("]" . rbracket)
+    ("." . dot)
+    (";" . semicolon)
+    ("," . comma)
+    ("<" . <)
+    (">" . >)
+    ("<=" . <=)
+    (">=" . >=)
+    ("==" . ==)
+    ("!=" . !=)
+    ("===" . ===)
+    ("!==" . !==)
+    ("+" . +)
+    ("-" . -)
+    ("*" . *)
+    ("%" . %)
+    ("++" . ++)
+    ("--" . --)
+    ("<<" . <<)
+    (">>" . >>)
+    (">>>" . >>>)
+    ("&" . &)
+    ("|" . bor)
+    ("^" . ^)
+    ("!" . !)
+    ("~" . ~)
+    ("&&" . &&)
+    ("||" . or)
+    ("?" . ?)
+    (":" . colon)
+    ("=" . =)
+    ("+=" . +=)
+    ("-=" . -=)
+    ("*=" . *=)
+    ("%=" . %=)
+    ("<<=" . <<=)
+    (">>=" . >>=)
+    (">>>=" . >>>=)
+    ("&=" . &=)
+    ("|=" . bor=)
+    ("^=" . ^=)))
+
+(define *div-punctuation*
+  '(("/" . /)
+    ("/=" . /=)))
+
+;; node ::= (char (symbol | #f) node*)
+(define read-punctuation
+  (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*))
+                     (cond ((null? puncs)
+                            nodes)
+                           ((assv-ref nodes (string-ref (caar puncs) 0))
+                            (let ((node-tail (assv-ref nodes (string-ref (caar puncs) 0))))
+                              (if (= (string-length (caar puncs)) 1)
+                                  (set-car! node-tail (cdar puncs))
+                                  (set-cdr! node-tail
+                                            (lp (cdr node-tail)
+                                                `((,(substring (caar puncs) 1)
+                                                   . ,(cdar puncs))))))
+                              (lp nodes (cdr puncs))))
+                           (else
+                            (lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
+                                puncs))))))
+    (lambda (loc)
+      (let lp ((c (peek-char)) (tree punc-tree) (candidate #f))
+        ;;(display "read-punctuation c=") (display c) (newline)
+        (cond
+         ((assv-ref tree c)
+          (let ((node-tail (assv-ref tree c)))
+            (read-char)
+            (lp (peek-char) (cdr node-tail) (car node-tail))))
+         (candidate
+          (make-lexical-token candidate loc #f))
+         (else
+          (syntax-error "bad syntax: character not allowed" loc c)))))))
+
+(define (next-token div?)
+  (let ((c   (peek-char))
+        (loc (port-source-location (current-input-port))))
+    ;;(display "next-token c=") (display c) (newline)
+
+    (case c
+      ((#\tab #\vt #\page #\space ;;#\x00A0
+        ) ; whitespace
+       (read-char)
+       (next-token div?))
+      ((#\newline #\return)                 ; line break
+       (read-char)
+       (next-token div?))
+      ((#\/)
+       ;; division, single comment, double comment, or regexp
+       (read-slash loc div?))
+      ((#\" #\')                        ; string literal
+       (read-string loc))
+      (else
+       (cond
+        ((eof-object? c)
+         '*eoi*)
+        ((or (char-alphabetic? c)
+             (char=? c #\$)
+             (char=? c #\_))
+         ;; reserved word or identifier
+         (read-identifier loc))
+        ((char-numeric? c)
+         ;; numeric -- also accept . FIXME, requires lookahead
+         (make-lexical-token 'NumericLiteral loc (read-numeric loc)))
+        (else
+         ;; punctuation
+         (read-punctuation loc)))))))
+
+(define (c-lexer errorp)
+  (let ((div? #f))
+    (lambda ()
+      (let ((tok (next-token div?)))
+        (set! div? (and (lexical-token? tok)
+                        (let ((cat (lexical-token-category tok)))
+                          (or (eq? cat 'Identifier)
+                              (eq? cat 'NumericLiteral)
+                              (eq? cat 'StringLiteral)))))
+        tok))))
diff --git a/module/language/c/parser.mes b/module/language/c/parser.mes
new file mode 100644 (file)
index 0000000..b308fa5
--- /dev/null
@@ -0,0 +1,458 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; parser.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; parser.mes is a translation of cgram.y to Dominique Boucher's LALR.
+;;; It parses a minimal int main () {}, see examples/main.c
+
+;;; Code:
+
+(cond-expand
+  (guile
+   (use-modules (srfi srfi-1))
+   ;;(use-modules (system base lalr))
+   (use-modules (ice-9 match)))
+  (mes
+   (mes-use-module (mes base-0))
+   (mes-use-module (mes base))
+   (mes-use-module (mes quasiquote))
+   (mes-use-module (mes let))
+   (mes-use-module (mes scm))
+   (mes-use-module (mes syntax))
+   (mes-use-module (srfi srfi-0))
+   (mes-use-module (mes record-0))
+   (mes-use-module (mes record))
+   (mes-use-module (srfi srfi-9))
+   (mes-use-module (mes lalr-0))
+   (mes-use-module (mes lalr))
+
+   (mes-use-module (mes let-syntax))
+   (mes-use-module (srfi srfi-1))
+   (mes-use-module (mes match))
+
+   (mes-use-module (rnrs bytevectors))
+   (mes-use-module (mes elf))
+   (mes-use-module (mes libc-i386))))
+
+(define c-parser
+  (lalr-parser
+
+   (lbrace rbrace lparen rparen lbracket rbracket semicolon colon dot comma
+           =
+           Identifier NumericLiteral StringLiteral
+           break case continue goto label
+           return switch
+           for
+           if else
+           (left: or && ! * / + -)
+           (left: bool double float enum void int struct)
+           (left: < > <= >=)
+           (left: ++ --)
+           (nonassoc: == !=)
+           )
+   
+   (program
+    (translation-unit *eoi*) : `(root ,@$1))
+
+   (translation-unit
+    (external-declaration) : `(,$1)
+    (translation-unit external-declaration) : `(,@$1 ,@$2))
+
+   (external-declaration
+    (function-definition) : $1
+    (declaration) : $1
+    (error semicolon) : (begin (syntax-error "external declaration" @1 $1) '()))
+
+   (function-definition
+    (declarator compound-statement) : `(function ,$1 (signature int (formals)) ,$2)
+    (declaration-specifiers declarator compound-statement) : `(function ,$2 (signature ,$1 (formals)) ,$3)
+    (declaration-specifiers declarator declaration-list compound-statement) : `(function ,$2 (signature ,$1 ,$3) ,$4))
+
+   (declaration
+    (declaration-specifiers semicolon) : `(,$1)
+    (declaration-specifiers init-declarator-list semicolon): `((,@$1 ,@$2))
+    )
+
+   (declaration-list
+    (declaration) : `(formals ,@$1)
+    (declaration-list declaration) : `(,@$1 ,@(cdr $2)))
+
+   (declaration-specifiers
+    ;;(storage-class-specifier) : `(,$1)
+    (type-specifier) : `(,$1)
+    ;;(type-qualifier) : `($1)
+    ;;(storage-class-specifier declaration-specifiers) : (cons $1 $2)
+    (type-specifier declaration-specifiers) : `(,$1 ,$2)
+    ;;(type-qualifier declaration-specifiers) : (cons $1 $2)
+    )
+
+   ;; (storage_class_specifier
+   ;;  (auto)
+   ;;  (extern)
+   ;;  (register)
+   ;;  (static)
+   ;;  (typedef))
+   
+   (type-specifier
+    ;; (char) : $1
+    ;; (double) : $1
+    ;; (void) : $1
+    ;; (float)
+    (int) : 'int
+    ;; (long)
+    ;; (short)
+    ;; (unsigned)
+    ;; (struct-or-enum-specifier)
+    ;; (enum-specifier)
+    ;; (type-name)
+    )
+
+   ;; (type-qualifier
+   ;;  (const)
+   ;;  (volatile))
+
+   ;; struct_or_union_specifier:
+   ;;             struct_or_union_ident lbrace struct_declaration_list rbrace
+   ;;          |  struct_or_union_ident
+   ;;          ;
+
+   ;; struct_or_union_ident: struct_or_union
+   ;;          | struct_or_union Identifier
+   ;;          ;
+
+   ;; struct_or_union:   STRUCT                                { ; }
+   ;;          |  UNION                                { ; }
+   ;;          ;
+   
+   ;; struct_declaration_list: struct_declaration
+   ;;          |  struct_declaration_list struct_declaration
+   ;;          ;
+
+   (init-declarator-list
+    ;; (init-declarator %prec comma) : `(,$1) HUH?
+    (init-declarator) : `(,$1)
+    (init-declarator-list comma init-declarator) : `(,$1)
+    )
+   ;; init_declarator_list:     init_declarator %prec comma
+   ;;          |  init_declarator_list comma init_declarator
+   ;;          ;
+
+   (init-declarator
+    (declarator) : $1
+    (declarator = initializer) : `(= ,$1 ,$3)
+    ;;                 | error { yyerror("init declarator error"); }
+    )
+
+   ;; struct_declaration: specifier_qualifier_list struct_declarator_list semicolon
+   ;;          ;
+
+   ;; specifier_qualifier_list: type_specifier
+   ;;          |  type_qualifier
+   ;;          |  type_specifier specifier_qualifier_list
+   ;;          | type_qualifier specifier_qualifier_list
+   ;;          ;
+
+   ;; struct_declarator_list: struct_declarator
+   ;;          |  struct_declarator_list comma struct_declarator
+   ;;          ;
+
+   ;; struct_declarator: declarator
+   ;;          |  COLON constant_expression            { ; }
+   ;;          |  declarator COLON constant_expression
+   ;;          ;
+
+   ;; enum_specifier:     ENUM Identifier lbrace enumerator_list rbrace        { ; }
+   ;;          |  ENUM lbrace enumerator_list rbrace           { ; }
+   ;;          |  ENUM Identifier                              { ; }
+   ;;          ;
+
+   ;; enumerator_list:   enumerator
+   ;;          |  enumerator_list comma enumerator
+   ;;          ;
+
+   ;; enumerator:                 Identifier
+   ;;          |  Identifier EQ constant_expression
+   ;;          ;
+
+   (declarator
+    (direct-declarator) : $1
+    ;;(pointer direct-declarator)
+    )
+
+   (direct-declarator
+    (Identifier) : $1
+    ;; (lparen declarator rparen)
+    ;; (direct-declarator lbracket rbracket)
+    ;; (direct-declarator lbracket constant-expression rbracket)
+    ;; (lbracket constant-expression rbracket)
+    ;; (direct-declarator lparen parameter-type-list rparen)
+    (direct-declarator lparen rparen) : $1
+    ;; (direct-declarator lparen identifier-list rparen)
+    )
+
+   ;; pointer:    STAR                                 { ; }
+   ;;          |  STAR pointer                         { ; }
+   ;;          |  STAR type_qualifier_list             { ; }
+   ;;          |  STAR type_qualifier_list pointer     { ; }
+   ;;          ;
+
+   ;; type_qualifier_list: type_qualifier
+   ;;          |  type_qualifier_list type_qualifier
+   ;;          ;
+
+   ;; parameter_type_list: parameter_list
+   ;;          | parameter_list comma ELLIPSIS
+   ;;          ;
+
+   ;; parameter_list:     parameter_declaration
+   ;;          |  parameter_list comma parameter_declaration
+   ;;          ;
+
+   ;; parameter_declaration:
+   ;;             declaration_specifiers declarator
+   ;;          |  declaration_specifiers
+   ;;          |  declaration_specifiers abstract_declarator
+   ;;          ;
+
+   ;; identifier_list:        Identifier
+   ;;          |  identifier_list comma Identifier
+   ;;          |  error { yyerror("identifier list error"); }
+   ;;          ;
+
+   (initializer
+    ;;(assignment-expression %prec comma) HUH?
+    (assignment-expression) : $1
+    ;; initializer:       assignment_expression %prec comma
+    ;;                 |  lbrace initializer_list rbrace               { ; }
+    ;;                 |  lbrace initializer_list comma rbrace         { ; }
+    ;;                 ;
+    )
+
+   ;; initializer_list:         initializer %prec comma
+   ;;          |  initializer_list comma initializer
+   ;;          ;
+
+   ;; type_name:          specifier_qualifier_list
+   ;;          |  specifier_qualifier_list abstract_declarator
+   ;;          ;
+
+   ;; abstract_declarator:     pointer
+   ;;          |  direct_abstract_declarator
+   ;;          |  pointer direct_abstract_declarator
+   ;;          ;
+
+   ;; direct_abstract_declarator:
+   ;;             lparen abstract_declarator rparen            { ; }
+   ;;          |  lbrace rbrace                                { ; }
+   ;;          |  direct_abstract_declarator lbrace rbrace
+   ;;          |  lbrace constant_expression rbrace            { ; }
+   ;;          |  direct_abstract_declarator lbrace constant_expression rbrace
+   ;;          |  lparen rparen                                { ; }
+   ;;          |  direct_abstract_declarator lparen rparen
+   ;;          |  lparen parameter_list rparen                 { ; }
+   ;;          |  direct_abstract_declarator lparen parameter_list rparen
+   ;;          ;
+
+   
+   (statement
+    ;;(labeled-statement) 
+    (expression-statement) : $1
+    (compound-statement) : $1
+    ;;(selection-statement)
+    (iteration-statement) : $1
+    (jump-statement) : $1
+    (semicolon) : '()
+    (error semicolon) : (begin (syntax-error "statement error" @1 $1) '())
+    (error rbrace) : (begin (syntax-error "statement error" @1 $1) '()))
+               
+
+   ;; labeled_statement:
+   ;;             Identifier COLON statement
+   ;;          |  CASE x COLON statement               { ; }
+   ;;          |  DEFAULT COLON statement              { ; }
+   ;;          ;
+
+   (expression-statement
+    (x semicolon) : $1)
+
+   (compound-statement
+    (lbrace rbrace) : '(compound)
+    (lbrace declaration-list rbrace) : `(compound ,$2)
+    (lbrace statement-list rbrace) :  `(compound ,@$2)
+    (lbrace declaration-list statement-list rbrace) : `(compound ,$2 ,@$3))
+
+   (statement-list
+    (statement) : `(,$1)
+    (statement-list statement) : `(,@$1 ,$2))
+   
+   ;; selection_statement:
+   ;;             IF lparen x rparen statement                 { ; }
+   ;;          |  IF lparen x rparen statement ELSE statement  { ; }
+   ;;          |  SWITCH lparen x rparen statement             { ; }
+   ;;          ;
+
+   (iteration-statement
+    ;; iteration_statement:
+    ;;                    WHILE lparen x rparen statement              { ; }
+    ;;                 |  DO statement WHILE lparen x rparen semicolon { ; }
+    (for lparen forcntrl rparen statement) : `(for ,@$3 ,$5))
+   
+   (forcntrl
+    ;;                 | semicolon semicolon x                         { ; }
+    ;;                 | semicolon x semicolon                         { ; }
+    ;;                 | semicolon x semicolon x                               { ; }
+    ;;                 | x semicolon semicolon
+    ;;                 | x semicolon semicolon x
+    ;;                 | x semicolon x semicolon
+    (x semicolon x semicolon x) : `((start ,$1) (test ,$3) (step ,$5)))
+
+   (jump-statement
+    (goto Identifier semicolon) : `(goto ,$2)
+    (continue semicolon) : '(continue)
+    (break semicolon) : '(break)
+    (return semicolon) : '(return)
+    (return x semicolon) : `(return ,$2))
+
+   (x
+    (assignment-expression) : $1
+    (x comma assignment-expression) : `(,$1 ,@$3))
+               
+   (assignment-expression
+    (equality-expression) : $1 ;; skip some
+    ;;(conditional-expression) : $1
+    (unary-expression assignment-operator assignment-expression) : `(,$2 ,$1 ,$3))
+
+   (assignment-operator
+    (=) : '=)
+   ;;          |  PLUSEQ                               { ; }
+   ;;          |  MINUSEQ                              { ; }
+   ;;          |  MUEQ                                 { ; }
+   ;;          |  DIVEQ                                { ; }
+   ;;          |  MODEQ                                { ; }
+   ;;          |  SLEQ                         { ; }
+   ;;          |  SREQ                         { ; }
+   ;;          |  ANEQ                         { ; }
+   ;;          |  OREQ                         { ; }
+   ;;          |  XOREQ                                { ; }
+   ;;          ;
+
+   ;; conditional_expression: logical_or_expression
+   ;;          |  logical_or_expression IF_THEN x COLON conditional_expression
+   ;;          ;
+
+   ;; constant_expression: conditional_expression
+   ;;          ;
+
+   ;; logical_or_expression: logical_and_expression
+   ;;          |  logical_or_expression OROR logical_and_expression
+   ;;          ;
+
+   ;; logical_and_expression: inclusive_or_expression
+   ;;          |  logical_and_expression ANDAND inclusive_or_expression
+   ;;          ;
+
+   ;; inclusive_or_expression: exclusive_or_expression
+   ;;          |  inclusive_or_expression OR exclusive_or_expression
+   ;;          ;
+
+   ;; exclusive_or_expression: and_expression
+   ;;          |  exclusive_or_expression XOR and_expression
+   ;;          ;
+
+   ;; and_expression: equality_expression
+   ;;          |  and_expression AND equality_expression
+   ;;          ;
+
+   (equality-expression
+    (relational-expression) : $1
+    (equality-expression == relational-expression) : `(== ,$1 ,$3)
+    (equality-expression != relational-expression) : `(!= ,$1 ,$3))
+
+   (relational-expression
+    (shift-expression) : $1
+    (relational-expression < shift-expression) : `(< ,$1 ,$3)
+    (relational-expression <= shift-expression) : `(<= ,$1 ,$3)
+    (relational-expression > shift-expression) : `(> ,$1 ,$3)
+    (relational-expression >= shift-expression) : `(>= ,$1 ,$3))
+
+   (shift-expression
+    (unary-expression) : $1 ;; skip some
+    ;; shift_expression: additive_expression
+    ;;                 |  shift_expression LTLT additive_expression
+    ;;                 |  shift_expression GTGT additive_expression
+    ;;                 ;
+    )
+   ;; additive_expression: multiplicative_expression
+   ;;          |  additive_expression PLUS multiplicative_expression
+   ;;          |  additive_expression MINUS multiplicative_expression
+   ;;          ;
+
+   ;; multiplicative_expression: cast_expression
+   ;;          |  multiplicative_expression STAR cast_expression
+   ;;          |  multiplicative_expression DIV cast_expression
+   ;;          |  multiplicative_expression MOD cast_expression
+   ;;          ;
+
+   ;; cast_expression:   unary_expression
+   ;;          |  lparen type_name rparen cast_expression      { ; }
+   ;;          ;
+
+   (unary-expression
+    (postfix-expression) : $1
+    (++ unary-expression) : `(++x ,$2)
+    (-- unary-expression) : `(--x ,$2)
+   ;;          |  SIZEOF unary_expression              { ; }
+   ;;          |  SIZEOF lparen type_name rparen %prec SIZEOF  { ; }
+   ;;          |  STAR cast_expression                 { ; }
+   ;;          |  AND cast_expression                  { ; }
+   ;;          |  MINUS cast_expression                { ; }
+   ;;          |  PLUS cast_expression                 { ; }
+   ;;          |  NEG cast_expression                  { ; }
+   ;;          |  NOT cast_expression                  { ; }
+   ;;          ;
+    )
+
+   (postfix-expression
+    (primary-expression) : $1
+    ;;                 |  postfix_expression lbracket x rbracket
+    (postfix-expression lparen rparen) : `(call ,$1 (arguments))
+    (postfix-expression lparen argument-expression-list rparen) : `(call ,$1 ,$3)
+    ;;                 |  postfix_expression FOLLOW Identifier
+    ;;                 |  postfix_expression DOT Identifier
+    (postfix-expression ++) : `(x++ ,$1)
+    (postfix-expression --) : `(x-- ,$1)
+    )
+
+   (primary-expression
+    (Identifier): $1
+    (NumericLiteral) : $1
+    ;; INT_LITERAL
+    ;; CHAR_LITERAL
+    ;; FLOAT_LITERAL
+    ;; STRING_LITERAL
+    (StringLiteral) : $1
+    ;; lparen x rparen
+    )
+   ;;          
+
+   (argument-expression-list
+    (assignment-expression) : `(arguments ,$1)
+    (argument-expression-list comma assignment-expression): `(,@$1 ,@(cdr $3)))))
diff --git a/module/language/paren.mes b/module/language/paren.mes
new file mode 100644 (file)
index 0000000..1c0909d
--- /dev/null
@@ -0,0 +1,189 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2008 Derek Peschel
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; paren.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; paren.mes is a simple yet full lalr test for Mes taken from the
+;;; Gambit wiki.
+;;;
+;;; Run with Guile:
+;;;    echo '___P((()))' | guile -s <(echo '(paren-depth)' | cat cc/paren.mes -)
+
+;;; Code:
+
+(cond-expand
+  (guile
+    (use-modules (system base lalr))
+   )
+  (mes
+   (mes-use-module (mes base-0))
+   (mes-use-module (mes base))
+   (mes-use-module (mes quasiquote))
+   (mes-use-module (mes let))
+   (mes-use-module (mes scm))
+   (mes-use-module (mes syntax))
+   (mes-use-module (srfi srfi-0))
+   (mes-use-module (mes record-0))
+   (mes-use-module (mes record))
+   (mes-use-module (srfi srfi-9))
+   (mes-use-module (mes lalr-0))
+   (mes-use-module (mes lalr))
+   ))
+
+;;; Taken from http://gambitscheme.org/wiki/index.php/Lalr_example
+;;; LGPL 2.1 / Apache 2.0
+
+;;; 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))))
diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes
new file mode 100644 (file)
index 0000000..492e2ef
--- /dev/null
@@ -0,0 +1,76 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; base-0.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; base-0.mes is the first file being loaded from the Mes core.  It
+;;; provides primitives that use Mes internals to create the illusion
+;;; of compatibility with Guile.  It is not safe to be run by Guile.
+
+;;; Code:
+
+(define eval eval-env)
+(define (apply f x) (apply-env f x (current-module)))
+(define (primitive-eval e) (eval-env e (current-module)))
+(define (expand-macro e) (expand-macro-env e (current-module)))
+
+(define quotient /)
+
+(define-macro (defined? x)
+  (list 'assq x '(cddr (current-module))))
+
+(define (current-input-port) 0)
+(define (current-output-port) 1)
+(define (current-error-port) 2)
+(define (port-filename port) "<stdin>")
+(define (port-line port) 0)
+(define (port-column port) 0)
+(define (ftell port) 0)
+(define (false-if-exception x) x)
+
+(define (cons* x . rest)
+  (define (loop rest)
+    (if (null? (cdr rest)) (car rest)
+        (cons (car rest) (loop (cdr rest)))))
+  (loop (cons x rest)))
+
+(define-macro cond
+  (lambda clauses
+    (if (null? clauses) *unspecified*
+        (if (null? (cdr clauses))
+            (list 'if (car (car clauses))
+                  (cons* 'begin (car (car clauses)) (cdr (car clauses)))
+                  *unspecified*)
+            (if (eq? (car (cadr clauses)) 'else)
+                (list 'if (car (car clauses))
+                      (cons* 'begin (car (car clauses)) (cdr (car clauses)))
+                      (cons* 'begin *unspecified* (cdr (cadr clauses))))
+                (list 'if (car (car clauses))
+                      (cons* 'begin (car (car clauses)) (cdr (car clauses)))
+                      (cons* 'cond (cdr clauses))))))))
+
+(define else #t)
+
+(define-macro (simple-let bindings . rest)
+  (cons (cons 'lambda (cons (map car bindings) rest))
+        (map cadr bindings)))
+
+(define-macro (let bindings . rest)
+  (cons* 'simple-let bindings rest))
diff --git a/module/mes/base.mes b/module/mes/base.mes
new file mode 100644 (file)
index 0000000..41f6247
--- /dev/null
@@ -0,0 +1,81 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; base.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+
+;;; base.mes is being loaded after base0.mes.  It provides the minimal
+;;; set of scheme primitives to run lib/test.mes.  It is safe to be
+;;; run by Guile.
+
+;;; Code:
+
+(define-macro (mes-use-module . rest) #t)
+
+(define (identity x) x)
+
+(define-macro (or . x)
+  (if (null? x) #f
+      (if (null? (cdr x)) (car x)
+          (list 'if (car x) (car x)
+                (cons* 'or (cdr x))))))
+
+(define-macro (and . x)
+  (if (null? x) #t
+      (if (null? (cdr x)) (car x)
+          (list 'if (car x) (cons 'and (cdr x))
+                #f))))
+
+(define (not x)
+  (if x #f #t))
+
+(define (equal? a b) ;; FIXME: only 2 arg
+  (if (and (null? a) (null? b)) #t
+      (if (and (pair? a) (pair? b))
+          (and (equal? (car a) (car b))
+               (equal? (cdr a) (cdr b)))
+          (if (and (string? a) (string? b))
+              (eq? (string->symbol a) (string->symbol b))
+              (if (and (vector? a) (vector? b))
+                  (equal? (vector->list a) (vector->list b))
+                  (eq? a b))))))
+
+(define (memq x lst)
+  (if (null? lst) #f
+      (if (eq? x (car lst)) lst
+          (memq x (cdr lst)))))
+
+(define guile? (not (pair? (current-module))))
+
+(define (map f l . r)
+  (if (null? l) '()
+      (if (null? r) (cons (f (car l)) (map f (cdr l)))
+          (if (null? (cdr r))
+              (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))))))
+
+(define (list? x)
+  (or (null? x)
+      (and (pair? x) (list? (cdr x)))))
+
+(define (procedure? p)
+  (cond ((builtin? p) #t)
+        ((and (pair? p) (eq? (car p) 'lambda)))
+        ((and (pair? p) (eq? (car p) '*closure*)))
+        (#t #f)))
diff --git a/module/mes/elf.mes b/module/mes/elf.mes
new file mode 100644 (file)
index 0000000..ba0dd5f
--- /dev/null
@@ -0,0 +1,215 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; elf.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; elf.mes - produce a i386 elf executable.
+
+;;; Code:
+
+(define (int->bv32 value)
+  (let ((bv (make-bytevector 4)))
+    (bytevector-u32-native-set! bv 0 value)
+    bv))
+
+(define (int->bv16 value)
+  (let ((bv (make-bytevector 2)))
+    (bytevector-u16-native-set! bv 0 value)
+    bv))
+
+(define elf32-addr int->bv32)
+(define elf32-half int->bv16)
+(define elf32-off int->bv32)
+(define elf32-word int->bv32)
+
+(define (make-elf text data)
+ (define vaddress #x08048000)
+
+ (define ei-magic `(#x7f ,@(string->list "ELF")))
+ (define ei-class '(#x01)) ;; 32 bit
+ (define ei-data '(#x01)) ;; little endian
+ (define ei-version '(#x01))
+ (define ei-osabi '(#x00))
+ (define ei-pad '(#x0 #x0 #x0 #x0 #x0 #x0 #x0 #x0))
+ (define e-ident
+   (append
+    ei-magic
+    ei-class
+    ei-data
+    ei-version
+    ei-osabi
+    ei-pad))
+
+ (define ET-EXEC 2)
+ (define EM-386 3)
+ (define EV-CURRENT 1)
+
+ (define p-filesz (elf32-word 0))
+ (define p-memsz (elf32-word 0))
+ (define PF-X 1)
+ (define PF-W 2)
+ (define PF-R 4)
+ (define p-flags (elf32-word (logior PF-X PF-W PF-R)))
+ (define p-align (elf32-word 1))
+
+ (define (program-header type offset text)
+   (append
+    (elf32-word type)
+    (elf32-off offset)
+    (elf32-addr (+ vaddress offset))
+    (elf32-addr (+ vaddress offset))
+    (elf32-word (length text))
+    (elf32-word (length text))
+    p-flags
+    p-align
+    ))
+
+ (define (section-header name type offset text)
+   (append
+    (elf32-word name)
+    (elf32-word type)
+    (elf32-word 3) ;; write/alloc must for data hmm
+    (elf32-addr (+ vaddress offset))
+    (elf32-off offset) 
+    (elf32-word (length text))
+    (elf32-word 0)
+    (elf32-word 0)
+    (elf32-word 1)
+    (elf32-word 0)))
+
+
+ (define e-type (elf32-half ET-EXEC))
+ (define e-machine (elf32-half EM-386))
+ (define e-version (elf32-word EV-CURRENT))
+ (define e-entry (elf32-addr 0))
+ ;;(define e-entry (elf32-addr (+ vaddress text-offset)))
+ ;;(define e-phoff (elf32-off 0))
+ (define e-shoff (elf32-off 0))
+ (define e-flags (elf32-word 0))
+ ;;(define e-ehsize (elf32-half 0))
+ (define e-phentsize (elf32-half (length (program-header 0 0 '()))))
+ (define e-phnum (elf32-half 1))
+ (define e-shentsize (elf32-half (length (section-header 0 0 0 '()))))
+ (define e-shnum (elf32-half 5))
+ (define e-shstrndx (elf32-half 4))
+
+ (define (elf-header size entry sections)
+   (append
+    e-ident
+    e-type
+    e-machine
+    e-version
+    (elf32-addr (+ vaddress entry)) ;; e-entry
+    (elf32-off size) ;; e-phoff
+    (elf32-off sections) ;; e-shoff
+    e-flags
+    (elf32-half size) ;; e-ehsize
+    e-phentsize
+    e-phnum
+    e-shentsize
+    e-shnum
+    e-shstrndx
+    ))
+
+ (define elf-header-size
+   (length (elf-header 0 0 0)))
+
+ (define program-header-size
+   (length (program-header 0 0 '())))
+
+ (define text-offset
+   (+ elf-header-size program-header-size))
+
+ (define (program-headers)
+   (append
+    (program-header 1 text-offset (text 0))
+    ))
+
+
+ (define note
+   (string->list
+    (string-append
+     "MES"
+     ;;"Mes -- Maxwell Equations of Software\n"
+     ;;"https://gitlab.com/janneke/mes"
+     )
+    ;; #x05 #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x02 #x00 #x00 #x00
+    ;; #\i #\3 #\8 #\6 #x00 #x00 #x00 #x00
+    ))
+
+ (define tab
+   `(
+     #x00 ,@(string->list ".shstrtab")
+          #x00 ,@(string->list ".text")
+          #x00 ,@(string->list ".data")
+          #x00 ,@(string->list ".note")
+          #x00 #x00 #x00 #x00
+          ))
+
+ (define text-length
+   (length (text 0)))
+
+ (define data-offset
+   (+ text-offset text-length))
+
+ (define data-address (+ data-offset vaddress))
+
+ (define data-length
+   (length data))
+
+ (define note-length
+   (length note))
+
+ (define note-offset
+   (+ data-offset data-length))
+
+ (define tab-offset
+   (+ note-offset note-length))
+
+ (define tab-length
+   (length tab))
+
+ (define section-headers-offset
+   (+ tab-offset tab-length))
+
+
+ (define SHT-PROGBITS 1)
+ (define SHT-STRTAB 3)
+ (define SHT-NOTE 7)
+ (define (section-headers)
+   (append
+    (section-header 0 0 0 '())
+    (section-header 11 SHT-PROGBITS text-offset (text 0))
+    (section-header 17 SHT-PROGBITS data-offset data)
+    (section-header 23 SHT-NOTE note-offset note)
+    (section-header 1 SHT-STRTAB tab-offset tab)
+    ))
+
+ (define exe
+   (append
+    (elf-header elf-header-size text-offset section-headers-offset)
+    (program-headers)
+    (text data-address)
+    data
+    note
+    tab
+    (section-headers)
+    ))
+ exe)
diff --git a/module/mes/lalr-0.mes b/module/mes/lalr-0.mes
new file mode 100644 (file)
index 0000000..400b0a8
--- /dev/null
@@ -0,0 +1,33 @@
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; lalr-0.mes: This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; lalr-0.mes has mes-specific definitions needed for lalr.mes
+
+;;; Code:
+
+(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)
diff --git a/module/mes/lalr.mes b/module/mes/lalr.mes
new file mode 100644 (file)
index 0000000..a73501a
--- /dev/null
@@ -0,0 +1,2120 @@
+;;;
+;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
+;;;
+;; Copyright 2014  Jan Nieuwenhuizen <janneke@gnu.org>
+;; Copyright 1993, 2010 Dominique Boucher
+;;
+;; This program 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 3 of
+;; the License, or (at your option) any later version.
+;;
+;; This program 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 General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+
+(define *lalr-scm-version* "2.5.0")
+
+(cond-expand 
+
+ ;; -- Gambit-C
+ (gambit
+
+   (display "Gambit-C!")
+   (newline)
+   
+  (define-macro (def-macro form . body)
+    `(define-macro ,form (let () ,@body)))
+
+  (def-macro (BITS-PER-WORD) 28)
+  (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
+  (def-macro (lalr-error msg obj) `(error ,msg ,obj))
+
+  (define pprint pretty-print)
+  (define lalr-keyword? keyword?)
+  (define (note-source-location lvalue tok) lvalue))
+ ;; -- 
+ (bigloo
+  (define-macro (def-macro form . body)
+    `(define-macro ,form (let () ,@body)))
+
+  (define pprint (lambda (obj) (write obj) (newline)))
+  (define lalr-keyword? keyword?)
+  (def-macro (BITS-PER-WORD) 29)
+  (def-macro (logical-or x . y) `(bit-or ,x ,@y))
+  (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
+ ;; -- Chicken
+ (chicken
+  
+  (define-macro (def-macro form . body)
+    `(define-macro ,form (let () ,@body)))
+
+  (define pprint pretty-print)
+  (define lalr-keyword? symbol?)
+  (def-macro (BITS-PER-WORD) 30)
+  (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
+  (def-macro (lalr-error msg obj) `(error ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
+
+ ;; -- STKlos
+ (stklos
+  (require "pp")
+
+  (define (pprint form) (pp form :port (current-output-port)))
+
+  (define lalr-keyword? keyword?)
+  (define-macro (BITS-PER-WORD) 30)
+  (define-macro (logical-or x . y) `(bit-or ,x ,@y))
+  (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
+
+ ;; -- Guile
+ (guile
+  (use-modules (ice-9 pretty-print))
+  (use-modules (srfi srfi-9))
+
+  (define pprint pretty-print)
+  (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)
+    (if (and (supports-source-properties? lvalue)
+             (not (source-property lvalue 'loc))
+             (lexical-token? tok))
+        (set-source-property! lvalue 'loc (lexical-token-source tok)))
+    lvalue))
+
+ ;; -- Mes
+  (mes
+   (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)
+  (define (BITS-PER-WORD) 30)
+  (define logical-or logior)
+  (define (lalr-keyword? obj) (keyword? obj))
+  (define (pprint obj) (pretty-print obj))
+  (define (lalr-error msg obj) (error msg obj))
+  (define (note-source-location lvalue tok) lvalue))
+
+ ;; -- SISC
+ (sisc
+  (import logicops)
+  (import record)
+       
+  (define pprint pretty-print)
+  (define lalr-keyword? symbol?)
+  (define-macro BITS-PER-WORD (lambda () 32))
+  (define-macro logical-or (lambda (x . y) `(logor ,x ,@y)))
+  (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
+       
+ ;; -- Gauche
+ (gauche
+  (use gauche.record)
+  (define-macro (def-macro form . body)
+    `(define-macro ,form (let () ,@body)))
+  (define pprint (lambda (obj) (write obj) (newline)))
+  (define lalr-keyword? symbol?)
+  (def-macro (BITS-PER-WORD) 30)
+  (def-macro (logical-or x . y) `(logior ,x . ,y))
+  (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
+  (define (note-source-location lvalue tok) lvalue))
+
+ (else
+  (error "Unsupported Scheme system")))
+
+
+(define-record-type lexical-token
+  (make-lexical-token category source value)
+  lexical-token?
+  (category lexical-token-category)
+  (source   lexical-token-source)
+  (value    lexical-token-value))
+
+
+(define-record-type source-location
+  (make-source-location input line column offset length)
+  source-location?
+  (input   source-location-input)
+  (line    source-location-line)
+  (column  source-location-column)
+  (offset  source-location-offset)
+  (length  source-location-length))
+
+
+
+      ;; - Macros pour la gestion des vecteurs de bits
+
+(define-macro (lalr-parser . arguments)
+  (define (set-bit v b)
+    (let ((x (quotient b (BITS-PER-WORD)))
+         (y (expt 2 (remainder b (BITS-PER-WORD)))))
+      (vector-set! v x (logical-or (vector-ref v x) y))))
+
+  (define (bit-union v1 v2 n)
+    (do ((i 0 (+ i 1)))
+       ((= i n))
+      (vector-set! v1 i (logical-or (vector-ref v1 i)
+                                   (vector-ref v2 i)))))
+
+  ;; - Macro pour les structures de donnees
+
+  (define (new-core)              (make-vector 4 0))
+  (define (set-core-number! c n)  (vector-set! c 0 n))
+  (define (set-core-acc-sym! c s) (vector-set! c 1 s))
+  (define (set-core-nitems! c n)  (vector-set! c 2 n))
+  (define (set-core-items! c i)   (vector-set! c 3 i))
+  (define (core-number c)         (vector-ref c 0))
+  (define (core-acc-sym c)        (vector-ref c 1))
+  (define (core-nitems c)         (vector-ref c 2))
+  (define (core-items c)          (vector-ref c 3))
+
+  (define (new-shift)              (make-vector 3 0))
+  (define (set-shift-number! c x)  (vector-set! c 0 x))
+  (define (set-shift-nshifts! c x) (vector-set! c 1 x))
+  (define (set-shift-shifts! c x)  (vector-set! c 2 x))
+  (define (shift-number s)         (vector-ref s 0))
+  (define (shift-nshifts s)        (vector-ref s 1))
+  (define (shift-shifts s)         (vector-ref s 2))
+
+  (define (new-red)                (make-vector 3 0))
+  (define (set-red-number! c x)    (vector-set! c 0 x))
+  (define (set-red-nreds! c x)     (vector-set! c 1 x))
+  (define (set-red-rules! c x)     (vector-set! c 2 x))
+  (define (red-number c)           (vector-ref c 0))
+  (define (red-nreds c)            (vector-ref c 1))
+  (define (red-rules c)            (vector-ref c 2))
+
+
+  (define (new-set nelem)
+    (make-vector nelem 0))
+
+
+  (define (vector-map f v)
+    (let ((vm-n (- (vector-length v) 1)))
+      (let loop ((vm-low 0) (vm-high vm-n))
+       (if (= vm-low vm-high)
+           (vector-set! v vm-low (f (vector-ref v vm-low) vm-low))
+           (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
+             (loop vm-low vm-middle)
+             (loop (+ vm-middle 1) vm-high))))))
+
+
+  ;; - Constantes
+  (define STATE-TABLE-SIZE 1009)
+
+
+  ;; - Tableaux 
+  (define rrhs         #f)
+  (define rlhs         #f)
+  (define ritem        #f)
+  (define nullable     #f)
+  (define derives      #f)
+  (define fderives     #f)
+  (define firsts       #f)
+  (define kernel-base  #f)
+  (define kernel-end   #f)
+  (define shift-symbol #f)
+  (define shift-set    #f)
+  (define red-set      #f)
+  (define state-table  #f)
+  (define acces-symbol #f)
+  (define reduction-table #f)
+  (define shift-table  #f)
+  (define consistent   #f)
+  (define lookaheads   #f)
+  (define LA           #f)
+  (define LAruleno     #f)
+  (define lookback     #f)
+  (define goto-map     #f)
+  (define from-state   #f)
+  (define to-state     #f)
+  (define includes     #f)
+  (define F            #f)
+  (define action-table #f)
+
+  ;; - Variables
+  (define nitems          #f)
+  (define nrules          #f)
+  (define nvars           #f)
+  (define nterms          #f)
+  (define nsyms           #f)
+  (define nstates         #f)
+  (define first-state     #f)
+  (define last-state      #f)
+  (define final-state     #f)
+  (define first-shift     #f)
+  (define last-shift      #f)
+  (define first-reduction #f)
+  (define last-reduction  #f)
+  (define nshifts         #f)
+  (define maxrhs          #f)
+  (define ngotos          #f)
+  (define token-set-size  #f)
+
+  (define driver-name     'lr-driver)
+
+  (define (glr-driver?)
+    (eq? driver-name 'glr-driver))
+  (define (lr-driver?)
+    (eq? driver-name 'lr-driver))
+
+  (define (gen-tables! tokens gram )
+    (initialize-all)
+    (rewrite-grammar
+     tokens
+     gram
+     (lambda (terms terms/prec vars gram gram/actions)
+       (set! the-terminals/prec (list->vector terms/prec))
+       (set! the-terminals (list->vector terms))
+       (set! the-nonterminals (list->vector vars))
+       (set! nterms (length terms))
+       (set! nvars  (length vars))
+       (set! nsyms  (+ nterms nvars))
+       (let ((no-of-rules (length gram/actions))
+            (no-of-items (let loop ((l gram/actions) (count 0))
+                           (if (null? l)
+                               count
+                               (loop (cdr l) (+ count (length (caar l))))))))
+        (pack-grammar no-of-rules no-of-items gram)
+        (set-derives)
+        (set-nullable)
+        (generate-states)
+        (lalr)
+        (build-tables)
+        (compact-action-table terms)
+        gram/actions))))
+
+
+  (define (initialize-all)
+    (set! rrhs         #f)
+    (set! rlhs         #f)
+    (set! ritem        #f)
+    (set! nullable     #f)
+    (set! derives      #f)
+    (set! fderives     #f)
+    (set! firsts       #f)
+    (set! kernel-base  #f)
+    (set! kernel-end   #f)
+    (set! shift-symbol #f)
+    (set! shift-set    #f)
+    (set! red-set      #f)
+    (set! state-table  (make-vector STATE-TABLE-SIZE '()))
+    (set! acces-symbol #f)
+    (set! reduction-table #f)
+    (set! shift-table  #f)
+    (set! consistent   #f)
+    (set! lookaheads   #f)
+    (set! LA           #f)
+    (set! LAruleno     #f)
+    (set! lookback     #f)
+    (set! goto-map     #f)
+    (set! from-state   #f)
+    (set! to-state     #f)
+    (set! includes     #f)
+    (set! F            #f)
+    (set! action-table #f)
+    (set! nstates         #f)
+    (set! first-state     #f)
+    (set! last-state      #f)
+    (set! final-state     #f)
+    (set! first-shift     #f)
+    (set! last-shift      #f)
+    (set! first-reduction #f)
+    (set! last-reduction  #f)
+    (set! nshifts         #f)
+    (set! maxrhs          #f)
+    (set! ngotos          #f)
+    (set! token-set-size  #f)
+    (set! rule-precedences '()))
+
+
+  (define (pack-grammar no-of-rules no-of-items gram)
+    (set! nrules (+  no-of-rules 1))
+    (set! nitems no-of-items)
+    (set! rlhs (make-vector nrules #f))
+    (set! rrhs (make-vector nrules #f))
+    (set! ritem (make-vector (+ 1 nitems) #f))
+
+    (let loop ((p gram) (item-no 0) (rule-no 1))
+      (if (not (null? p))
+         (let ((nt (caar p)))
+           (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
+             (if (null? prods)
+                 (loop (cdr p) it-no2 rl-no2)
+                 (begin
+                   (vector-set! rlhs rl-no2 nt)
+                   (vector-set! rrhs rl-no2 it-no2)
+                   (let loop3 ((rhs (car prods)) (it-no3 it-no2))
+                     (if (null? rhs)
+                         (begin
+                           (vector-set! ritem it-no3 (- rl-no2))
+                           (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
+                         (begin
+                           (vector-set! ritem it-no3 (car rhs))
+                           (loop3 (cdr rhs) (+ it-no3 1))))))))))))
+
+
+  (define (set-derives)
+    (define delts (make-vector (+ nrules 1) 0))
+    (define dset  (make-vector nvars -1))
+
+    (let loop ((i 1) (j 0))            ; i = 0
+      (if (< i nrules)
+         (let ((lhs (vector-ref rlhs i)))
+           (if (>= lhs 0)
+               (begin
+                 (vector-set! delts j (cons i (vector-ref dset lhs)))
+                 (vector-set! dset lhs j)
+                 (loop (+ i 1) (+ j 1)))
+               (loop (+ i 1) j)))))
+
+    (set! derives (make-vector nvars 0))
+
+    (let loop ((i 0))
+      (if (< i nvars)
+         (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
+                    (if (< j 0)
+                        s
+                        (let ((x (vector-ref delts j)))
+                          (loop2 (cdr x) (cons (car x) s)))))))
+           (vector-set! derives i q)
+           (loop (+ i 1))))))
+
+
+
+  (define (set-nullable)
+    (set! nullable (make-vector nvars #f))
+    (let ((squeue (make-vector nvars #f))
+         (rcount (make-vector (+ nrules 1) 0))
+         (rsets  (make-vector nvars #f))
+         (relts  (make-vector (+ nitems nvars 1) #f)))
+      (let loop ((r 0) (s2 0) (p 0))
+       (let ((*r (vector-ref ritem r)))
+         (if *r
+             (if (< *r 0)
+                 (let ((symbol (vector-ref rlhs (- *r))))
+                   (if (and (>= symbol 0)
+                            (not (vector-ref nullable symbol)))
+                       (begin
+                         (vector-set! nullable symbol #t)
+                         (vector-set! squeue s2 symbol)
+                         (loop (+ r 1) (+ s2 1) p))))
+                 (let loop2 ((r1 r) (any-tokens #f))
+                   (let* ((symbol (vector-ref ritem r1)))
+                     (if (> symbol 0)
+                         (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
+                         (if (not any-tokens)
+                             (let ((ruleno (- symbol)))
+                               (let loop3 ((r2 r) (p2 p))
+                                 (let ((symbol (vector-ref ritem r2)))
+                                   (if (> symbol 0)
+                                       (begin
+                                         (vector-set! rcount ruleno
+                                                      (+ (vector-ref rcount ruleno) 1))
+                                         (vector-set! relts p2
+                                                      (cons (vector-ref rsets symbol)
+                                                            ruleno))
+                                         (vector-set! rsets symbol p2)
+                                         (loop3 (+ r2 1) (+ p2 1)))
+                                       (loop (+ r2 1) s2 p2)))))
+                             (loop (+ r1 1) s2 p))))))
+             (let loop ((s1 0) (s3 s2))
+               (if (< s1 s3)
+                   (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
+                     (if p
+                         (let* ((x (vector-ref relts p))
+                                (ruleno (cdr x))
+                                (y (- (vector-ref rcount ruleno) 1)))
+                           (vector-set! rcount ruleno y)
+                           (if (= y 0)
+                               (let ((symbol (vector-ref rlhs ruleno)))
+                                 (if (and (>= symbol 0)
+                                          (not (vector-ref nullable symbol)))
+                                     (begin
+                                       (vector-set! nullable symbol #t)
+                                       (vector-set! squeue s4 symbol)
+                                       (loop2 (car x) (+ s4 1)))
+                                     (loop2 (car x) s4)))
+                               (loop2 (car x) s4))))
+                     (loop (+ s1 1) s4)))))))))
+
+
+
+  (define (set-firsts)
+    (set! firsts (make-vector nvars '()))
+
+    ;; -- initialization
+    (let loop ((i 0))
+      (if (< i nvars)
+         (let loop2 ((sp (vector-ref derives i)))
+           (if (null? sp)
+               (loop (+ i 1))
+               (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
+                 (if (< -1 sym nvars)
+                     (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
+                 (loop2 (cdr sp)))))))
+
+    ;; -- reflexive and transitive closure
+    (let loop ((continue #t))
+      (if continue
+         (let loop2 ((i 0) (cont #f))
+           (if (>= i nvars)
+               (loop cont)
+               (let* ((x (vector-ref firsts i))
+                      (y (let loop3 ((l x) (z x))
+                           (if (null? l)
+                               z
+                               (loop3 (cdr l)
+                                      (sunion (vector-ref firsts (car l)) z))))))
+                 (if (equal? x y)
+                     (loop2 (+ i 1) cont)
+                     (begin
+                       (vector-set! firsts i y)
+                       (loop2 (+ i 1) #t))))))))
+
+    (let loop ((i 0))
+      (if (< i nvars)
+         (begin
+           (vector-set! firsts i (sinsert i (vector-ref firsts i)))
+           (loop (+ i 1))))))
+
+
+
+
+  (define (set-fderives)
+    (set! fderives (make-vector nvars #f))
+
+    (set-firsts)
+
+    (let loop ((i 0))
+      (if (< i nvars)
+         (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
+                    (if (null? l)
+                        fd
+                        (loop2 (cdr l)
+                               (sunion (vector-ref derives (car l)) fd))))))
+           (vector-set! fderives i x)
+           (loop (+ i 1))))))
+
+
+  (define (closure core)
+    ;; Initialization
+    (define ruleset (make-vector nrules #f))
+
+    (let loop ((csp core))
+      (if (not (null? csp))
+         (let ((sym (vector-ref ritem (car csp))))
+           (if (< -1 sym nvars)
+               (let loop2 ((dsp (vector-ref fderives sym)))
+                 (if (not (null? dsp))
+                     (begin
+                       (vector-set! ruleset (car dsp) #t)
+                       (loop2 (cdr dsp))))))
+           (loop (cdr csp)))))
+
+    (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
+      (if (< ruleno nrules)
+         (if (vector-ref ruleset ruleno)
+             (let ((itemno (vector-ref rrhs ruleno)))
+               (let loop2 ((c csp) (itemsetv2 itemsetv))
+                 (if (and (pair? c)
+                          (< (car c) itemno))
+                     (loop2 (cdr c) (cons (car c) itemsetv2))
+                     (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
+             (loop (+ ruleno 1) csp itemsetv))
+         (let loop2 ((c csp) (itemsetv2 itemsetv))
+           (if (pair? c)
+&nb