From 2b577eaee0c5a31c68e9be308bfc22ed4a28bdfb Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Wed, 7 Dec 2016 20:26:41 +0100 Subject: [PATCH] Add loadable modules. * module/mes/base-0.mes (mes-use-module): Implement. * module/mes: Update users. * HACKING: Update. * NEWS: Update. * configure (main): Use shell expansion for prefix. * make/install.make (install): Substitute prefix. --- .gitignore | 2 +- AUTHORS | 8 +- GNUmakefile | 26 +- HACKING | 7 - NEWS | 6 + configure | 2 +- make/install.make | 7 + mes.c | 12 +- module/language/c/compiler.mes | 7 + module/language/c/lexer.mes | 7 +- module/language/c/parser.mes | 29 +- module/language/paren.mes | 18 +- module/mes/base-0.mes | 53 +- module/mes/base.mes | 20 +- module/mes/elf.mes | 4 +- module/mes/lalr.mes | 2134 +------------------- module/mes/lalr.upstream.mes | 2120 +++++++++++++++++++ module/mes/let.mes | 12 +- module/mes/libc-i386.mes | 2 +- module/mes/loop-0.mes | 2 +- module/mes/match.mes | 960 +-------- module/mes/match.upstream.mes | 934 +++++++++ module/mes/mes-0.mes | 2 +- module/mes/psyntax.mes | 23 + module/mes/quasiquote.mes | 13 +- module/mes/record-0.mes | 2 +- module/mes/record.mes | 2 +- module/mes/repl.mes | 46 +- module/mes/scm.mes | 4 +- module/mes/syntax.mes | 228 +-- module/mes/syntax.upstream.mes | 251 +++ module/mes/test.mes | 3 +- module/mes/type-0.mes | 2 +- module/rnrs/bytevectors.mes | 2 +- module/srfi/srfi-0.mes | 11 +- module/srfi/srfi-9.mes | 85 +- module/srfi/srfi-9.upstream.mes | 100 + posix.c | 2 +- scripts/elf.mes | 4 +- scripts/mescc.mes | 22 +- scripts/paren.mes | 15 +- scripts/repl.mes | 9 +- tests/base.test | 6 +- tests/closure.test | 6 +- tests/cwv.test | 12 +- tests/gc-0.test | 2 +- tests/gc-1.test | 2 +- tests/gc-2.test | 2 +- tests/gc-2a.test | 2 +- tests/gc-3.test | 2 +- tests/gc-4.test | 2 +- tests/gc-5.test | 2 +- tests/gc-6.test | 2 +- tests/gc.test | 6 +- tests/let-syntax.test | 9 +- tests/let.test | 7 +- tests/match.test | 14 +- module/mes/lalr-0.mes => tests/module.test | 27 +- tests/psyntax.test | 23 +- tests/quasiquote.test | 5 +- tests/read.test | 2 +- tests/record.test | 14 +- tests/scm.test | 13 +- tests/vector.test | 12 +- 64 files changed, 3725 insertions(+), 3645 deletions(-) create mode 100644 module/mes/lalr.upstream.mes create mode 100644 module/mes/match.upstream.mes create mode 100644 module/mes/psyntax.mes create mode 100644 module/mes/syntax.upstream.mes create mode 100644 module/srfi/srfi-9.upstream.mes rename module/mes/lalr-0.mes => tests/module.test (65%) mode change 100644 => 100755 diff --git a/.gitignore b/.gitignore index 6f98ac5e..02fe8e98 100644 --- a/.gitignore +++ b/.gitignore @@ -13,7 +13,7 @@ /ChangeLog /a.out /mes -/read-0.mo +/module/mes/read-0.mo /out ? ?.mes diff --git a/AUTHORS b/AUTHORS index fd443ac9..f31762bf 100644 --- a/AUTHORS +++ b/AUTHORS @@ -4,8 +4,8 @@ All files except the files listed below Based on Scheme48's scheme/alt module/mes/record.mes -module/srfi/srfi-9.mes -module/mes/syntax.mes +module/mes/syntax.upstream.mes +module/srfi/srfi-9.upstream.mes Based on Guile ECMAScript module/language/c/lexer.mes @@ -14,10 +14,10 @@ Included verbatim from gnulib build-aux/gitlog-to-changelog Portable hygienic pattern matcher -module/mes/match.mes +module/mes/match.upstream.mes Portable LALR(1) parser generator -module/mes/lalr.mes +module/mes/lalr.upstream.mes Portable syntax-case from Chez Scheme module/mes/psyntax.ss diff --git a/GNUmakefile b/GNUmakefile index fbe63fe0..21be765d 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -10,18 +10,21 @@ CFLAGS:=-std=c99 -O3 -finline-functions #CFLAGS:=-pg -std=c99 -O0 #CFLAGS:=-std=c99 -O0 -g -export BOOT -ifneq ($(BOOT),) -CFLAGS+=-DBOOT=1 -endif - include .config.make --include .local.make include make/install.make +CPPFLAGS+=-DPREFIX='"$(PREFIX)"' -all: mes +export BOOT +ifneq ($(BOOT),) +CPPFLAGS+=-DBOOT=1 +endif +-include .local.make + +all: mes module/mes/read-0.mo + +mes.o: GNUmakefile mes.o: mes.c mes.o: mes.c mes.h mes.i mes.environment.i mes.symbols.i mes.o: define.c define.h define.i define.environment.i @@ -72,16 +75,15 @@ export MES_DEBUG mes-check: all set -e; for i in $(TESTS); do ./$$i; done -dump: all - ./mes --dump < module/mes/read-0.mes > read-0.mo +module/mes/read-0.mo: module/mes/read-0.mes mes + ./mes --dump < $< > $@ + +dump: module/mes/read-0.mo guile-check: set -e; for i in $(TESTS); do\ guile -s <(cat $(MES-0) module/mes/test.mes $$i);\ done - set -e; for i in $(TESTS); do\ - guile -s <(cat $(MES-0) $$(scripts/include.mes $$i | grep -Ev 'let.mes|quasiquote.mes|match.mes|base-0|loop-0|psyntax-|srfi-0') $$i);\ - done MAIN_C:=doc/examples/main.c mescc: all diff --git a/HACKING b/HACKING index e3135515..14e44722 100644 --- a/HACKING +++ b/HACKING @@ -37,13 +37,6 @@ bootstrap binary. mes.c is ~1500 lines (~10,000LOC Assembly) which seems much too big to start translating it to assembly/hex. -** (mes-use-module ...) is a fake, see module/mes/base.mes. -All top level scripts and test files (scripts/*.mes tests/*.test) -now include appropriate (mes-use-module ...) stanzas. - -This hack allows for scripts/includes.mes to generate the list of -files to be prepended. Previously, this information was put in -GNUmakefile. ** Actually do something useful, build: [[https://en.wikipedia.org/wiki/Tiny_C_Compiler][Tiny C Compiler]] * OLD: Booting from LISP-1.5 into Mes diff --git a/NEWS b/NEWS index c9c3efdd..71cdabd9 100644 --- a/NEWS +++ b/NEWS @@ -17,6 +17,12 @@ Please send Mes bug reports to janneke@gnu.org. A variant on SICP's stop and copy Garbage Colletor (Jam Scraper?) algorithm has been implemented. *** The reader has been moved to Scheme. +** Language +*** Simple loadable modules. +*** Srfi-9 and match use handwritten syntax-rules (mes-use-module (mes syntax)). +*** Optional syntax-case using psyntax (mes-use-module (mes psyntax)). +** Noteworthy bug fixes +*** Srfi-0 has been fixed. * Changes in 0.2 since 0.1 ** Core *** Names of symbols and strings are list of characters [WAS: c-string]. diff --git a/configure b/configure index 1f0dbd97..ffc510f1 100755 --- a/configure +++ b/configure @@ -199,7 +199,7 @@ Usage: ./configure [OPTION]... (stdout "GUILE_EV:=~a\n" GUILE_EV) (stdout "PACKAGE:=~a\n" PACKAGE) (stdout "VERSION:=~a\n" VERSION) - (stdout "PREFIX:=~a\n" prefix) + (stdout "PREFIX:=~a\n" (gulp-pipe (string-append "echo " prefix))) (stdout "SYSCONFDIR:=~a\n" sysconfdir))) (stdout "\nRun: make to build mes diff --git a/make/install.make b/make/install.make index e8628d56..b4895d1f 100644 --- a/make/install.make +++ b/make/install.make @@ -53,6 +53,13 @@ install: all ChangeLog mkdir -p $(DESTDIR)$(PREFIX)/share/mes $(GIT_ARCHIVE_HEAD) module\ | tar -C $(DESTDIR)$(PREFIX)/share/mes -xf- + cp module/mes/read-0.mo $(DESTDIR)$(PREFIX)/share/mes/module/mes + sed -i -e 's@module/@$(PREFIX)/share/mes/module/@' \ + $(DESTDIR)$(PREFIX)/share/mes/module/mes/base-0.mes \ + $(DESTDIR)$(PREFIX)/bin/elf.mes \ + $(DESTDIR)$(PREFIX)/bin/mescc.mes \ + $(DESTDIR)$(PREFIX)/bin/repl.mes \ + $(DESTDIR)$(PREFIX)/bin/paren.mes mkdir -p $(DESTDIR)$(PREFIX)/share/doc/mes $(GIT_ARCHIVE_HEAD) $(READMES) \ | tar -C $(DESTDIR)$(PREFIX)/share/doc/mes -xf- diff --git a/mes.c b/mes.c index e1956300..951f7518 100644 --- a/mes.c +++ b/mes.c @@ -522,8 +522,13 @@ vm_begin_env () { SCM r = cell_unspecified; while (r1 != cell_nil) { - if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR && caar (r1) == cell_symbol_begin) - r1 = append2 (cdar (r1), cdr (r1)); + if (TYPE (r1) == PAIR && TYPE (CAR (r1)) == PAIR) + { + if (caar (r1) == cell_symbol_begin) + r1 = append2 (cdar (r1), cdr (r1)); + else if (caar (r1) == cell_symbol_primitive_load) + r1 = append2 (read_input_file_env (r0), cdr (r1)); + } r = eval_env (car (r1), r0); r1 = CDR (r1); } @@ -1211,7 +1216,8 @@ load_env (SCM a) SCM bload_env (SCM a) { - g_stdin = fopen ("read-0.mo", "r"); + g_stdin = fopen ("module/mes/read-0.mo", "r"); + g_stdin = g_stdin ? g_stdin : fopen (PREFIX "module/mes/read-0.mo", "r"); char *p = (char*)g_cells; assert (getchar () == 'M'); assert (getchar () == 'E'); diff --git a/module/language/c/compiler.mes b/module/language/c/compiler.mes index 2cd88d7c..acc63f33 100644 --- a/module/language/c/compiler.mes +++ b/module/language/c/compiler.mes @@ -25,6 +25,13 @@ ;;; Code: +(mes-use-module (mes elf)) +(mes-use-module (mes libc-i386)) +(mes-use-module (mes match)) +(mes-use-module (srfi srfi-1)) +(mes-use-module (language c lexer)) +(mes-use-module (language c parser)) + (define mescc (let ((errorp (lambda args diff --git a/module/language/c/lexer.mes b/module/language/c/lexer.mes index 6218e5d5..191013a9 100644 --- a/module/language/c/lexer.mes +++ b/module/language/c/lexer.mes @@ -1,3 +1,5 @@ +;;; -*-scheme-*- + ;;; Mes --- Maxwell Equations of Software ;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. ;;; Copyright © 2016 Jan Nieuwenhuizen @@ -63,10 +65,7 @@ ) (mes - - - ) - ) + (mes-use-module (mes lalr)))) (define (read-delimited delims port handle-delim) (let ((stop (string->list delims))) diff --git a/module/language/c/parser.mes b/module/language/c/parser.mes index 9fe8fcd0..3b9225b5 100644 --- a/module/language/c/parser.mes +++ b/module/language/c/parser.mes @@ -27,31 +27,12 @@ (cond-expand (guile - (use-modules (srfi srfi-1)) - ;;(use-modules (system base lalr)) - (use-modules (ice-9 match))) + ;;(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 (srfi srfi-0)) - - (mes-use-module (mes syntax)) - - (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 (srfi srfi-1)) - (mes-use-module (mes match)) - - (mes-use-module (rnrs bytevectors)) - (mes-use-module (mes elf)) - (mes-use-module (mes libc-i386)))) + (mes-use-module (mes lalr)))) (gc) (define c-parser diff --git a/module/language/paren.mes b/module/language/paren.mes index 1c0909dc..7614c504 100644 --- a/module/language/paren.mes +++ b/module/language/paren.mes @@ -4,7 +4,7 @@ ;;; Copyright © 2008 Derek Peschel ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; paren.mes: This file is part of 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 @@ -31,22 +31,10 @@ (cond-expand (guile - (use-modules (system base lalr)) - ) + (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)) - )) + (mes-use-module (mes lalr)))) ;;; Taken from http://gambitscheme.org/wiki/index.php/Lalr_example ;;; LGPL 2.1 / Apache 2.0 diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes index 8bba7ff9..9128020d 100644 --- a/module/mes/base-0.mes +++ b/module/mes/base-0.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; base-0.mes: This file is part of 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 @@ -27,6 +27,7 @@ ;;; Code: #f ;; FIXME -- needed for --dump, then --load + (define (primitive-eval e) (eval-env e (current-module))) (define eval eval-env) (define (expand-macro e) (expand-macro-env e (current-module))) @@ -97,9 +98,47 @@ (set! ,stack (cdr ,stack)) o)) (define-macro (load file) - `(primitive-eval - (begin - (push! *input-ports* (current-input-port)) - (set-current-input-port (open-input-file ,file)) - (primitive-load) - (set-current-input-port (pop! *input-ports*))))) + `(begin + (push! *input-ports* (current-input-port)) + (set-current-input-port (open-input-file ,file)) + (primitive-load) + (set-current-input-port (pop! *input-ports*)))) + +(define (memq x lst) + (if (null? lst) #f + (if (eq? x (car lst)) lst + (memq x (cdr lst))))) + +(define (string-join lst infix) + (if (null? (cdr lst)) (car lst) + (string-append (car lst) infix (string-join (cdr lst) infix)))) + +(define *mes-prefix* "module/") +(define (module->file o) + (string-append (string-join (map symbol->string o) "/") ".mes")) + +(define *modules* '(mes/base-0.mes)) +(define (mes-load-module-env module a) + (push! *input-ports* (current-input-port)) + (set-current-input-port (open-input-file (string-append *mes-prefix* (module->file module)))) + (let ((x (eval-env (append (cons 'begin (read-input-file-env #f a)) + '((current-module))) + a))) + (set-current-input-port (pop! *input-ports*)) + x)) +(define-macro (mes-use-module module) + `(begin + (if (not (memq (string->symbol ,(module->file module)) *modules*)) + (begin + (set! *modules* (cons (string->symbol ,(module->file module)) *modules*)) + ;; (display "loading file=" (current-error-port)) + ;; (display ,(module->file module) (current-error-port)) + ;; (newline (current-error-port)) + (load ,(string-append *mes-prefix* (module->file module))))))) + +(define (not x) + (if x #f #t)) + +(mes-use-module (srfi srfi-0)) +(mes-use-module (mes base)) +(mes-use-module (mes scm)) diff --git a/module/mes/base.mes b/module/mes/base.mes index 938cdb88..e6b70dd6 100644 --- a/module/mes/base.mes +++ b/module/mes/base.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; base.mes: This file is part of 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 @@ -21,14 +21,12 @@ ;;; Commentary: -;;; base.mes is being loaded after base0.mes. It provides the minimal +;;; base.mes is being loaded after base-0.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) @@ -43,9 +41,6 @@ (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)) @@ -57,19 +52,8 @@ (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))))) diff --git a/module/mes/elf.mes b/module/mes/elf.mes index ba0dd5f6..c79a9a4b 100644 --- a/module/mes/elf.mes +++ b/module/mes/elf.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; elf.mes: This file is part of 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 @@ -24,6 +24,8 @@ ;;; Code: +(mes-use-module (rnrs bytevectors)) + (define (int->bv32 value) (let ((bv (make-bytevector 4))) (bytevector-u32-native-set! bv 0 value) diff --git a/module/mes/lalr.mes b/module/mes/lalr.mes index a73501a8..3eaffd11 100644 --- a/module/mes/lalr.mes +++ b/module/mes/lalr.mes @@ -1,2120 +1,28 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme +;;; This file is part of Mes. ;;; -;; Copyright 2014 Jan Nieuwenhuizen -;; 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 . - - -(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)) - - - +;;; 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. ;;; -;;;; -- -;;;; Implementation of the lr-driver +;;; 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 . +;;; Commentary: -(cond-expand - (gambit - (declare - (standard-bindings) - (fixnum) - (block) - (not safe))) - (chicken - (declare - (uses extras) - (usual-integrations) - (fixnum) - (not safe))) - (guile) - (else)) +;;; lalr - -;;; -;;;; 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))) +(mes-use-module (mes scm)) +(mes-use-module (mes syntax)) +(mes-use-module (srfi srfi-9)) +(mes-use-module (mes lalr.upstream)) diff --git a/module/mes/lalr.upstream.mes b/module/mes/lalr.upstream.mes new file mode 100644 index 00000000..4f50d27e --- /dev/null +++ b/module/mes/lalr.upstream.mes @@ -0,0 +1,2120 @@ +;;; +;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme +;;; +;; Copyright 2014 Jan Nieuwenhuizen +;; 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 . + + +(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) + (define *eoi* -1)) + + ;; -- 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))) + (guile) + (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/module/mes/let.mes b/module/mes/let.mes index cbd7a01a..3f89ed53 100644 --- a/module/mes/let.mes +++ b/module/mes/let.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; let.mes: This file is part of 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 @@ -18,6 +18,16 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . +;;; Commentary: + +;;; let.mes is loaded after base and quasiquote. It provides +;;; let, let* and named let. + +;;; Code: + +(mes-use-module (mes base)) +(mes-use-module (mes quasiquote)) + (define-macro (xsimple-let bindings rest) `(,`(lambda ,(map car bindings) ,@rest) ,@(map cadr bindings))) diff --git a/module/mes/libc-i386.mes b/module/mes/libc-i386.mes index 06e691ed..46b64a82 100644 --- a/module/mes/libc-i386.mes +++ b/module/mes/libc-i386.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; libc-i386.mes: This file is part of 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 diff --git a/module/mes/loop-0.mes b/module/mes/loop-0.mes index 2646d6ee..25912954 100644 --- a/module/mes/loop-0.mes +++ b/module/mes/loop-0.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; loop-0.mes: This file is part of 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 diff --git a/module/mes/match.mes b/module/mes/match.mes index 1cdc3ebc..95b51dbe 100644 --- a/module/mes/match.mes +++ b/module/mes/match.mes @@ -1,934 +1,26 @@ -;;; match.scm -- portable hygienic pattern matcher -*- coding: utf-8; mode: scheme -*- -;; -;; 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))))) +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; Commentary: + +;;; portable matcher + +(mes-use-module (mes syntax)) +(mes-use-module (mes match.upstream)) diff --git a/module/mes/match.upstream.mes b/module/mes/match.upstream.mes new file mode 100644 index 00000000..1cdc3ebc --- /dev/null +++ b/module/mes/match.upstream.mes @@ -0,0 +1,934 @@ +;;; match.scm -- portable hygienic pattern matcher -*- coding: utf-8; mode: scheme -*- +;; +;; 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/module/mes/mes-0.mes b/module/mes/mes-0.mes index 0854a1de..a3c5e6a8 100644 --- a/module/mes/mes-0.mes +++ b/module/mes/mes-0.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; mes-0.mes: This file is part of 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 diff --git a/module/mes/psyntax.mes b/module/mes/psyntax.mes new file mode 100644 index 00000000..15e427aa --- /dev/null +++ b/module/mes/psyntax.mes @@ -0,0 +1,23 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +(mes-use-module (mes psyntax-0)) +(mes-use-module (mes psyntax-pp)) +(mes-use-module (mes psyntax-1)) diff --git a/module/mes/quasiquote.mes b/module/mes/quasiquote.mes index 5551de3a..8712370a 100644 --- a/module/mes/quasiquote.mes +++ b/module/mes/quasiquote.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; quasiquote.mes: This file is part of 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 @@ -18,7 +18,16 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(define-macro (slow...quasiquote x) +;;; Commentary: + +;;; quasiquote.mes is loaded after base. It provides quasiquote +;;; written in Scheme. + +;;; Code: + +(mes-use-module (mes base)) + +(define-macro (quasiquote x) (define (check x) (cond ((pair? (cdr x)) (cond ((null? (cddr x))) (#t (error (car x) "invalid form ~s" x)))))) diff --git a/module/mes/record-0.mes b/module/mes/record-0.mes index ff6ce99c..23a9d770 100644 --- a/module/mes/record-0.mes +++ b/module/mes/record-0.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; record-0.mes: This file is part of 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 diff --git a/module/mes/record.mes b/module/mes/record.mes index 9a2fdfe8..ddc0249c 100644 --- a/module/mes/record.mes +++ b/module/mes/record.mes @@ -4,7 +4,7 @@ ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; syntax.mes: This file is part of 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 diff --git a/module/mes/repl.mes b/module/mes/repl.mes index a13a8b40..81187a59 100644 --- a/module/mes/repl.mes +++ b/module/mes/repl.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; repl.mes: This file is part of 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 @@ -24,6 +24,8 @@ ;;; Code: +(mes-use-module (mes scm)) + (define welcome "Mes 0.2 Copyright (C) 2016 Jan Nieuwenhuizen @@ -97,6 +99,7 @@ along with Mes. If not, see . ,sc-expand SEXP - SC-expand SEXP ,help - Show this help ,show TOPIC - Show info on TOPIC [c, w] + ,use MODULE - load MODULE ") (define show-commands @@ -130,18 +133,23 @@ along with Mes. If not, see . (display (sc-expand sexp)) (newline))) - (define (help) (display help-commands)) - (define (show) + (define (help . x) (display help-commands)) + (define (show . x) (define topic-alist `((#\newline . ,show-commands) (#\c . ,copying) (#\w . ,warranty))) (let ((topic (read-char))) (display (assoc-ref topic-alist topic)))) - (define (meta command) + (define (use a) + (lambda () + (let ((module (read-env (current-module)))) + (mes-load-module-env module a)))) + (define (meta command a) (let ((command-alist `((expand . ,expand) (sc-expand . ,scexpand) (help . ,help) - (show . ,show)))) + (show . ,show) + (use . ,(use a))))) ((or (assoc-ref command-alist command) (lambda () #f))))) @@ -156,16 +164,18 @@ along with Mes. If not, see . (display sexp) (display "]") (newline)) - (if (and (pair? sexp) (eq? (car sexp) (string->symbol "unquote"))) - (begin - (meta (cadr sexp)) - (loop a)) - (let ((e (eval-env sexp a))) - (if (eq? e *unspecified*) (loop a) - (let ((id (string->symbol (string-append "$" (number->string count))))) - (set! count (+ count 1)) - (display id) - (display " = ") - (display e) - (newline) - (loop (acons id e a))))))))))) + (cond ((and (pair? sexp) (eq? (car sexp) (string->symbol "unquote"))) + (let ((r (meta (cadr sexp) a))) + (if (pair? r) (loop (append r a)) + (loop a)))) + ((and (pair? sexp) (eq? (car sexp) 'mes-use-module)) + (loop (mes-load-module-env (cadr sexp) a))) + (else (let ((e (eval-env sexp a))) + (if (eq? e *unspecified*) (loop a) + (let ((id (string->symbol (string-append "$" (number->string count))))) + (set! count (+ count 1)) + (display id) + (display " = ") + (display e) + (newline) + (loop (acons id e a)))))))))))) diff --git a/module/mes/scm.mes b/module/mes/scm.mes index 2e488be6..2ac9180e 100644 --- a/module/mes/scm.mes +++ b/module/mes/scm.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; scm.mes: This file is part of 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 @@ -26,6 +26,8 @@ ;;; Code: +(mes-use-module (mes let)) + (define (cadddr x) (car (cdddr x))) (define (list . rest) rest) diff --git a/module/mes/syntax.mes b/module/mes/syntax.mes index 39820fca..48725660 100644 --- a/module/mes/syntax.mes +++ b/module/mes/syntax.mes @@ -1,10 +1,9 @@ ;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; syntax.mes: This file is part of 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 @@ -26,6 +25,8 @@ ;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm ;;; Code: +(mes-use-module (mes scm)) +(mes-use-module (mes syntax.upstream)) (define (syntax-error message thing) (display "syntax-error:" (current-error-port)) @@ -37,229 +38,6 @@ (define (silent-syntax-error message thing) *unspecified*) -;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. - -;;; scheme48-1.1/COPYING - -;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees -;; All rights reserved. - -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions -;; are met: -;; 1. Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; 2. Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in the -;; documentation and/or other materials provided with the distribution. -;; 3. The name of the authors may not be used to endorse or promote products -;; derived from this software without specific prior written permission. - -;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, -;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF -;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -(define-macro (define-syntax macro-name transformer . stuff) - `(define-macro (,macro-name . args) - (,transformer (cons ',macro-name args) - (lambda (x0) x0) - eq?))) - -;; Rewrite-rule compiler (a.k.a. "extend-syntax") - -;; Example: -;; -;; (define-syntax or -;; (syntax-rules () -;; ((or) #f) -;; ((or e) e) -;; ((or e1 e ...) (let ((temp e1)) -;; (if temp temp (or e ...)))))) - -(define-syntax syntax-rules - (let () - (define name? symbol?) - - (define (segment-pattern? pattern) - (and (segment-template? pattern) - (or (null? (cddr pattern)) - (syntax-error "segment matching not implemented" pattern)))) - - (define (segment-template? pattern) - (and (pair? pattern) - (pair? (cdr pattern)) - (memq (cadr pattern) indicators-for-zero-or-more))) - - (define indicators-for-zero-or-more (list (string->symbol "...") '---)) - - (lambda (exp r c) - - (define %input (r '%input)) ;Gensym these, if you like. - (define %compare (r '%compare)) - (define %rename (r '%rename)) - (define %tail (r '%tail)) - (define %temp (r '%temp)) - - (define rules (cddr exp)) - (define subkeywords (cadr exp)) - - (define (make-transformer rules) - `(lambda (,%input ,%rename ,%compare) - (let ((,%tail (cdr ,%input))) - (cond ,@(map process-rule rules) - (else - (syntax-error - "use of macro doesn't match definition" - ,%input)))))) - - (define (process-rule rule) - (if (and (pair? rule) - (pair? (cdr rule)) - (null? (cddr rule))) - (let ((pattern (cdar rule)) - (template (cadr rule))) - `((and ,@(process-match %tail pattern)) - (let* ,(process-pattern pattern - %tail - (lambda (x) x)) - ,(process-template template - 0 - (meta-variables pattern 0 '()))))) - (syntax-error "ill-formed syntax rule" rule))) - - ;; Generate code to test whether input expression matches pattern - - (define (process-match input pattern) - (cond ((name? pattern) - (if (member pattern subkeywords) - `((,%compare ,input (,%rename ',pattern))) - `())) - ((segment-pattern? pattern) - (process-segment-match input (car pattern))) - ((pair? pattern) - `((let ((,%temp ,input)) - (and (pair? ,%temp) - ,@(process-match `(car ,%temp) (car pattern)) - ,@(process-match `(cdr ,%temp) (cdr pattern)))))) - ((or (null? pattern) (boolean? pattern) (char? pattern)) - `((eq? ,input ',pattern))) - (else - `((equal? ,input ',pattern))))) - - (define (process-segment-match input pattern) - (let ((conjuncts (process-match '(car l) pattern))) - (if (null? conjuncts) - `((list? ,input)) ;+++ - `((let loop ((l ,input)) - (or (null? l) - (and (pair? l) - ,@conjuncts - (loop (cdr l))))))))) - - ;; Generate code to take apart the input expression - ;; This is pretty bad, but it seems to work (can't say why). - - (define (process-pattern pattern path mapit) - (cond ((name? pattern) - (if (memq pattern subkeywords) - '() - (list (list pattern (mapit path))))) - ((segment-pattern? pattern) - (process-pattern (car pattern) - %temp - (lambda (x) ;temp is free in x - (mapit (if (eq? %temp x) - path ;+++ - `(map (lambda (,%temp) ,x) - ,path)))))) - ((pair? pattern) - (append (process-pattern (car pattern) `(car ,path) mapit) - (process-pattern (cdr pattern) `(cdr ,path) mapit))) - (else '()))) - - ;; Generate code to compose the output expression according to template - - (define (process-template template rank env) - (cond ((name? template) - (let ((probe (assq template env))) - (if probe - (if (<= (cdr probe) rank) - template - (syntax-error "template rank error (too few ...'s?)" - template)) - `(,%rename ',template)))) - ((segment-template? template) - (let ((vars - (free-meta-variables (car template) (+ rank 1) env '()))) - (if (null? vars) - (silent-syntax-error "too many ...'s" template) - (let* ((x (process-template (car template) - (+ rank 1) - env)) - (gen (if (equal? (list x) vars) - x ;+++ - `(map (lambda ,vars ,x) - ,@vars)))) - (if (null? (cddr template)) - gen ;+++ - `(append ,gen ,(process-template (cddr template) - rank env))))))) - ((pair? template) - `(cons ,(process-template (car template) rank env) - ,(process-template (cdr template) rank env))) - (else `(quote ,template)))) - - ;; Return an association list of (var . rank) - - (define (meta-variables pattern rank vars) - (cond ((name? pattern) - (if (memq pattern subkeywords) - vars - (cons (cons pattern rank) vars))) - ((segment-pattern? pattern) - (meta-variables (car pattern) (+ rank 1) vars)) - ((pair? pattern) - (meta-variables (car pattern) rank - (meta-variables (cdr pattern) rank vars))) - (else vars))) - - ;; Return a list of meta-variables of given higher rank - - (define (free-meta-variables template rank env free) - (cond ((name? template) - (if (and (not (memq template free)) - (let ((probe (assq template env))) - (and probe (>= (cdr probe) rank)))) - (cons template free) - free)) - ((segment-template? template) - (free-meta-variables (car template) - rank env - (free-meta-variables (cddr template) - rank env free))) - ((pair? template) - (free-meta-variables (car template) - rank env - (free-meta-variables (cdr template) - rank env free))) - (else free))) - - c ;ignored - - ;; Kludge for Scheme48 linker. - ;; `(cons ,(make-transformer rules) - ;; ',(find-free-names-in-syntax-rules subkeywords rules)) - - (make-transformer rules)))) - (define-macro (define-syntax-rule id-pattern . template) `(define-syntax ,(car id-pattern) (syntax-rules () diff --git a/module/mes/syntax.upstream.mes b/module/mes/syntax.upstream.mes new file mode 100644 index 00000000..16293276 --- /dev/null +++ b/module/mes/syntax.upstream.mes @@ -0,0 +1,251 @@ +;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; Commentary: + +;;; syntax.mes is loaded after scm.mes. It provides the R5RS hygienic +;;; macros define-syntax, syntax-rules and define-syntax-rule. +;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm + +;;; Code: + +;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. + +;;; scheme48-1.1/COPYING + +;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. The name of the authors may not be used to endorse or promote products +;; derived from this software without specific prior written permission. + +;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +(define-macro (define-syntax macro-name transformer . stuff) + `(define-macro (,macro-name . args) + (,transformer (cons ',macro-name args) + (lambda (x0) x0) + eq?))) + +;; Rewrite-rule compiler (a.k.a. "extend-syntax") + +;; Example: +;; +;; (define-syntax or +;; (syntax-rules () +;; ((or) #f) +;; ((or e) e) +;; ((or e1 e ...) (let ((temp e1)) +;; (if temp temp (or e ...)))))) + +(define-syntax syntax-rules + (let () + (define name? symbol?) + + (define (segment-pattern? pattern) + (and (segment-template? pattern) + (or (null? (cddr pattern)) + (syntax-error "segment matching not implemented" pattern)))) + + (define (segment-template? pattern) + (and (pair? pattern) + (pair? (cdr pattern)) + (memq (cadr pattern) indicators-for-zero-or-more))) + + (define indicators-for-zero-or-more (list (string->symbol "...") '---)) + + (lambda (exp r c) + + (define %input (r '%input)) ;Gensym these, if you like. + (define %compare (r '%compare)) + (define %rename (r '%rename)) + (define %tail (r '%tail)) + (define %temp (r '%temp)) + + (define rules (cddr exp)) + (define subkeywords (cadr exp)) + + (define (make-transformer rules) + `(lambda (,%input ,%rename ,%compare) + (let ((,%tail (cdr ,%input))) + (cond ,@(map process-rule rules) + (else + (syntax-error + "use of macro doesn't match definition" + ,%input)))))) + + (define (process-rule rule) + (if (and (pair? rule) + (pair? (cdr rule)) + (null? (cddr rule))) + (let ((pattern (cdar rule)) + (template (cadr rule))) + `((and ,@(process-match %tail pattern)) + (let* ,(process-pattern pattern + %tail + (lambda (x) x)) + ,(process-template template + 0 + (meta-variables pattern 0 '()))))) + (syntax-error "ill-formed syntax rule" rule))) + + ;; Generate code to test whether input expression matches pattern + + (define (process-match input pattern) + (cond ((name? pattern) + (if (member pattern subkeywords) + `((,%compare ,input (,%rename ',pattern))) + `())) + ((segment-pattern? pattern) + (process-segment-match input (car pattern))) + ((pair? pattern) + `((let ((,%temp ,input)) + (and (pair? ,%temp) + ,@(process-match `(car ,%temp) (car pattern)) + ,@(process-match `(cdr ,%temp) (cdr pattern)))))) + ((or (null? pattern) (boolean? pattern) (char? pattern)) + `((eq? ,input ',pattern))) + (else + `((equal? ,input ',pattern))))) + + (define (process-segment-match input pattern) + (let ((conjuncts (process-match '(car l) pattern))) + (if (null? conjuncts) + `((list? ,input)) ;+++ + `((let loop ((l ,input)) + (or (null? l) + (and (pair? l) + ,@conjuncts + (loop (cdr l))))))))) + + ;; Generate code to take apart the input expression + ;; This is pretty bad, but it seems to work (can't say why). + + (define (process-pattern pattern path mapit) + (cond ((name? pattern) + (if (memq pattern subkeywords) + '() + (list (list pattern (mapit path))))) + ((segment-pattern? pattern) + (process-pattern (car pattern) + %temp + (lambda (x) ;temp is free in x + (mapit (if (eq? %temp x) + path ;+++ + `(map (lambda (,%temp) ,x) + ,path)))))) + ((pair? pattern) + (append (process-pattern (car pattern) `(car ,path) mapit) + (process-pattern (cdr pattern) `(cdr ,path) mapit))) + (else '()))) + + ;; Generate code to compose the output expression according to template + + (define (process-template template rank env) + (cond ((name? template) + (let ((probe (assq template env))) + (if probe + (if (<= (cdr probe) rank) + template + (syntax-error "template rank error (too few ...'s?)" + template)) + `(,%rename ',template)))) + ((segment-template? template) + (let ((vars + (free-meta-variables (car template) (+ rank 1) env '()))) + (if (null? vars) + (silent-syntax-error "too many ...'s" template) + (let* ((x (process-template (car template) + (+ rank 1) + env)) + (gen (if (equal? (list x) vars) + x ;+++ + `(map (lambda ,vars ,x) + ,@vars)))) + (if (null? (cddr template)) + gen ;+++ + `(append ,gen ,(process-template (cddr template) + rank env))))))) + ((pair? template) + `(cons ,(process-template (car template) rank env) + ,(process-template (cdr template) rank env))) + (else `(quote ,template)))) + + ;; Return an association list of (var . rank) + + (define (meta-variables pattern rank vars) + (cond ((name? pattern) + (if (memq pattern subkeywords) + vars + (cons (cons pattern rank) vars))) + ((segment-pattern? pattern) + (meta-variables (car pattern) (+ rank 1) vars)) + ((pair? pattern) + (meta-variables (car pattern) rank + (meta-variables (cdr pattern) rank vars))) + (else vars))) + + ;; Return a list of meta-variables of given higher rank + + (define (free-meta-variables template rank env free) + (cond ((name? template) + (if (and (not (memq template free)) + (let ((probe (assq template env))) + (and probe (>= (cdr probe) rank)))) + (cons template free) + free)) + ((segment-template? template) + (free-meta-variables (car template) + rank env + (free-meta-variables (cddr template) + rank env free))) + ((pair? template) + (free-meta-variables (car template) + rank env + (free-meta-variables (cdr template) + rank env free))) + (else free))) + + c ;ignored + + ;; Kludge for Scheme48 linker. + ;; `(cons ,(make-transformer rules) + ;; ',(find-free-names-in-syntax-rules subkeywords rules)) + + (make-transformer rules)))) diff --git a/module/mes/test.mes b/module/mes/test.mes index 3895606a..f6437e82 100644 --- a/module/mes/test.mes +++ b/module/mes/test.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; test.mes: This file is part of 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 @@ -25,6 +25,7 @@ ;;; Code: +(mes-use-module (mes base)) (define guile? (not (pair? (current-module)))) (define result diff --git a/module/mes/type-0.mes b/module/mes/type-0.mes index bd28e669..53b0a2d3 100644 --- a/module/mes/type-0.mes +++ b/module/mes/type-0.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; type-0.mes: This file is part of 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 diff --git a/module/rnrs/bytevectors.mes b/module/rnrs/bytevectors.mes index a9358399..15fc1883 100644 --- a/module/rnrs/bytevectors.mes +++ b/module/rnrs/bytevectors.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; bytevectors.mes: This file is part of 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 diff --git a/module/srfi/srfi-0.mes b/module/srfi/srfi-0.mes index 17a897a5..e5ff2e5b 100644 --- a/module/srfi/srfi-0.mes +++ b/module/srfi/srfi-0.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; srfi-0.mes: This file is part of 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 @@ -27,10 +27,9 @@ (define mes '(0 1)) (define (cond-expand-expander clauses) - (let loop ((clauses clauses)) - (if (defined? (caar clauses)) - (eval (cons 'begin (cdar clauses)) (current-module)) - (loop (cdr clauses))))) + (if (defined? (caar clauses)) + (cdar clauses) + (cond-expand-expander (cdr clauses)))) (define-macro (cond-expand . clauses) - `(cond-expand-expander (quote ,clauses))) + `(begin ,@(cond-expand-expander clauses))) diff --git a/module/srfi/srfi-9.mes b/module/srfi/srfi-9.mes index d0a8345c..05714a93 100644 --- a/module/srfi/srfi-9.mes +++ b/module/srfi/srfi-9.mes @@ -1,10 +1,9 @@ ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software -;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; base-0.mes: This file is part of 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 @@ -21,80 +20,10 @@ ;;; Commentary: -;;; srfi-9.mes - records. Assumes record-0.mes and record.mes are -;;; available. Modified from -;;; scheme48-1.1/scheme/alt/jar-defrecord.scm to implement SRFI-9. +;;; srfi-9.mes - records. -;;; Code: - -;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. - -;;; scheme48-1.1/COPYING - -;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees -;; All rights reserved. - -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions -;; are met: -;; 1. Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; 2. Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in the -;; documentation and/or other materials provided with the distribution. -;; 3. The name of the authors may not be used to endorse or promote products -;; derived from this software without specific prior written permission. - -;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR -;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES -;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. -;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, -;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF -;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -; This is JAR's define-record-type, which doesn't resemble Richard's. - -; There's no implicit name concatenation, so it can be defined -; entirely using syntax-rules. Example: -; (define-record-type foo :foo -; (make-foo x y) -; foo? - predicate name is optional -; (x foo-x) -; (y foo-y) -; (z foo-z set-foo-z!)) - -(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)))))) +(mes-use-module (mes scm)) +(mes-use-module (mes syntax)) +(mes-use-module (mes record-0)) +(mes-use-module (mes record)) +(mes-use-module (srfi srfi-9.upstream)) diff --git a/module/srfi/srfi-9.upstream.mes b/module/srfi/srfi-9.upstream.mes new file mode 100644 index 00000000..47b51617 --- /dev/null +++ b/module/srfi/srfi-9.upstream.mes @@ -0,0 +1,100 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +;;; Commentary: + +;;; srfi-9.mes - records. Assumes record-0.mes and record.mes are +;;; available. Modified from +;;; scheme48-1.1/scheme/alt/jar-defrecord.scm to implement SRFI-9. + +;;; Code: + +;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING. + +;;; scheme48-1.1/COPYING + +;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees +;; All rights reserved. + +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; 1. Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; 2. Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; 3. The name of the authors may not be used to endorse or promote products +;; derived from this software without specific prior written permission. + +;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +; This is JAR's define-record-type, which doesn't resemble Richard's. + +; There's no implicit name concatenation, so it can be defined +; entirely using syntax-rules. Example: +; (define-record-type foo :foo +; (make-foo x y) +; foo? - predicate name is optional +; (x foo-x) +; (y foo-y) +; (z foo-z set-foo-z!)) + +(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/posix.c b/posix.c index 5b98cd5e..092400cd 100644 --- a/posix.c +++ b/posix.c @@ -59,5 +59,5 @@ current_input_port () SCM set_current_input_port (SCM port) { - g_stdin = fdopen (VALUE (port), "r"); + g_stdin = VALUE (port) ? fdopen (VALUE (port), "r") : stdin; } diff --git a/scripts/elf.mes b/scripts/elf.mes index f021a8e4..8c0d7455 100755 --- a/scripts/elf.mes +++ b/scripts/elf.mes @@ -1,6 +1,7 @@ #! /bin/sh # -*-scheme-*- -cat $($(dirname $0)/include.mes $0) $0 /dev/stdin | $(dirname $0)/mes $MES_FLAGS "$@" > a.out +prefix=module/ +cat $prefix/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/mes $MES_FLAGS "$@" > a.out #paredit:| chmod +x a.out exit $? @@ -24,7 +25,6 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) (mes-use-module (mes base)) (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) diff --git a/scripts/mescc.mes b/scripts/mescc.mes index 54a4dd08..08e86f09 100755 --- a/scripts/mescc.mes +++ b/scripts/mescc.mes @@ -1,6 +1,7 @@ #! /bin/sh # -*-scheme-*- -cat ${1-$(dirname $(dirname $0))/share/doc/mes/examples/main.c} | cat $($(dirname $0)/include.mes $0) $0 /dev/stdin | $(dirname $0)/mes $MES_FLAGS "$@" > a.out +prefix=module/ +cat ${1-$(dirname $(dirname $0))/share/doc/mes/examples/main.c} | cat $prefix/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/mes $MES_FLAGS "$@" > a.out chmod +x a.out exit $? !# @@ -33,25 +34,6 @@ exit $? ;;; Code: -(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 (srfi srfi-1)) -(mes-use-module (mes match)) -(mes-use-module (rnrs bytevectors)) -(mes-use-module (mes elf)) -(mes-use-module (mes libc-i386)) -(mes-use-module (language c lexer)) -(mes-use-module (language c parser)) (mes-use-module (language c compiler)) (compile) diff --git a/scripts/paren.mes b/scripts/paren.mes index 3f4e453c..0af036e4 100755 --- a/scripts/paren.mes +++ b/scripts/paren.mes @@ -1,6 +1,7 @@ #! /bin/sh # -*-scheme-*- -echo -e 'EOF\n___P((()))' | cat $($(dirname $0)/include.mes $0) $0 /dev/stdin | $(dirname $0)/mes $MES_FLAGS "$@" +prefix=module/ +echo -e 'EOF\n___P((()))' | cat $prefix/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/mes $MES_FLAGS "$@" chmod +x a.out exit $? !# @@ -34,18 +35,6 @@ exit $? ;;; Code: -(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 (language paren)) (paren-depth) diff --git a/scripts/repl.mes b/scripts/repl.mes index d8833117..3292bf54 100755 --- a/scripts/repl.mes +++ b/scripts/repl.mes @@ -2,7 +2,8 @@ # -*-scheme-*- MES_ARENA=${MES_ARENA-5000000} export MES_ARENA -cat $($(dirname $0)/include.mes $0) $0 /dev/stdin | $(dirname $0)/mes $MES_FLAGS "$@" +prefix=module/ +cat $prefix/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/mes $MES_FLAGS "$@" #paredit:| exit $? !# @@ -25,14 +26,8 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(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 (srfi srfi-0)) (mes-use-module (mes syntax)) -(mes-use-module (mes match)) (mes-use-module (mes repl)) (repl) diff --git a/tests/base.test b/tests/base.test index 15ae2d0c..8670c370 100755 --- a/tests/base.test +++ b/tests/base.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; base.test: This file is part of 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 @@ -25,8 +25,6 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) -(mes-use-module (mes base)) (mes-use-module (mes test)) (pass-if "first dummy" #t) diff --git a/tests/closure.test b/tests/closure.test index f2dcadb3..494daca8 100755 --- a/tests/closure.test +++ b/tests/closure.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; closure.test: This file is part of 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 @@ -25,8 +25,6 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) -(mes-use-module (mes base)) (mes-use-module (mes test)) (pass-if "first dummy" #t) diff --git a/tests/cwv.test b/tests/cwv.test index 0fc38025..bdd450ad 100755 --- a/tests/cwv.test +++ b/tests/cwv.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; scm.test: This file is part of 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 @@ -25,17 +25,9 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) -(mes-use-module (mes base)) -(mes-use-module (mes quasiquote)) -(mes-use-module (mes let)) -(mes-use-module (srfi srfi-0)) (mes-use-module (mes scm)) (mes-use-module (mes test)) -(if guile? - (use-modules (srfi srfi-1))) - (pass-if "values" (seq? (values 0 1) 0)) (pass-if "values 2" (seq? ((lambda (x) x) (values 1 2 3)) 1)) (pass-if "values 3" (seq? 1 ((lambda (x) x) (values 1 2 3)))) diff --git a/tests/gc-0.test b/tests/gc-0.test index aa00fec8..8381e871 100755 --- a/tests/gc-0.test +++ b/tests/gc-0.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/..//mes "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/..//mes "$@" #paredit:|| exit $? !# diff --git a/tests/gc-1.test b/tests/gc-1.test index 35d35430..ee3b3878 100755 --- a/tests/gc-1.test +++ b/tests/gc-1.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# diff --git a/tests/gc-2.test b/tests/gc-2.test index 32eb5468..0cafbfbd 100755 --- a/tests/gc-2.test +++ b/tests/gc-2.test @@ -1,7 +1,7 @@ #! /bin/sh # -*-scheme-*- set -x -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# diff --git a/tests/gc-2a.test b/tests/gc-2a.test index d2d77e96..e9c6c797 100755 --- a/tests/gc-2a.test +++ b/tests/gc-2a.test @@ -1,7 +1,7 @@ #! /bin/sh # -*-scheme-*- set -x -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# diff --git a/tests/gc-3.test b/tests/gc-3.test index 56444fda..688f44fe 100755 --- a/tests/gc-3.test +++ b/tests/gc-3.test @@ -1,7 +1,7 @@ #! /bin/sh # -*-scheme-*- set -x -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# diff --git a/tests/gc-4.test b/tests/gc-4.test index db176aeb..ca9cc13d 100755 --- a/tests/gc-4.test +++ b/tests/gc-4.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/..//mes "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/..//mes "$@" #paredit:|| exit $? !# diff --git a/tests/gc-5.test b/tests/gc-5.test index 701dda9c..c5fd31ec 100755 --- a/tests/gc-5.test +++ b/tests/gc-5.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/..//mes "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/..//mes "$@" #paredit:|| exit $? !# diff --git a/tests/gc-6.test b/tests/gc-6.test index dd73008d..95fe2453 100755 --- a/tests/gc-6.test +++ b/tests/gc-6.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/..//mes "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/..//mes "$@" #paredit:|| exit $? !# diff --git a/tests/gc.test b/tests/gc.test index 64369a74..8ca5bf02 100755 --- a/tests/gc.test +++ b/tests/gc.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -25,7 +25,6 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) (mes-use-module (mes base)) (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) @@ -33,9 +32,6 @@ exit $? (mes-use-module (mes scm)) (mes-use-module (mes test)) -(when guile? - (use-modules (srfi srfi-1))) - (pass-if "first dummy" #t) (pass-if-not "second dummy" #f) diff --git a/tests/let-syntax.test b/tests/let-syntax.test index 17420701..0bc7fa97 100755 --- a/tests/let-syntax.test +++ b/tests/let-syntax.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; let-syntax.test: This file is part of 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 @@ -25,11 +25,6 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(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 (mes test)) diff --git a/tests/let.test b/tests/let.test index 2e19696b..f2c1f333 100755 --- a/tests/let.test +++ b/tests/let.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; let.test: This file is part of 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 @@ -25,9 +25,6 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(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 test)) diff --git a/tests/match.test b/tests/match.test index 10a4fccb..52fbd982 100755 --- a/tests/match.test +++ b/tests/match.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; match.test: This file is part of 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 @@ -25,16 +25,6 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) -(mes-use-module (mes base)) -(mes-use-module (mes quasiquote)) -(mes-use-module (mes let)) -(mes-use-module (srfi srfi-0)) -(mes-use-module (mes scm)) -(mes-use-module (mes syntax)) -(mes-use-module (mes record-0)) -(mes-use-module (mes record)) -(mes-use-module (srfi srfi-9)) (mes-use-module (mes match)) (mes-use-module (mes test)) diff --git a/module/mes/lalr-0.mes b/tests/module.test old mode 100644 new mode 100755 similarity index 65% rename from module/mes/lalr-0.mes rename to tests/module.test index 400b0a89..ced75746 --- a/module/mes/lalr-0.mes +++ b/tests/module.test @@ -1,9 +1,19 @@ +#! /bin/sh +# -*-scheme-*- +set -x +#echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes "$@" +#paredit:|| +cat module/mes/base-0.mes $0 | $(dirname $0)/../scripts/mes "$@" +#paredit:| +exit $? +!# + ;;; -*-scheme-*- ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; lalr-0.mes: This file is part of 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 @@ -18,16 +28,9 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -;;; Commentary: +(mes-use-module (mes test)) -;;; lalr-0.mes has mes-specific definitions needed for lalr.mes +(pass-if "first dummy" #t) +(pass-if-not "second dummy" #f) -;;; 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) +(result 'report) diff --git a/tests/psyntax.test b/tests/psyntax.test index 4b8d21f6..82e00fec 100755 --- a/tests/psyntax.test +++ b/tests/psyntax.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -25,20 +25,6 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) -(mes-use-module (mes base)) -(mes-use-module (mes quasiquote)) -(mes-use-module (mes let)) -(mes-use-module (srfi srfi-0)) -(mes-use-module (mes scm)) -(mes-use-module (mes psyntax-0)) -(mes-use-module (mes psyntax-pp)) -(mes-use-module (mes psyntax-1)) -(mes-use-module (mes test)) - -(pass-if "first dummy" #t) -(pass-if-not "second dummy" #f) - (cond-expand (guile ;;(use-modules (ice-9 syncase)) @@ -46,7 +32,12 @@ exit $? (define syntax-object->datum syntax->datum) (define datum->syntax-object datum->syntax) ) - (mes)) + (mes + (mes-use-module (mes psyntax)) + (mes-use-module (mes test)))) + +(pass-if "first dummy" #t) +(pass-if-not "second dummy" #f) (when (not guile?) (pass-if "andmap" diff --git a/tests/quasiquote.test b/tests/quasiquote.test index bf65af7b..4d307f68 100755 --- a/tests/quasiquote.test +++ b/tests/quasiquote.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; quasiquote.test: This file is part of 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 @@ -25,7 +25,6 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) (mes-use-module (mes base)) (mes-use-module (mes quasiquote)) (mes-use-module (mes test)) diff --git a/tests/read.test b/tests/read.test index 6ae37184..7bcdbf3b 100755 --- a/tests/read.test +++ b/tests/read.test @@ -1,7 +1,7 @@ #! /bin/sh # -*-scheme-*- # ***REMOVE THIS BLOCK COMMENT INITIALLY*** -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# diff --git a/tests/record.test b/tests/record.test index 2c6930c9..7b1e3d7e 100755 --- a/tests/record.test +++ b/tests/record.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; record.test: This file is part of 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 @@ -25,17 +25,7 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) -(mes-use-module (mes base)) -(mes-use-module (mes quasiquote)) -(mes-use-module (mes let)) -(mes-use-module (srfi srfi-0)) -(mes-use-module (mes scm)) -(mes-use-module (mes syntax)) -(mes-use-module (mes record-0)) -(mes-use-module (mes record)) (mes-use-module (srfi srfi-9)) - (mes-use-module (mes test)) (when guile? diff --git a/tests/scm.test b/tests/scm.test index 0eb6f6e8..1f22d087 100755 --- a/tests/scm.test +++ b/tests/scm.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; scm.test: This file is part of 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 @@ -25,17 +25,10 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) -(mes-use-module (mes base)) -(mes-use-module (mes quasiquote)) -(mes-use-module (mes let)) -(mes-use-module (srfi srfi-0)) (mes-use-module (mes scm)) +(mes-use-module (srfi srfi-0)) (mes-use-module (mes test)) -(when guile? - (use-modules (srfi srfi-1))) - (pass-if "first dummy" #t) (pass-if-not "second dummy" #f) diff --git a/tests/vector.test b/tests/vector.test index e40ba2d2..13cc7441 100755 --- a/tests/vector.test +++ b/tests/vector.test @@ -1,6 +1,6 @@ #! /bin/sh # -*-scheme-*- -echo ' ()' | cat $($(dirname $0)/../scripts/include.mes $0) $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" +echo ' ()' | cat $(dirname $0)/../module/mes/base-0.mes $0 /dev/stdin | $(dirname $0)/../scripts/mes $MES_FLAGS "$@" #paredit:|| exit $? !# @@ -10,7 +10,7 @@ exit $? ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; vector.test: This file is part of 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 @@ -25,17 +25,9 @@ exit $? ;;; You should have received a copy of the GNU General Public License ;;; along with Mes. If not, see . -(mes-use-module (mes base-0)) -(mes-use-module (mes base)) -(mes-use-module (mes quasiquote)) -(mes-use-module (mes let)) -(mes-use-module (srfi srfi-0)) (mes-use-module (mes scm)) (mes-use-module (mes test)) -(when guile? - (use-modules (srfi srfi-1))) - (pass-if "first dummy" #t) (pass-if-not "second dummy" #f)