diff --git a/GNUmakefile b/GNUmakefile index f88f4ec1..f0335e0e 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,5 +1,6 @@ .PHONY: all check default CFLAGS:=-std=c99 -O3 -finline-functions +#CFLAGS:=-pg -std=c99 -O3 -finline-functions #CFLAGS:=-std=c99 -g default: all @@ -44,6 +45,7 @@ mes-check: all 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 scm.mes syntax.mes let-syntax.mes lib/srfi/srfi-0.scm lib/test.mes test/let-syntax.test | ./mes guile-check: guile -s <(cat base.mes lib/test.mes test/base.test) @@ -115,7 +117,7 @@ guile-paren: paren.test echo '___P((()))' | guile -s $^ mescc: all - echo ' EOF ' | 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 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 + 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 mescc.test: lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm lib/elf.mes c-lexer.scm mescc.scm @@ -135,3 +137,12 @@ hello: hello.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 chmod +x a.out + +match: 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 match.mes | ./mes + +match.test: lib/lalr.scm lib/rnrs/bytevectors.scm lib/srfi/srfi-1.scm lib/match.scm match.mes + cat $^ > $@ + +guile-match: match.test + guile -s $^ diff --git a/let-syntax.mes b/let-syntax.mes new file mode 100644 index 00000000..cda9a70c --- /dev/null +++ b/let-syntax.mes @@ -0,0 +1,29 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; 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 . + +(define-macro (let-syntax bindings . rest) + `((lambda () + ,@(map (lambda (binding) + `(define-macro (,(car binding) . args) + (,(cadr binding) (cons ',(car binding) args) + (lambda (x0) x0) + eq?))) + bindings) + ,@rest))) diff --git a/let.mes b/let.mes index fc34e9f0..d87b2be4 100644 --- a/let.mes +++ b/let.mes @@ -3,7 +3,7 @@ ;;; Mes --- Maxwell Equations of Software ;;; Copyright © 2016 Jan Nieuwenhuizen ;;; -;;; test.mes: This file is part of Mes. +;;; 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 diff --git a/syntax.mes b/syntax.mes index 3baa811a..134aa394 100644 --- a/syntax.mes +++ b/syntax.mes @@ -42,8 +42,8 @@ (define-macro (define-syntax macro-name transformer . stuff) `(define-macro (,macro-name . args) (,transformer (cons ',macro-name args) - (lambda (x) x) - eq?))) + (lambda (x0) x0) + eq?))) ;; Rewrite-rule compiler (a.k.a. "extend-syntax") @@ -57,21 +57,21 @@ ;; (if temp temp (or e ...)))))) (define-syntax syntax-rules - (let () - (define name? symbol?) + (let () + (define name? symbol?) - (define (segment-pattern? pattern) - (and (segment-template? pattern) - (or (null? (cddr pattern)) - (syntax-error "segment matching not implemented" pattern)))) - - (define (segment-template? pattern) - (and (pair? pattern) - (pair? (cdr pattern)) - (memq (cadr pattern) indicators-for-zero-or-more))) - - (define indicators-for-zero-or-more (list (string->symbol "...") '---)) - + (define (segment-pattern? pattern) + (and (segment-template? pattern) + (or (null? (cddr pattern)) + (syntax-error "segment matching not implemented" pattern)))) + + (define (segment-template? pattern) + (and (pair? pattern) + (pair? (cdr pattern)) + (memq (cadr pattern) indicators-for-zero-or-more))) + + (define indicators-for-zero-or-more (list (string->symbol "...") '---)) + (lambda (exp r c) (define %input (r '%input)) ;Gensym these, if you like. @@ -84,36 +84,36 @@ (define subkeywords (cadr exp)) (define (make-transformer rules) - `(lambda (,%input ,%rename ,%compare) + `(lambda (,%input ,%rename ,%compare) (let ((,%tail (cdr ,%input))) - (cond ,@(map process-rule rules) + (cond ,@(map process-rule rules) (else (syntax-error "use of macro doesn't match definition" ,%input)))))) (define (process-rule rule) - (cond ((and (pair? rule) - (pair? (cdr rule)) - (null? (cddr rule))) - (let ((pattern (cdar rule)) - (template (cadr rule))) - `((and ,@(process-match %tail pattern)) - (let* ,(process-pattern pattern - %tail - (lambda (x) x)) - ,(process-template template - 0 - (meta-variables pattern 0 '())))))) - (syntax-error "ill-formed syntax rule" rule))) - + (if (and (pair? rule) + (pair? (cdr rule)) + (null? (cddr rule))) + (let ((pattern (cdar rule)) + (template (cadr rule))) + `((and ,@(process-match %tail pattern)) + (let* ,(process-pattern pattern + %tail + (lambda (x) x)) + ,(process-template template + 0 + (meta-variables pattern 0 '()))))) + (syntax-error "ill-formed syntax rule" rule))) + ;; Generate code to test whether input expression matches pattern (define (process-match input pattern) - (cond ((name? pattern) - (cond ((member pattern subkeywords) - `((,%compare ,input (,%rename ',pattern)))) - (#t `()))) + (cond ((name? pattern) + (if (member pattern subkeywords) + `((,%compare ,input (,%rename ',pattern))) + `())) ((segment-pattern? pattern) (process-segment-match input (car pattern))) ((pair? pattern) @@ -125,35 +125,33 @@ `((eq? ,input ',pattern))) (else `((equal? ,input ',pattern))))) - + (define (process-segment-match input pattern) (let ((conjuncts (process-match '(car l) pattern))) - (cond ((null? conjuncts) - `((list? ,input))) ;+++ - (#t `((let loop ((l ,input)) - (or (null? l) - (and (pair? l) - ,@conjuncts - (loop (cdr l)))))))))) - + (if (null? conjuncts) + `((list? ,input)) ;+++ + `((let loop ((l ,input)) + (or (null? l) + (and (pair? l) + ,@conjuncts + (loop (cdr l))))))))) + ;; Generate code to take apart the input expression ;; This is pretty bad, but it seems to work (can't say why). (define (process-pattern pattern path mapit) (cond ((name? pattern) - (cond ((memq pattern subkeywords) - '()) - (#t - (list (list pattern (mapit path)))))) + (if (memq pattern subkeywords) + '() + (list (list pattern (mapit path))))) ((segment-pattern? pattern) (process-pattern (car pattern) %temp - (lambda (x) ;temp is free in x - (mapit (cond ((eq? %temp x) - path) ;+++ - (#t - `(map (lambda (,%temp) ,x) - ,path))))))) + (lambda (x) ;temp is free in x + (mapit (if (eq? %temp x) + path ;+++ + `(map (lambda (,%temp) ,x) + ,path)))))) ((pair? pattern) (append (process-pattern (car pattern) `(car ,path) mapit) (process-pattern (cdr pattern) `(cdr ,path) mapit))) @@ -164,29 +162,28 @@ (define (process-template template rank env) (cond ((name? template) (let ((probe (assq template env))) - (cond (probe - (cond ((<= (cdr probe) rank) - template) - (#t (syntax-error "template rank error (too few ...'s?)" - template)))) - (#t `(,%rename ',template))))) + (if probe + (if (<= (cdr probe) rank) + template + (syntax-error "template rank error (too few ...'s?)" + template)) + `(,%rename ',template)))) ((segment-template? template) (let ((vars (free-meta-variables (car template) (+ rank 1) env '()))) - (cond ((null? vars) - (syntax-error "too many ...'s" template)) - (#t (let* ((x (process-template (car template) - (+ rank 1) - env)) - (gen (cond ((equal? (list x) vars) - x) ;+++ - (#t `(map (lambda ,vars ,x) - ,@vars))))) - (cond ((null? (cddr template)) - gen) ;+++ - (else - `(append ,gen ,(process-template (cddr template) - rank env))))))))) + (if (null? vars) + (syntax-error "too many ...'s" template) + (let* ((x (process-template (car template) + (+ rank 1) + env)) + (gen (if (equal? (list x) vars) + x ;+++ + `(map (lambda ,vars ,x) + ,@vars)))) + (if (null? (cddr template)) + gen ;+++ + `(append ,gen ,(process-template (cddr template) + rank env))))))) ((pair? template) `(cons ,(process-template (car template) rank env) ,(process-template (cdr template) rank env))) @@ -196,9 +193,9 @@ (define (meta-variables pattern rank vars) (cond ((name? pattern) - (cond ((memq pattern subkeywords) - vars) - (else (cons (cons pattern rank) vars)))) + (if (memq pattern subkeywords) + vars + (cons (cons pattern rank) vars))) ((segment-pattern? pattern) (meta-variables (car pattern) (+ rank 1) vars)) ((pair? pattern) @@ -210,11 +207,11 @@ (define (free-meta-variables template rank env free) (cond ((name? template) - (cond ((and (not (memq template free)) - (let ((probe (assq template env))) - (and probe (>= (cdr probe) rank)))) - (cons template free)) - (else free))) + (if (and (not (memq template free)) + (let ((probe (assq template env))) + (and probe (>= (cdr probe) rank)))) + (cons template free) + free)) ((segment-template? template) (free-meta-variables (car template) rank env diff --git a/test/let-syntax.test b/test/let-syntax.test new file mode 100644 index 00000000..0a12765f --- /dev/null +++ b/test/let-syntax.test @@ -0,0 +1,51 @@ +;;; -*-scheme-*- + +;;; Mes --- Maxwell Equations of Software +;;; Copyright © 2016 Jan Nieuwenhuizen +;;; +;;; let-syntax.test: 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 . + +(pass-if "first dummy" #t) +(pass-if-not "second dummy" #f) + +(pass-if "let-syntax" + (seq? + (let-syntax ((when (syntax-rules () + ((when condition exp ...) + (if (not condition) + (begin exp ...)))))) + (when #f 3)) + 3)) + +(pass-if "let-syntax no-leak" + (seq? + (when #f 3) + *unspecified*)) + +(pass-if "let-syntax" + (sequal? + (let-syntax ((when (syntax-rules () + ((when condition exp ...) + (if (not condition) + (begin exp ...))))) + (unless (syntax-rules () + ((when condition exp ...) + (if condition + (begin exp ...)))))) + (list (when #f 0) (unless #t 1))) + '(0 1))) + +(result 'report)