* 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.
/ChangeLog
/a.out
/mes
-/read-0.mo
+/module/mes/read-0.mo
/out
?
?.mes
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
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
#CFLAGS:=-pg -std=c99 -O0
#CFLAGS:=-std=c99 -O0 -g
+include .config.make
+include make/install.make
+
+CPPFLAGS+=-DPREFIX='"$(PREFIX)"'
+
export BOOT
ifneq ($(BOOT),)
-CFLAGS+=-DBOOT=1
+CPPFLAGS+=-DBOOT=1
endif
-include .config.make
-include .local.make
-include make/install.make
-
-all: mes
+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
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
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
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].
(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
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-
{
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);
}
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');
;;; 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
+;;; -*-scheme-*-
+
;;; Mes --- Maxwell Equations of Software
;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
)
(mes
-
-
- )
- )
+ (mes-use-module (mes lalr))))
(define (read-delimited delims port handle-delim)
(let ((stop (string->list delims)))
(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
;;; Copyright © 2008 Derek Peschel
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
(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
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; 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)))
(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))
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; 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)
(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))
(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)))))
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; Code:
+(mes-use-module (rnrs bytevectors))
+
(define (int->bv32 value)
(let ((bv (make-bytevector 4)))
(bytevector-u32-native-set! bv 0 value)
+++ /dev/null
-;;; -*-scheme-*-
-
-;;; Mes --- Maxwell Equations of Software
-;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
-;;;
-;;; lalr-0.mes: This file is part of Mes.
-;;;
-;;; Mes is free software; you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 3 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; Mes is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; lalr-0.mes has mes-specific definitions needed for lalr.mes
-
-;;; Code:
-
-(define pprint display)
-(define lalr-keyword? symbol?)
-(define-macro (BITS-PER-WORD) 30)
-(define-macro (logical-or x . y) `(logior ,x ,@y))
-(define-macro (lalr-error msg obj) `(error ,msg ,obj))
-(define (note-source-location lvalue tok) lvalue)
-(define *eoi* -1)
-;;;
-;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
-;;;
-;; Copyright 2014 Jan Nieuwenhuizen <janneke@gnu.org>
-;; Copyright 1993, 2010 Dominique Boucher
-;;
-;; This program is free software: you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public License
-;; as published by the Free Software Foundation, either version 3 of
-;; the License, or (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-
-(define *lalr-scm-version* "2.5.0")
-
-(cond-expand
-
- ;; -- Gambit-C
- (gambit
-
- (display "Gambit-C!")
- (newline)
-
- (define-macro (def-macro form . body)
- `(define-macro ,form (let () ,@body)))
-
- (def-macro (BITS-PER-WORD) 28)
- (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
- (def-macro (lalr-error msg obj) `(error ,msg ,obj))
-
- (define pprint pretty-print)
- (define lalr-keyword? keyword?)
- (define (note-source-location lvalue tok) lvalue))
-
- ;; --
- (bigloo
- (define-macro (def-macro form . body)
- `(define-macro ,form (let () ,@body)))
-
- (define pprint (lambda (obj) (write obj) (newline)))
- (define lalr-keyword? keyword?)
- (def-macro (BITS-PER-WORD) 29)
- (def-macro (logical-or x . y) `(bit-or ,x ,@y))
- (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
- (define (note-source-location lvalue tok) lvalue))
-
- ;; -- Chicken
- (chicken
-
- (define-macro (def-macro form . body)
- `(define-macro ,form (let () ,@body)))
-
- (define pprint pretty-print)
- (define lalr-keyword? symbol?)
- (def-macro (BITS-PER-WORD) 30)
- (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
- (def-macro (lalr-error msg obj) `(error ,msg ,obj))
- (define (note-source-location lvalue tok) lvalue))
-
- ;; -- STKlos
- (stklos
- (require "pp")
-
- (define (pprint form) (pp form :port (current-output-port)))
-
- (define lalr-keyword? keyword?)
- (define-macro (BITS-PER-WORD) 30)
- (define-macro (logical-or x . y) `(bit-or ,x ,@y))
- (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj))
- (define (note-source-location lvalue tok) lvalue))
-
- ;; -- Guile
- (guile
- (use-modules (ice-9 pretty-print))
- (use-modules (srfi srfi-9))
-
- (define pprint pretty-print)
- (define lalr-keyword? symbol?)
- (define-macro (BITS-PER-WORD) 30)
- (define-macro (logical-or x . y) `(logior ,x ,@y))
- (define-macro (lalr-error msg obj) `(error ,msg ,obj))
- (define (note-source-location lvalue tok)
- (if (and (supports-source-properties? lvalue)
- (not (source-property lvalue 'loc))
- (lexical-token? tok))
- (set-source-property! lvalue 'loc (lexical-token-source tok)))
- lvalue))
-
- ;; -- Mes
- (mes
- (define pprint display)
- (define lalr-keyword? symbol?)
- (define-macro (BITS-PER-WORD) 30)
- (define-macro (logical-or x . y) `(logior ,x ,@y))
- (define-macro (lalr-error msg obj) `(error ,msg ,obj))
- (define (note-source-location lvalue tok) lvalue)
- )
-
- ;; -- Kawa
- (kawa
- (require 'pretty-print)
- (define (BITS-PER-WORD) 30)
- (define logical-or logior)
- (define (lalr-keyword? obj) (keyword? obj))
- (define (pprint obj) (pretty-print obj))
- (define (lalr-error msg obj) (error msg obj))
- (define (note-source-location lvalue tok) lvalue))
-
- ;; -- SISC
- (sisc
- (import logicops)
- (import record)
-
- (define pprint pretty-print)
- (define lalr-keyword? symbol?)
- (define-macro BITS-PER-WORD (lambda () 32))
- (define-macro logical-or (lambda (x . y) `(logor ,x ,@y)))
- (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj))
- (define (note-source-location lvalue tok) lvalue))
-
- ;; -- Gauche
- (gauche
- (use gauche.record)
- (define-macro (def-macro form . body)
- `(define-macro ,form (let () ,@body)))
- (define pprint (lambda (obj) (write obj) (newline)))
- (define lalr-keyword? symbol?)
- (def-macro (BITS-PER-WORD) 30)
- (def-macro (logical-or x . y) `(logior ,x . ,y))
- (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
- (define (note-source-location lvalue tok) lvalue))
-
- (else
- (error "Unsupported Scheme system")))
-
-
-(define-record-type lexical-token
- (make-lexical-token category source value)
- lexical-token?
- (category lexical-token-category)
- (source lexical-token-source)
- (value lexical-token-value))
-
-
-(define-record-type source-location
- (make-source-location input line column offset length)
- source-location?
- (input source-location-input)
- (line source-location-line)
- (column source-location-column)
- (offset source-location-offset)
- (length source-location-length))
-
-
-
- ;; - Macros pour la gestion des vecteurs de bits
-
-(define-macro (lalr-parser . arguments)
- (define (set-bit v b)
- (let ((x (quotient b (BITS-PER-WORD)))
- (y (expt 2 (remainder b (BITS-PER-WORD)))))
- (vector-set! v x (logical-or (vector-ref v x) y))))
-
- (define (bit-union v1 v2 n)
- (do ((i 0 (+ i 1)))
- ((= i n))
- (vector-set! v1 i (logical-or (vector-ref v1 i)
- (vector-ref v2 i)))))
-
- ;; - Macro pour les structures de donnees
-
- (define (new-core) (make-vector 4 0))
- (define (set-core-number! c n) (vector-set! c 0 n))
- (define (set-core-acc-sym! c s) (vector-set! c 1 s))
- (define (set-core-nitems! c n) (vector-set! c 2 n))
- (define (set-core-items! c i) (vector-set! c 3 i))
- (define (core-number c) (vector-ref c 0))
- (define (core-acc-sym c) (vector-ref c 1))
- (define (core-nitems c) (vector-ref c 2))
- (define (core-items c) (vector-ref c 3))
-
- (define (new-shift) (make-vector 3 0))
- (define (set-shift-number! c x) (vector-set! c 0 x))
- (define (set-shift-nshifts! c x) (vector-set! c 1 x))
- (define (set-shift-shifts! c x) (vector-set! c 2 x))
- (define (shift-number s) (vector-ref s 0))
- (define (shift-nshifts s) (vector-ref s 1))
- (define (shift-shifts s) (vector-ref s 2))
-
- (define (new-red) (make-vector 3 0))
- (define (set-red-number! c x) (vector-set! c 0 x))
- (define (set-red-nreds! c x) (vector-set! c 1 x))
- (define (set-red-rules! c x) (vector-set! c 2 x))
- (define (red-number c) (vector-ref c 0))
- (define (red-nreds c) (vector-ref c 1))
- (define (red-rules c) (vector-ref c 2))
-
-
- (define (new-set nelem)
- (make-vector nelem 0))
-
-
- (define (vector-map f v)
- (let ((vm-n (- (vector-length v) 1)))
- (let loop ((vm-low 0) (vm-high vm-n))
- (if (= vm-low vm-high)
- (vector-set! v vm-low (f (vector-ref v vm-low) vm-low))
- (let ((vm-middle (quotient (+ vm-low vm-high) 2)))
- (loop vm-low vm-middle)
- (loop (+ vm-middle 1) vm-high))))))
-
-
- ;; - Constantes
- (define STATE-TABLE-SIZE 1009)
-
-
- ;; - Tableaux
- (define rrhs #f)
- (define rlhs #f)
- (define ritem #f)
- (define nullable #f)
- (define derives #f)
- (define fderives #f)
- (define firsts #f)
- (define kernel-base #f)
- (define kernel-end #f)
- (define shift-symbol #f)
- (define shift-set #f)
- (define red-set #f)
- (define state-table #f)
- (define acces-symbol #f)
- (define reduction-table #f)
- (define shift-table #f)
- (define consistent #f)
- (define lookaheads #f)
- (define LA #f)
- (define LAruleno #f)
- (define lookback #f)
- (define goto-map #f)
- (define from-state #f)
- (define to-state #f)
- (define includes #f)
- (define F #f)
- (define action-table #f)
-
- ;; - Variables
- (define nitems #f)
- (define nrules #f)
- (define nvars #f)
- (define nterms #f)
- (define nsyms #f)
- (define nstates #f)
- (define first-state #f)
- (define last-state #f)
- (define final-state #f)
- (define first-shift #f)
- (define last-shift #f)
- (define first-reduction #f)
- (define last-reduction #f)
- (define nshifts #f)
- (define maxrhs #f)
- (define ngotos #f)
- (define token-set-size #f)
-
- (define driver-name 'lr-driver)
-
- (define (glr-driver?)
- (eq? driver-name 'glr-driver))
- (define (lr-driver?)
- (eq? driver-name 'lr-driver))
-
- (define (gen-tables! tokens gram )
- (initialize-all)
- (rewrite-grammar
- tokens
- gram
- (lambda (terms terms/prec vars gram gram/actions)
- (set! the-terminals/prec (list->vector terms/prec))
- (set! the-terminals (list->vector terms))
- (set! the-nonterminals (list->vector vars))
- (set! nterms (length terms))
- (set! nvars (length vars))
- (set! nsyms (+ nterms nvars))
- (let ((no-of-rules (length gram/actions))
- (no-of-items (let loop ((l gram/actions) (count 0))
- (if (null? l)
- count
- (loop (cdr l) (+ count (length (caar l))))))))
- (pack-grammar no-of-rules no-of-items gram)
- (set-derives)
- (set-nullable)
- (generate-states)
- (lalr)
- (build-tables)
- (compact-action-table terms)
- gram/actions))))
-
-
- (define (initialize-all)
- (set! rrhs #f)
- (set! rlhs #f)
- (set! ritem #f)
- (set! nullable #f)
- (set! derives #f)
- (set! fderives #f)
- (set! firsts #f)
- (set! kernel-base #f)
- (set! kernel-end #f)
- (set! shift-symbol #f)
- (set! shift-set #f)
- (set! red-set #f)
- (set! state-table (make-vector STATE-TABLE-SIZE '()))
- (set! acces-symbol #f)
- (set! reduction-table #f)
- (set! shift-table #f)
- (set! consistent #f)
- (set! lookaheads #f)
- (set! LA #f)
- (set! LAruleno #f)
- (set! lookback #f)
- (set! goto-map #f)
- (set! from-state #f)
- (set! to-state #f)
- (set! includes #f)
- (set! F #f)
- (set! action-table #f)
- (set! nstates #f)
- (set! first-state #f)
- (set! last-state #f)
- (set! final-state #f)
- (set! first-shift #f)
- (set! last-shift #f)
- (set! first-reduction #f)
- (set! last-reduction #f)
- (set! nshifts #f)
- (set! maxrhs #f)
- (set! ngotos #f)
- (set! token-set-size #f)
- (set! rule-precedences '()))
-
-
- (define (pack-grammar no-of-rules no-of-items gram)
- (set! nrules (+ no-of-rules 1))
- (set! nitems no-of-items)
- (set! rlhs (make-vector nrules #f))
- (set! rrhs (make-vector nrules #f))
- (set! ritem (make-vector (+ 1 nitems) #f))
-
- (let loop ((p gram) (item-no 0) (rule-no 1))
- (if (not (null? p))
- (let ((nt (caar p)))
- (let loop2 ((prods (cdar p)) (it-no2 item-no) (rl-no2 rule-no))
- (if (null? prods)
- (loop (cdr p) it-no2 rl-no2)
- (begin
- (vector-set! rlhs rl-no2 nt)
- (vector-set! rrhs rl-no2 it-no2)
- (let loop3 ((rhs (car prods)) (it-no3 it-no2))
- (if (null? rhs)
- (begin
- (vector-set! ritem it-no3 (- rl-no2))
- (loop2 (cdr prods) (+ it-no3 1) (+ rl-no2 1)))
- (begin
- (vector-set! ritem it-no3 (car rhs))
- (loop3 (cdr rhs) (+ it-no3 1))))))))))))
-
-
- (define (set-derives)
- (define delts (make-vector (+ nrules 1) 0))
- (define dset (make-vector nvars -1))
-
- (let loop ((i 1) (j 0)) ; i = 0
- (if (< i nrules)
- (let ((lhs (vector-ref rlhs i)))
- (if (>= lhs 0)
- (begin
- (vector-set! delts j (cons i (vector-ref dset lhs)))
- (vector-set! dset lhs j)
- (loop (+ i 1) (+ j 1)))
- (loop (+ i 1) j)))))
-
- (set! derives (make-vector nvars 0))
-
- (let loop ((i 0))
- (if (< i nvars)
- (let ((q (let loop2 ((j (vector-ref dset i)) (s '()))
- (if (< j 0)
- s
- (let ((x (vector-ref delts j)))
- (loop2 (cdr x) (cons (car x) s)))))))
- (vector-set! derives i q)
- (loop (+ i 1))))))
-
-
-
- (define (set-nullable)
- (set! nullable (make-vector nvars #f))
- (let ((squeue (make-vector nvars #f))
- (rcount (make-vector (+ nrules 1) 0))
- (rsets (make-vector nvars #f))
- (relts (make-vector (+ nitems nvars 1) #f)))
- (let loop ((r 0) (s2 0) (p 0))
- (let ((*r (vector-ref ritem r)))
- (if *r
- (if (< *r 0)
- (let ((symbol (vector-ref rlhs (- *r))))
- (if (and (>= symbol 0)
- (not (vector-ref nullable symbol)))
- (begin
- (vector-set! nullable symbol #t)
- (vector-set! squeue s2 symbol)
- (loop (+ r 1) (+ s2 1) p))))
- (let loop2 ((r1 r) (any-tokens #f))
- (let* ((symbol (vector-ref ritem r1)))
- (if (> symbol 0)
- (loop2 (+ r1 1) (or any-tokens (>= symbol nvars)))
- (if (not any-tokens)
- (let ((ruleno (- symbol)))
- (let loop3 ((r2 r) (p2 p))
- (let ((symbol (vector-ref ritem r2)))
- (if (> symbol 0)
- (begin
- (vector-set! rcount ruleno
- (+ (vector-ref rcount ruleno) 1))
- (vector-set! relts p2
- (cons (vector-ref rsets symbol)
- ruleno))
- (vector-set! rsets symbol p2)
- (loop3 (+ r2 1) (+ p2 1)))
- (loop (+ r2 1) s2 p2)))))
- (loop (+ r1 1) s2 p))))))
- (let loop ((s1 0) (s3 s2))
- (if (< s1 s3)
- (let loop2 ((p (vector-ref rsets (vector-ref squeue s1))) (s4 s3))
- (if p
- (let* ((x (vector-ref relts p))
- (ruleno (cdr x))
- (y (- (vector-ref rcount ruleno) 1)))
- (vector-set! rcount ruleno y)
- (if (= y 0)
- (let ((symbol (vector-ref rlhs ruleno)))
- (if (and (>= symbol 0)
- (not (vector-ref nullable symbol)))
- (begin
- (vector-set! nullable symbol #t)
- (vector-set! squeue s4 symbol)
- (loop2 (car x) (+ s4 1)))
- (loop2 (car x) s4)))
- (loop2 (car x) s4))))
- (loop (+ s1 1) s4)))))))))
-
-
-
- (define (set-firsts)
- (set! firsts (make-vector nvars '()))
-
- ;; -- initialization
- (let loop ((i 0))
- (if (< i nvars)
- (let loop2 ((sp (vector-ref derives i)))
- (if (null? sp)
- (loop (+ i 1))
- (let ((sym (vector-ref ritem (vector-ref rrhs (car sp)))))
- (if (< -1 sym nvars)
- (vector-set! firsts i (sinsert sym (vector-ref firsts i))))
- (loop2 (cdr sp)))))))
-
- ;; -- reflexive and transitive closure
- (let loop ((continue #t))
- (if continue
- (let loop2 ((i 0) (cont #f))
- (if (>= i nvars)
- (loop cont)
- (let* ((x (vector-ref firsts i))
- (y (let loop3 ((l x) (z x))
- (if (null? l)
- z
- (loop3 (cdr l)
- (sunion (vector-ref firsts (car l)) z))))))
- (if (equal? x y)
- (loop2 (+ i 1) cont)
- (begin
- (vector-set! firsts i y)
- (loop2 (+ i 1) #t))))))))
-
- (let loop ((i 0))
- (if (< i nvars)
- (begin
- (vector-set! firsts i (sinsert i (vector-ref firsts i)))
- (loop (+ i 1))))))
-
-
-
-
- (define (set-fderives)
- (set! fderives (make-vector nvars #f))
-
- (set-firsts)
-
- (let loop ((i 0))
- (if (< i nvars)
- (let ((x (let loop2 ((l (vector-ref firsts i)) (fd '()))
- (if (null? l)
- fd
- (loop2 (cdr l)
- (sunion (vector-ref derives (car l)) fd))))))
- (vector-set! fderives i x)
- (loop (+ i 1))))))
-
-
- (define (closure core)
- ;; Initialization
- (define ruleset (make-vector nrules #f))
-
- (let loop ((csp core))
- (if (not (null? csp))
- (let ((sym (vector-ref ritem (car csp))))
- (if (< -1 sym nvars)
- (let loop2 ((dsp (vector-ref fderives sym)))
- (if (not (null? dsp))
- (begin
- (vector-set! ruleset (car dsp) #t)
- (loop2 (cdr dsp))))))
- (loop (cdr csp)))))
-
- (let loop ((ruleno 1) (csp core) (itemsetv '())) ; ruleno = 0
- (if (< ruleno nrules)
- (if (vector-ref ruleset ruleno)
- (let ((itemno (vector-ref rrhs ruleno)))
- (let loop2 ((c csp) (itemsetv2 itemsetv))
- (if (and (pair? c)
- (< (car c) itemno))
- (loop2 (cdr c) (cons (car c) itemsetv2))
- (loop (+ ruleno 1) c (cons itemno itemsetv2)))))
- (loop (+ ruleno 1) csp itemsetv))
- (let loop2 ((c csp) (itemsetv2 itemsetv))
- (if (pair? c)
- (loop2 (cdr c) (cons (car c) itemsetv2))
- (reverse itemsetv2))))))
-
-
-
- (define (allocate-item-sets)
- (set! kernel-base (make-vector nsyms 0))
- (set! kernel-end (make-vector nsyms #f)))
-
-
- (define (allocate-storage)
- (allocate-item-sets)
- (set! red-set (make-vector (+ nrules 1) 0)))
-
- ; --
-
-
- (define (initialize-states)
- (let ((p (new-core)))
- (set-core-number! p 0)
- (set-core-acc-sym! p #f)
- (set-core-nitems! p 1)
- (set-core-items! p '(0))
-
- (set! first-state (list p))
- (set! last-state first-state)
- (set! nstates 1)))
-
-
-
- (define (generate-states)
- (allocate-storage)
- (set-fderives)
- (initialize-states)
- (let loop ((this-state first-state))
- (if (pair? this-state)
- (let* ((x (car this-state))
- (is (closure (core-items x))))
- (save-reductions x is)
- (new-itemsets is)
- (append-states)
- (if (> nshifts 0)
- (save-shifts x))
- (loop (cdr this-state))))))
-
-
- (define (new-itemsets itemset)
- ;; - Initialization
- (set! shift-symbol '())
- (let loop ((i 0))
- (if (< i nsyms)
- (begin
- (vector-set! kernel-end i '())
- (loop (+ i 1)))))
-
- (let loop ((isp itemset))
- (if (pair? isp)
- (let* ((i (car isp))
- (sym (vector-ref ritem i)))
- (if (>= sym 0)
- (begin
- (set! shift-symbol (sinsert sym shift-symbol))
- (let ((x (vector-ref kernel-end sym)))
- (if (null? x)
- (begin
- (vector-set! kernel-base sym (cons (+ i 1) x))
- (vector-set! kernel-end sym (vector-ref kernel-base sym)))
- (begin
- (set-cdr! x (list (+ i 1)))
- (vector-set! kernel-end sym (cdr x)))))))
- (loop (cdr isp)))))
-
- (set! nshifts (length shift-symbol)))
-
-
-
- (define (get-state sym)
- (let* ((isp (vector-ref kernel-base sym))
- (n (length isp))
- (key (let loop ((isp1 isp) (k 0))
- (if (null? isp1)
- (modulo k STATE-TABLE-SIZE)
- (loop (cdr isp1) (+ k (car isp1))))))
- (sp (vector-ref state-table key)))
- (if (null? sp)
- (let ((x (new-state sym)))
- (vector-set! state-table key (list x))
- (core-number x))
- (let loop ((sp1 sp))
- (if (and (= n (core-nitems (car sp1)))
- (let loop2 ((i1 isp) (t (core-items (car sp1))))
- (if (and (pair? i1)
- (= (car i1)
- (car t)))
- (loop2 (cdr i1) (cdr t))
- (null? i1))))
- (core-number (car sp1))
- (if (null? (cdr sp1))
- (let ((x (new-state sym)))
- (set-cdr! sp1 (list x))
- (core-number x))
- (loop (cdr sp1))))))))
-
-
- (define (new-state sym)
- (let* ((isp (vector-ref kernel-base sym))
- (n (length isp))
- (p (new-core)))
- (set-core-number! p nstates)
- (set-core-acc-sym! p sym)
- (if (= sym nvars) (set! final-state nstates))
- (set-core-nitems! p n)
- (set-core-items! p isp)
- (set-cdr! last-state (list p))
- (set! last-state (cdr last-state))
- (set! nstates (+ nstates 1))
- p))
-
-
- ; --
-
- (define (append-states)
- (set! shift-set
- (let loop ((l (reverse shift-symbol)))
- (if (null? l)
- '()
- (cons (get-state (car l)) (loop (cdr l)))))))
-
- ; --
-
- (define (save-shifts core)
- (let ((p (new-shift)))
- (set-shift-number! p (core-number core))
- (set-shift-nshifts! p nshifts)
- (set-shift-shifts! p shift-set)
- (if last-shift
- (begin
- (set-cdr! last-shift (list p))
- (set! last-shift (cdr last-shift)))
- (begin
- (set! first-shift (list p))
- (set! last-shift first-shift)))))
-
- (define (save-reductions core itemset)
- (let ((rs (let loop ((l itemset))
- (if (null? l)
- '()
- (let ((item (vector-ref ritem (car l))))
- (if (< item 0)
- (cons (- item) (loop (cdr l)))
- (loop (cdr l))))))))
- (if (pair? rs)
- (let ((p (new-red)))
- (set-red-number! p (core-number core))
- (set-red-nreds! p (length rs))
- (set-red-rules! p rs)
- (if last-reduction
- (begin
- (set-cdr! last-reduction (list p))
- (set! last-reduction (cdr last-reduction)))
- (begin
- (set! first-reduction (list p))
- (set! last-reduction first-reduction)))))))
-
-
- ; --
-
- (define (lalr)
- (set! token-set-size (+ 1 (quotient nterms (BITS-PER-WORD))))
- (set-accessing-symbol)
- (set-shift-table)
- (set-reduction-table)
- (set-max-rhs)
- (initialize-LA)
- (set-goto-map)
- (initialize-F)
- (build-relations)
- (digraph includes)
- (compute-lookaheads))
-
- (define (set-accessing-symbol)
- (set! acces-symbol (make-vector nstates #f))
- (let loop ((l first-state))
- (if (pair? l)
- (let ((x (car l)))
- (vector-set! acces-symbol (core-number x) (core-acc-sym x))
- (loop (cdr l))))))
-
- (define (set-shift-table)
- (set! shift-table (make-vector nstates #f))
- (let loop ((l first-shift))
- (if (pair? l)
- (let ((x (car l)))
- (vector-set! shift-table (shift-number x) x)
- (loop (cdr l))))))
-
- (define (set-reduction-table)
- (set! reduction-table (make-vector nstates #f))
- (let loop ((l first-reduction))
- (if (pair? l)
- (let ((x (car l)))
- (vector-set! reduction-table (red-number x) x)
- (loop (cdr l))))))
-
- (define (set-max-rhs)
- (let loop ((p 0) (curmax 0) (length 0))
- (let ((x (vector-ref ritem p)))
- (if x
- (if (>= x 0)
- (loop (+ p 1) curmax (+ length 1))
- (loop (+ p 1) (max curmax length) 0))
- (set! maxrhs curmax)))))
-
- (define (initialize-LA)
- (define (last l)
- (if (null? (cdr l))
- (car l)
- (last (cdr l))))
-
- (set! consistent (make-vector nstates #f))
- (set! lookaheads (make-vector (+ nstates 1) #f))
-
- (let loop ((count 0) (i 0))
- (if (< i nstates)
- (begin
- (vector-set! lookaheads i count)
- (let ((rp (vector-ref reduction-table i))
- (sp (vector-ref shift-table i)))
- (if (and rp
- (or (> (red-nreds rp) 1)
- (and sp
- (not
- (< (vector-ref acces-symbol
- (last (shift-shifts sp)))
- nvars)))))
- (loop (+ count (red-nreds rp)) (+ i 1))
- (begin
- (vector-set! consistent i #t)
- (loop count (+ i 1))))))
-
- (begin
- (vector-set! lookaheads nstates count)
- (let ((c (max count 1)))
- (set! LA (make-vector c #f))
- (do ((j 0 (+ j 1))) ((= j c)) (vector-set! LA j (new-set token-set-size)))
- (set! LAruleno (make-vector c -1))
- (set! lookback (make-vector c #f)))
- (let loop ((i 0) (np 0))
- (if (< i nstates)
- (if (vector-ref consistent i)
- (loop (+ i 1) np)
- (let ((rp (vector-ref reduction-table i)))
- (if rp
- (let loop2 ((j (red-rules rp)) (np2 np))
- (if (null? j)
- (loop (+ i 1) np2)
- (begin
- (vector-set! LAruleno np2 (car j))
- (loop2 (cdr j) (+ np2 1)))))
- (loop (+ i 1) np))))))))))
-
-
- (define (set-goto-map)
- (set! goto-map (make-vector (+ nvars 1) 0))
- (let ((temp-map (make-vector (+ nvars 1) 0)))
- (let loop ((ng 0) (sp first-shift))
- (if (pair? sp)
- (let loop2 ((i (reverse (shift-shifts (car sp)))) (ng2 ng))
- (if (pair? i)
- (let ((symbol (vector-ref acces-symbol (car i))))
- (if (< symbol nvars)
- (begin
- (vector-set! goto-map symbol
- (+ 1 (vector-ref goto-map symbol)))
- (loop2 (cdr i) (+ ng2 1)))
- (loop2 (cdr i) ng2)))
- (loop ng2 (cdr sp))))
-
- (let loop ((k 0) (i 0))
- (if (< i nvars)
- (begin
- (vector-set! temp-map i k)
- (loop (+ k (vector-ref goto-map i)) (+ i 1)))
-
- (begin
- (do ((i 0 (+ i 1)))
- ((>= i nvars))
- (vector-set! goto-map i (vector-ref temp-map i)))
-
- (set! ngotos ng)
- (vector-set! goto-map nvars ngotos)
- (vector-set! temp-map nvars ngotos)
- (set! from-state (make-vector ngotos #f))
- (set! to-state (make-vector ngotos #f))
-
- (do ((sp first-shift (cdr sp)))
- ((null? sp))
- (let* ((x (car sp))
- (state1 (shift-number x)))
- (do ((i (shift-shifts x) (cdr i)))
- ((null? i))
- (let* ((state2 (car i))
- (symbol (vector-ref acces-symbol state2)))
- (if (< symbol nvars)
- (let ((k (vector-ref temp-map symbol)))
- (vector-set! temp-map symbol (+ k 1))
- (vector-set! from-state k state1)
- (vector-set! to-state k state2))))))))))))))
-
-
- (define (map-goto state symbol)
- (let loop ((low (vector-ref goto-map symbol))
- (high (- (vector-ref goto-map (+ symbol 1)) 1)))
- (if (> low high)
- (begin
- (display (list "Error in map-goto" state symbol)) (newline)
- 0)
- (let* ((middle (quotient (+ low high) 2))
- (s (vector-ref from-state middle)))
- (cond
- ((= s state)
- middle)
- ((< s state)
- (loop (+ middle 1) high))
- (else
- (loop low (- middle 1))))))))
-
-
- (define (initialize-F)
- (set! F (make-vector ngotos #f))
- (do ((i 0 (+ i 1))) ((= i ngotos)) (vector-set! F i (new-set token-set-size)))
-
- (let ((reads (make-vector ngotos #f)))
-
- (let loop ((i 0) (rowp 0))
- (if (< i ngotos)
- (let* ((rowf (vector-ref F rowp))
- (stateno (vector-ref to-state i))
- (sp (vector-ref shift-table stateno)))
- (if sp
- (let loop2 ((j (shift-shifts sp)) (edges '()))
- (if (pair? j)
- (let ((symbol (vector-ref acces-symbol (car j))))
- (if (< symbol nvars)
- (if (vector-ref nullable symbol)
- (loop2 (cdr j) (cons (map-goto stateno symbol)
- edges))
- (loop2 (cdr j) edges))
- (begin
- (set-bit rowf (- symbol nvars))
- (loop2 (cdr j) edges))))
- (if (pair? edges)
- (vector-set! reads i (reverse edges))))))
- (loop (+ i 1) (+ rowp 1)))))
- (digraph reads)))
-
- (define (add-lookback-edge stateno ruleno gotono)
- (let ((k (vector-ref lookaheads (+ stateno 1))))
- (let loop ((found #f) (i (vector-ref lookaheads stateno)))
- (if (and (not found) (< i k))
- (if (= (vector-ref LAruleno i) ruleno)
- (loop #t i)
- (loop found (+ i 1)))
-
- (if (not found)
- (begin (display "Error in add-lookback-edge : ")
- (display (list stateno ruleno gotono)) (newline))
- (vector-set! lookback i
- (cons gotono (vector-ref lookback i))))))))
-
-
- (define (transpose r-arg n)
- (let ((new-end (make-vector n #f))
- (new-R (make-vector n #f)))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (let ((x (list 'bidon)))
- (vector-set! new-R i x)
- (vector-set! new-end i x)))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (let ((sp (vector-ref r-arg i)))
- (if (pair? sp)
- (let loop ((sp2 sp))
- (if (pair? sp2)
- (let* ((x (car sp2))
- (y (vector-ref new-end x)))
- (set-cdr! y (cons i (cdr y)))
- (vector-set! new-end x (cdr y))
- (loop (cdr sp2))))))))
- (do ((i 0 (+ i 1)))
- ((= i n))
- (vector-set! new-R i (cdr (vector-ref new-R i))))
-
- new-R))
-
-
-
- (define (build-relations)
-
- (define (get-state stateno symbol)
- (let loop ((j (shift-shifts (vector-ref shift-table stateno)))
- (stno stateno))
- (if (null? j)
- stno
- (let ((st2 (car j)))
- (if (= (vector-ref acces-symbol st2) symbol)
- st2
- (loop (cdr j) st2))))))
-
- (set! includes (make-vector ngotos #f))
- (do ((i 0 (+ i 1)))
- ((= i ngotos))
- (let ((state1 (vector-ref from-state i))
- (symbol1 (vector-ref acces-symbol (vector-ref to-state i))))
- (let loop ((rulep (vector-ref derives symbol1))
- (edges '()))
- (if (pair? rulep)
- (let ((*rulep (car rulep)))
- (let loop2 ((rp (vector-ref rrhs *rulep))
- (stateno state1)
- (states (list state1)))
- (let ((*rp (vector-ref ritem rp)))
- (if (> *rp 0)
- (let ((st (get-state stateno *rp)))
- (loop2 (+ rp 1) st (cons st states)))
- (begin
-
- (if (not (vector-ref consistent stateno))
- (add-lookback-edge stateno *rulep i))
-
- (let loop2 ((done #f)
- (stp (cdr states))
- (rp2 (- rp 1))
- (edgp edges))
- (if (not done)
- (let ((*rp (vector-ref ritem rp2)))
- (if (< -1 *rp nvars)
- (loop2 (not (vector-ref nullable *rp))
- (cdr stp)
- (- rp2 1)
- (cons (map-goto (car stp) *rp) edgp))
- (loop2 #t stp rp2 edgp)))
-
- (loop (cdr rulep) edgp))))))))
- (vector-set! includes i edges)))))
- (set! includes (transpose includes ngotos)))
-
-
-
- (define (compute-lookaheads)
- (let ((n (vector-ref lookaheads nstates)))
- (let loop ((i 0))
- (if (< i n)
- (let loop2 ((sp (vector-ref lookback i)))
- (if (pair? sp)
- (let ((LA-i (vector-ref LA i))
- (F-j (vector-ref F (car sp))))
- (bit-union LA-i F-j token-set-size)
- (loop2 (cdr sp)))
- (loop (+ i 1))))))))
-
-
-
- (define (digraph relation)
- (define infinity (+ ngotos 2))
- (define INDEX (make-vector (+ ngotos 1) 0))
- (define VERTICES (make-vector (+ ngotos 1) 0))
- (define top 0)
- (define R relation)
-
- (define (traverse i)
- (set! top (+ 1 top))
- (vector-set! VERTICES top i)
- (let ((height top))
- (vector-set! INDEX i height)
- (let ((rp (vector-ref R i)))
- (if (pair? rp)
- (let loop ((rp2 rp))
- (if (pair? rp2)
- (let ((j (car rp2)))
- (if (= 0 (vector-ref INDEX j))
- (traverse j))
- (if (> (vector-ref INDEX i)
- (vector-ref INDEX j))
- (vector-set! INDEX i (vector-ref INDEX j)))
- (let ((F-i (vector-ref F i))
- (F-j (vector-ref F j)))
- (bit-union F-i F-j token-set-size))
- (loop (cdr rp2))))))
- (if (= (vector-ref INDEX i) height)
- (let loop ()
- (let ((j (vector-ref VERTICES top)))
- (set! top (- top 1))
- (vector-set! INDEX j infinity)
- (if (not (= i j))
- (begin
- (bit-union (vector-ref F i)
- (vector-ref F j)
- token-set-size)
- (loop)))))))))
-
- (let loop ((i 0))
- (if (< i ngotos)
- (begin
- (if (and (= 0 (vector-ref INDEX i))
- (pair? (vector-ref R i)))
- (traverse i))
- (loop (+ i 1))))))
-
-
- ;; ----------------------------------------------------------------------
- ;; operator precedence management
- ;; ----------------------------------------------------------------------
-
- ;; a vector of precedence descriptors where each element
- ;; is of the form (terminal type precedence)
- (define the-terminals/prec #f) ; terminal symbols with precedence
- ; the precedence is an integer >= 0
- (define (get-symbol-precedence sym)
- (caddr (vector-ref the-terminals/prec sym)))
- ; the operator type is either 'none, 'left, 'right, or 'nonassoc
- (define (get-symbol-assoc sym)
- (cadr (vector-ref the-terminals/prec sym)))
-
- (define rule-precedences '())
- (define (add-rule-precedence! rule sym)
- (set! rule-precedences
- (cons (cons rule sym) rule-precedences)))
-
- (define (get-rule-precedence ruleno)
- (cond
- ((assq ruleno rule-precedences)
- => (lambda (p)
- (get-symbol-precedence (cdr p))))
- (else
- ;; process the rule symbols from left to right
- (let loop ((i (vector-ref rrhs ruleno))
- (prec 0))
- (let ((item (vector-ref ritem i)))
- ;; end of rule
- (if (< item 0)
- prec
- (let ((i1 (+ i 1)))
- (if (>= item nvars)
- ;; it's a terminal symbol
- (loop i1 (get-symbol-precedence (- item nvars)))
- (loop i1 prec)))))))))
-
- ;; ----------------------------------------------------------------------
- ;; Build the various tables
- ;; ----------------------------------------------------------------------
-
- (define expected-conflicts 0)
-
- (define (build-tables)
-
- (define (resolve-conflict sym rule)
- (let ((sym-prec (get-symbol-precedence sym))
- (sym-assoc (get-symbol-assoc sym))
- (rule-prec (get-rule-precedence rule)))
- (cond
- ((> sym-prec rule-prec) 'shift)
- ((< sym-prec rule-prec) 'reduce)
- ((eq? sym-assoc 'left) 'reduce)
- ((eq? sym-assoc 'right) 'shift)
- (else 'none))))
-
- (define conflict-messages '())
-
- (define (add-conflict-message . l)
- (set! conflict-messages (cons l conflict-messages)))
-
- (define (log-conflicts)
- (if (> (length conflict-messages) expected-conflicts)
- (for-each
- (lambda (message)
- (for-each display message)
- (newline))
- conflict-messages)))
-
- ;; --- Add an action to the action table
- (define (add-action state symbol new-action)
- (let* ((state-actions (vector-ref action-table state))
- (actions (assv symbol state-actions)))
- (if (pair? actions)
- (let ((current-action (cadr actions)))
- (if (not (= new-action current-action))
- ;; -- there is a conflict
- (begin
- (if (and (<= current-action 0) (<= new-action 0))
- ;; --- reduce/reduce conflict
- (begin
- (add-conflict-message
- "%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action)
- ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
- (if (glr-driver?)
- (set-cdr! (cdr actions) (cons new-action (cddr actions)))
- (set-car! (cdr actions) (max current-action new-action))))
- ;; --- shift/reduce conflict
- ;; can we resolve the conflict using precedences?
- (case (resolve-conflict symbol (- current-action))
- ;; -- shift
- ((shift) (if (glr-driver?)
- (set-cdr! (cdr actions) (cons new-action (cddr actions)))
- (set-car! (cdr actions) new-action)))
- ;; -- reduce
- ((reduce) #f) ; well, nothing to do...
- ;; -- signal a conflict!
- (else (add-conflict-message
- "%% Shift/Reduce conflict (shift " new-action ", reduce " (- current-action)
- ") on '" (get-symbol (+ symbol nvars)) "' in state " state)
- (if (glr-driver?)
- (set-cdr! (cdr actions) (cons new-action (cddr actions)))
- (set-car! (cdr actions) new-action))))))))
-
- (vector-set! action-table state (cons (list symbol new-action) state-actions)))
- ))
-
- (define (add-action-for-all-terminals state action)
- (do ((i 1 (+ i 1)))
- ((= i nterms))
- (add-action state i action)))
-
- (set! action-table (make-vector nstates '()))
-
- (do ((i 0 (+ i 1))) ; i = state
- ((= i nstates))
- (let ((red (vector-ref reduction-table i)))
- (if (and red (>= (red-nreds red) 1))
- (if (and (= (red-nreds red) 1) (vector-ref consistent i))
- (if (glr-driver?)
- (add-action-for-all-terminals i (- (car (red-rules red))))
- (add-action i 'default (- (car (red-rules red)))))
- (let ((k (vector-ref lookaheads (+ i 1))))
- (let loop ((j (vector-ref lookaheads i)))
- (if (< j k)
- (let ((rule (- (vector-ref LAruleno j)))
- (lav (vector-ref LA j)))
- (let loop2 ((token 0) (x (vector-ref lav 0)) (y 1) (z 0))
- (if (< token nterms)
- (begin
- (let ((in-la-set? (modulo x 2)))
- (if (= in-la-set? 1)
- (add-action i token rule)))
- (if (= y (BITS-PER-WORD))
- (loop2 (+ token 1)
- (vector-ref lav (+ z 1))
- 1
- (+ z 1))
- (loop2 (+ token 1) (quotient x 2) (+ y 1) z)))))
- (loop (+ j 1)))))))))
-
- (let ((shiftp (vector-ref shift-table i)))
- (if shiftp
- (let loop ((k (shift-shifts shiftp)))
- (if (pair? k)
- (let* ((state (car k))
- (symbol (vector-ref acces-symbol state)))
- (if (>= symbol nvars)
- (add-action i (- symbol nvars) state))
- (loop (cdr k))))))))
-
- (add-action final-state 0 'accept)
- (log-conflicts))
-
- (define (compact-action-table terms)
- (define (most-common-action acts)
- (let ((accums '()))
- (let loop ((l acts))
- (if (pair? l)
- (let* ((x (cadar l))
- (y (assv x accums)))
- (if (and (number? x) (< x 0))
- (if y
- (set-cdr! y (+ 1 (cdr y)))
- (set! accums (cons `(,x . 1) accums))))
- (loop (cdr l)))))
-
- (let loop ((l accums) (max 0) (sym #f))
- (if (null? l)
- sym
- (let ((x (car l)))
- (if (> (cdr x) max)
- (loop (cdr l) (cdr x) (car x))
- (loop (cdr l) max sym)))))))
-
- (define (translate-terms acts)
- (map (lambda (act)
- (cons (list-ref terms (car act))
- (cdr act)))
- acts))
-
- (do ((i 0 (+ i 1)))
- ((= i nstates))
- (let ((acts (vector-ref action-table i)))
- (if (vector? (vector-ref reduction-table i))
- (let ((act (most-common-action acts)))
- (vector-set! action-table i
- (cons `(*default* ,(if act act '*error*))
- (translate-terms
- (lalr-filter (lambda (x)
- (not (and (= (length x) 2)
- (eq? (cadr x) act))))
- acts)))))
- (vector-set! action-table i
- (cons `(*default* *error*)
- (translate-terms acts)))))))
-
-
-
- ;; --
-
- (define (rewrite-grammar tokens grammar k)
-
- (define eoi '*eoi*)
-
- (define (check-terminal term terms)
- (cond
- ((not (valid-terminal? term))
- (lalr-error "invalid terminal: " term))
- ((member term terms)
- (lalr-error "duplicate definition of terminal: " term))))
-
- (define (prec->type prec)
- (cdr (assq prec '((left: . left)
- (right: . right)
- (nonassoc: . nonassoc)))))
-
- (cond
- ;; --- a few error conditions
- ((not (list? tokens))
- (lalr-error "Invalid token list: " tokens))
- ((not (pair? grammar))
- (lalr-error "Grammar definition must have a non-empty list of productions" '()))
-
- (else
- ;; --- check the terminals
- (let loop1 ((lst tokens)
- (rev-terms '())
- (rev-terms/prec '())
- (prec-level 0))
- (if (pair? lst)
- (let ((term (car lst)))
- (cond
- ((pair? term)
- (if (and (memq (car term) '(left: right: nonassoc:))
- (not (null? (cdr term))))
- (let ((prec (+ prec-level 1))
- (optype (prec->type (car term))))
- (let loop-toks ((l (cdr term))
- (rev-terms rev-terms)
- (rev-terms/prec rev-terms/prec))
- (if (null? l)
- (loop1 (cdr lst) rev-terms rev-terms/prec prec)
- (let ((term (car l)))
- (check-terminal term rev-terms)
- (loop-toks
- (cdr l)
- (cons term rev-terms)
- (cons (list term optype prec) rev-terms/prec))))))
-
- (lalr-error "invalid operator precedence specification: " term)))
-
- (else
- (check-terminal term rev-terms)
- (loop1 (cdr lst)
- (cons term rev-terms)
- (cons (list term 'none 0) rev-terms/prec)
- prec-level))))
-
- ;; --- check the grammar rules
- (let loop2 ((lst grammar) (rev-nonterm-defs '()))
- (if (pair? lst)
- (let ((def (car lst)))
- (if (not (pair? def))
- (lalr-error "Nonterminal definition must be a non-empty list" '())
- (let ((nonterm (car def)))
- (cond ((not (valid-nonterminal? nonterm))
- (lalr-error "Invalid nonterminal:" nonterm))
- ((or (member nonterm rev-terms)
- (assoc nonterm rev-nonterm-defs))
- (lalr-error "Nonterminal previously defined:" nonterm))
- (else
- (loop2 (cdr lst)
- (cons def rev-nonterm-defs)))))))
- (let* ((terms (cons eoi (cons 'error (reverse rev-terms))))
- (terms/prec (cons '(eoi none 0) (cons '(error none 0) (reverse rev-terms/prec))))
- (nonterm-defs (reverse rev-nonterm-defs))
- (nonterms (cons '*start* (map car nonterm-defs))))
- (if (= (length nonterms) 1)
- (lalr-error "Grammar must contain at least one nonterminal" '())
- (let loop-defs ((defs (cons `(*start* (,(cadr nonterms) ,eoi) : $1)
- nonterm-defs))
- (ruleno 0)
- (comp-defs '()))
- (if (pair? defs)
- (let* ((nonterm-def (car defs))
- (compiled-def (rewrite-nonterm-def
- nonterm-def
- ruleno
- terms nonterms)))
- (loop-defs (cdr defs)
- (+ ruleno (length compiled-def))
- (cons compiled-def comp-defs)))
-
- (let ((compiled-nonterm-defs (reverse comp-defs)))
- (k terms
- terms/prec
- nonterms
- (map (lambda (x) (cons (caaar x) (map cdar x)))
- compiled-nonterm-defs)
- (apply append compiled-nonterm-defs))))))))))))))
-
-
- (define (rewrite-nonterm-def nonterm-def ruleno terms nonterms)
-
- (define No-NT (length nonterms))
-
- (define (encode x)
- (let ((PosInNT (pos-in-list x nonterms)))
- (if PosInNT
- PosInNT
- (let ((PosInT (pos-in-list x terms)))
- (if PosInT
- (+ No-NT PosInT)
- (lalr-error "undefined symbol : " x))))))
-
- (define (process-prec-directive rhs ruleno)
- (let loop ((l rhs))
- (if (null? l)
- '()
- (let ((first (car l))
- (rest (cdr l)))
- (cond
- ((or (member first terms) (member first nonterms))
- (cons first (loop rest)))
- ((and (pair? first)
- (eq? (car first) 'prec:))
- (if (and (pair? (cdr first))
- (null? (cddr first))
- (member (cadr first) terms))
- (if (null? rest)
- (begin
- (add-rule-precedence! ruleno (pos-in-list (cadr first) terms))
- (loop rest))
- (lalr-error "prec: directive should be at end of rule: " rhs))
- (lalr-error "Invalid prec: directive: " first)))
- (else
- (lalr-error "Invalid terminal or nonterminal: " first)))))))
-
- (define (check-error-production rhs)
- (let loop ((rhs rhs))
- (if (pair? rhs)
- (begin
- (if (and (eq? (car rhs) 'error)
- (or (null? (cdr rhs))
- (not (member (cadr rhs) terms))
- (not (null? (cddr rhs)))))
- (lalr-error "Invalid 'error' production. A single terminal symbol must follow the 'error' token.:" rhs))
- (loop (cdr rhs))))))
-
-
- (if (not (pair? (cdr nonterm-def)))
- (lalr-error "At least one production needed for nonterminal:" (car nonterm-def))
- (let ((name (symbol->string (car nonterm-def))))
- (let loop1 ((lst (cdr nonterm-def))
- (i 1)
- (rev-productions-and-actions '()))
- (if (not (pair? lst))
- (reverse rev-productions-and-actions)
- (let* ((rhs (process-prec-directive (car lst) (+ ruleno i -1)))
- (rest (cdr lst))
- (prod (map encode (cons (car nonterm-def) rhs))))
- ;; -- check for undefined tokens
- (for-each (lambda (x)
- (if (not (or (member x terms) (member x nonterms)))
- (lalr-error "Invalid terminal or nonterminal:" x)))
- rhs)
- ;; -- check 'error' productions
- (check-error-production rhs)
-
- (if (and (pair? rest)
- (eq? (car rest) ':)
- (pair? (cdr rest)))
- (loop1 (cddr rest)
- (+ i 1)
- (cons (cons prod (cadr rest))
- rev-productions-and-actions))
- (let* ((rhs-length (length rhs))
- (action
- (cons 'vector
- (cons (list 'quote (string->symbol
- (string-append
- name
- "-"
- (number->string i))))
- (let loop-j ((j 1))
- (if (> j rhs-length)
- '()
- (cons (string->symbol
- (string-append
- "$"
- (number->string j)))
- (loop-j (+ j 1)))))))))
- (loop1 rest
- (+ i 1)
- (cons (cons prod action)
- rev-productions-and-actions))))))))))
-
- (define (valid-nonterminal? x)
- (symbol? x))
-
- (define (valid-terminal? x)
- (symbol? x)) ; DB
-
- ;; ----------------------------------------------------------------------
- ;; Miscellaneous
- ;; ----------------------------------------------------------------------
- (define (pos-in-list x lst)
- (let loop ((lst lst) (i 0))
- (cond ((not (pair? lst)) #f)
- ((equal? (car lst) x) i)
- (else (loop (cdr lst) (+ i 1))))))
-
- (define (sunion lst1 lst2) ; union of sorted lists
- (let loop ((L1 lst1)
- (L2 lst2))
- (cond ((null? L1) L2)
- ((null? L2) L1)
- (else
- (let ((x (car L1)) (y (car L2)))
- (cond
- ((> x y)
- (cons y (loop L1 (cdr L2))))
- ((< x y)
- (cons x (loop (cdr L1) L2)))
- (else
- (loop (cdr L1) L2))
- ))))))
-
- (define (sinsert elem lst)
- (let loop ((l1 lst))
- (if (null? l1)
- (cons elem l1)
- (let ((x (car l1)))
- (cond ((< elem x)
- (cons elem l1))
- ((> elem x)
- (cons x (loop (cdr l1))))
- (else
- l1))))))
-
- (define (lalr-filter p lst)
- (let loop ((l lst))
- (if (null? l)
- '()
- (let ((x (car l)) (y (cdr l)))
- (if (p x)
- (cons x (loop y))
- (loop y))))))
-
- ;; ----------------------------------------------------------------------
- ;; Debugging tools ...
- ;; ----------------------------------------------------------------------
- (define the-terminals #f) ; names of terminal symbols
- (define the-nonterminals #f) ; non-terminals
-
- (define (print-item item-no)
- (let loop ((i item-no))
- (let ((v (vector-ref ritem i)))
- (if (>= v 0)
- (loop (+ i 1))
- (let* ((rlno (- v))
- (nt (vector-ref rlhs rlno)))
- (display (vector-ref the-nonterminals nt)) (display " --> ")
- (let loop ((i (vector-ref rrhs rlno)))
- (let ((v (vector-ref ritem i)))
- (if (= i item-no)
- (display ". "))
- (if (>= v 0)
- (begin
- (display (get-symbol v))
- (display " ")
- (loop (+ i 1)))
- (begin
- (display " (rule ")
- (display (- v))
- (display ")")
- (newline))))))))))
-
- (define (get-symbol n)
- (if (>= n nvars)
- (vector-ref the-terminals (- n nvars))
- (vector-ref the-nonterminals n)))
-
-
- (define (print-states)
- (define (print-action act)
- (cond
- ((eq? act '*error*)
- (display " : Error"))
- ((eq? act 'accept)
- (display " : Accept input"))
- ((< act 0)
- (display " : reduce using rule ")
- (display (- act)))
- (else
- (display " : shift and goto state ")
- (display act)))
- (newline)
- #t)
-
- (define (print-actions acts)
- (let loop ((l acts))
- (if (null? l)
- #t
- (let ((sym (caar l))
- (act (cadar l)))
- (display " ")
- (cond
- ((eq? sym 'default)
- (display "default action"))
- (else
- (if (number? sym)
- (display (get-symbol (+ sym nvars)))
- (display sym))))
- (print-action act)
- (loop (cdr l))))))
-
- (if (not action-table)
- (begin
- (display "No generated parser available!")
- (newline)
- #f)
- (begin
- (display "State table") (newline)
- (display "-----------") (newline) (newline)
-
- (let loop ((l first-state))
- (if (null? l)
- #t
- (let* ((core (car l))
- (i (core-number core))
- (items (core-items core))
- (actions (vector-ref action-table i)))
- (display "state ") (display i) (newline)
- (newline)
- (for-each (lambda (x) (display " ") (print-item x))
- items)
- (newline)
- (print-actions actions)
- (newline)
- (loop (cdr l))))))))
-
-
-
- ;; ----------------------------------------------------------------------
-
- (define build-goto-table
- (lambda ()
- `(vector
- ,@(map
- (lambda (shifts)
- (list 'quote
- (if shifts
- (let loop ((l (shift-shifts shifts)))
- (if (null? l)
- '()
- (let* ((state (car l))
- (symbol (vector-ref acces-symbol state)))
- (if (< symbol nvars)
- (cons `(,symbol . ,state)
- (loop (cdr l)))
- (loop (cdr l))))))
- '())))
- (vector->list shift-table)))))
-
-
- (define build-reduction-table
- (lambda (gram/actions)
- `(vector
- '()
- ,@(map
- (lambda (p)
- (let ((act (cdr p)))
- `(lambda ,(if (eq? driver-name 'lr-driver)
- '(___stack ___sp ___goto-table ___push yypushback)
- '(___sp ___goto-table ___push))
- ,(let* ((nt (caar p)) (rhs (cdar p)) (n (length rhs)))
- `(let* (,@(if act
- (let loop ((i 1) (l rhs))
- (if (pair? l)
- (let ((rest (cdr l))
- (ns (number->string (+ (- n i) 1))))
- (cons
- `(tok ,(if (eq? driver-name 'lr-driver)
- `(vector-ref ___stack (- ___sp ,(- (* i 2) 1)))
- `(list-ref ___sp ,(+ (* (- i 1) 2) 1))))
- (cons
- `(,(string->symbol (string-append "$" ns))
- (if (lexical-token? tok) (lexical-token-value tok) tok))
- (cons
- `(,(string->symbol (string-append "@" ns))
- (if (lexical-token? tok) (lexical-token-source tok) tok))
- (loop (+ i 1) rest)))))
- '()))
- '()))
- ,(if (= nt 0)
- '$1
- `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp))
- ,(if (eq? driver-name 'lr-driver)
- `(vector-ref ___stack (- ___sp ,(length rhs)))
- `(list-ref ___sp ,(length rhs))))))))))
-
- gram/actions))))
-
-
-
- ;; Options
-
- (define *valid-options*
- (list
- (cons 'out-table:
- (lambda (option)
- (and (list? option)
- (= (length option) 2)
- (string? (cadr option)))))
- (cons 'output:
- (lambda (option)
- (and (list? option)
- (= (length option) 3)
- (symbol? (cadr option))
- (string? (caddr option)))))
- (cons 'expect:
- (lambda (option)
- (and (list? option)
- (= (length option) 2)
- (integer? (cadr option))
- (>= (cadr option) 0))))
-
- (cons 'driver:
- (lambda (option)
- (and (list? option)
- (= (length option) 2)
- (symbol? (cadr option))
- (memq (cadr option) '(lr glr)))))))
-
-
- (define (validate-options options)
- (for-each
- (lambda (option)
- (let ((p (assoc (car option) *valid-options*)))
- (if (or (not p)
- (not ((cdr p) option)))
- (lalr-error "Invalid option:" option))))
- options))
-
-
- (define (output-parser! options code)
- (let ((option (assq 'output: options)))
- (if option
- (let ((parser-name (cadr option))
- (file-name (caddr option)))
- (with-output-to-file file-name
- (lambda ()
- (pprint `(define ,parser-name ,code))
- (newline)))))))
-
-
- (define (output-table! options)
- (let ((option (assq 'out-table: options)))
- (if option
- (let ((file-name (cadr option)))
- (with-output-to-file file-name print-states)))))
-
-
- (define (set-expected-conflicts! options)
- (let ((option (assq 'expect: options)))
- (set! expected-conflicts (if option (cadr option) 0))))
-
- (define (set-driver-name! options)
- (let ((option (assq 'driver: options)))
- (if option
- (let ((driver-type (cadr option)))
- (set! driver-name (if (eq? driver-type 'glr) 'glr-driver 'lr-driver))))))
-
-
- ;; -- arguments
-
- (define (extract-arguments lst proc)
- (let loop ((options '())
- (tokens '())
- (rules '())
- (lst lst))
- (if (pair? lst)
- (let ((p (car lst)))
- (cond
- ((and (pair? p)
- (lalr-keyword? (car p))
- (assq (car p) *valid-options*))
- (loop (cons p options) tokens rules (cdr lst)))
- (else
- (proc options p (cdr lst)))))
- (lalr-error "Malformed lalr-parser form" lst))))
-
-
- (define (build-driver options tokens rules)
- (validate-options options)
- (set-expected-conflicts! options)
- (set-driver-name! options)
- (let* ((gram/actions (gen-tables! tokens rules))
- (code `(,driver-name ',action-table ,(build-goto-table) ,(build-reduction-table gram/actions))))
-
- (output-table! options)
- (output-parser! options code)
- code))
-
- (extract-arguments arguments build-driver))
-
-
-
-;;;
-;;;; --
-;;;; Implementation of the lr-driver
-;;;
-
-
-(cond-expand
- (gambit
- (declare
- (standard-bindings)
- (fixnum)
- (block)
- (not safe)))
- (chicken
- (declare
- (uses extras)
- (usual-integrations)
- (fixnum)
- (not safe)))
- (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))))))
-
+;;; -*-scheme-*-
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;;; LR-driver
+;;; This file is part of Mes.
;;;
-
-
-(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)))
-
-
+;;; 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.
;;;
-;;;; Simple-minded GLR-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 <http://www.gnu.org/licenses/>.
+;;; Commentary:
-(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)))
+;;; lalr
-(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))
--- /dev/null
+;;;
+;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
+;;;
+;; Copyright 2014 Jan Nieuwenhuizen <janneke@gnu.org>
+;; Copyright 1993, 2010 Dominique Boucher
+;;
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation, either version 3 of
+;; the License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+
+(define *lalr-scm-version* "2.5.0")
+
+(cond-expand
+
+ ;; -- Gambit-C
+ (gambit
+
+ (display "Gambit-C!")
+ (newline)
+
+ (define-macro (def-macro form . body)
+ `(define-macro ,form (let () ,@body)))
+
+ (def-macro (BITS-PER-WORD) 28)
+ (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
+ (def-macro (lalr-error msg obj) `(error ,msg ,obj))
+
+ (define pprint pretty-print)
+ (define lalr-keyword? keyword?)
+ (define (note-source-location lvalue tok) lvalue))
+
+ ;; --
+ (bigloo
+ (define-macro (def-macro form . body)
+ `(define-macro ,form (let () ,@body)))
+
+ (define pprint (lambda (obj) (write obj) (newline)))
+ (define lalr-keyword? keyword?)
+ (def-macro (BITS-PER-WORD) 29)
+ (def-macro (logical-or x . y) `(bit-or ,x ,@y))
+ (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))
+ (define (note-source-location lvalue tok) lvalue))
+
+ ;; -- Chicken
+ (chicken
+
+ (define-macro (def-macro form . body)
+ `(define-macro ,form (let () ,@body)))
+
+ (define pprint pretty-print)
+ (define lalr-keyword? symbol?)
+ (def-macro (BITS-PER-WORD) 30)
+ (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y))
+ (def-macro (lalr-error msg obj) `(error ,msg ,obj))
+ (define (note-source-location lvalue tok) lvalue))
+
+ ;; -- STKlos
+ (stklos
+ (require "pp")
+
+ (define (pprint form) (pp form :port (current-output-port)))
+
+ (define lalr-keyword? keyword?)
+ (define-macro (BITS-PER-WORD) 30)
+ (define-macro (logical-or x . y) `(bit-or ,x ,@y))
+ (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj))
+ (define (note-source-location lvalue tok) lvalue))
+
+ ;; -- Guile
+ (guile
+ (use-modules (ice-9 pretty-print))
+ (use-modules (srfi srfi-9))
+
+ (define pprint pretty-print)
+ (define lalr-keyword? symbol?)
+ (define-macro (BITS-PER-WORD) 30)
+ (define-macro (logical-or x . y) `(logior ,x ,@y))
+ (define-macro (lalr-error msg obj) `(error ,msg ,obj))
+ (define (note-source-location lvalue tok)
+ (if (and (supports-source-properties? lvalue)
+ (not (source-property lvalue 'loc))
+ (lexical-token? tok))
+ (set-source-property! lvalue 'loc (lexical-token-source tok)))
+ lvalue))
+
+ ;; -- Mes
+ (mes
+ (define pprint display)
+ (define lalr-keyword? symbol?)
+ (define-macro (BITS-PER-WORD) 30)
+ (define-macro (logical-or x . y) `(logior ,x ,@y))
+ (define-macro (lalr-error msg obj) `(error ,msg ,obj))
+ (define (note-source-location lvalue tok) lvalue)
+ (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)))
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
+;;; 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)))
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
-;;; 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 <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; portable matcher
+
+(mes-use-module (mes syntax))
+(mes-use-module (mes match.upstream))
--- /dev/null
+;;; 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)))))
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
--- /dev/null
+;;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
+
+(mes-use-module (mes psyntax-0))
+(mes-use-module (mes psyntax-pp))
+(mes-use-module (mes psyntax-1))
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; You should have received a copy of the GNU General Public License
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
-(define-macro (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))))))
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; Code:
+(mes-use-module (mes scm))
+
(define welcome
"Mes 0.2
Copyright (C) 2016 Jan Nieuwenhuizen <janneke@gnu.org>
,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
(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)))))
(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))))))))))))
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; Code:
+(mes-use-module (mes let))
+
(define (cadddr x) (car (cdddr x)))
(define (list . rest) rest)
;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
-;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; 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))
(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 ()
--- /dev/null
+;; -*-scheme-*-
+
+;;; Mes --- Maxwell Equations of Software
+;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;
+;;; This file is part of Mes.
+;;;
+;;; Mes is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; Mes is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; 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))))
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; Code:
+(mes-use-module (mes base))
(define guile? (not (pair? (current-module))))
(define result
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
(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)))
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
-;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
-;;; 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
;;; 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.
-
-; The
projects / mes.git / commitdiff