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