artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

let-syntax.mes: implement.

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-10-10 22:55:37 +02:00
parent a265f933d8
commit d3fab554d5
5 changed files with 173 additions and 85 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
GNUmakefile
View file

@ -1,5 +1,6 @@
.PHONY: all check default .PHONY: all check default
CFLAGS:=-std=c99 -O3 -finline-functions CFLAGS:=-std=c99 -O3 -finline-functions
#CFLAGS:=-pg -std=c99 -O3 -finline-functions
#CFLAGS:=-std=c99 -g #CFLAGS:=-std=c99 -g
default: all 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 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/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 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-check:
guile -s <(cat base.mes lib/test.mes test/base.test) guile -s <(cat base.mes lib/test.mes test/base.test)
@ -115,7 +117,7 @@ guile-paren: paren.test
echo '___P((()))' | guile -s $^ echo '___P((()))' | guile -s $^
mescc: all 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 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 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 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 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 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 $^

29
let-syntax.mes Normal file
View file

@ -0,0 +1,29 @@
;;; -*-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)))

2
let.mes
View file

@ -3,7 +3,7 @@
;;; Mes --- Maxwell Equations of Software ;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; 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 ;;; Mes is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by ;;; under the terms of the GNU General Public License as published by

163
syntax.mes
View file

@ -42,8 +42,8 @@
(define-macro (define-syntax macro-name transformer . stuff) (define-macro (define-syntax macro-name transformer . stuff)
`(define-macro (,macro-name . args) `(define-macro (,macro-name . args)
(,transformer (cons ',macro-name args) (,transformer (cons ',macro-name args)
(lambda (x) x) (lambda (x0) x0)
eq?))) eq?)))
;; Rewrite-rule compiler (a.k.a. "extend-syntax") ;; Rewrite-rule compiler (a.k.a. "extend-syntax")
@ -57,21 +57,21 @@
;; (if temp temp (or e ...)))))) ;; (if temp temp (or e ...))))))
(define-syntax syntax-rules (define-syntax syntax-rules
(let () (let ()
(define name? symbol?) (define name? symbol?)
(define (segment-pattern? pattern) (define (segment-pattern? pattern)
(and (segment-template? pattern) (and (segment-template? pattern)
(or (null? (cddr pattern)) (or (null? (cddr pattern))
(syntax-error "segment matching not implemented" pattern)))) (syntax-error "segment matching not implemented" pattern))))
(define (segment-template? pattern) (define (segment-template? pattern)
(and (pair? pattern) (and (pair? pattern)
(pair? (cdr pattern)) (pair? (cdr pattern))
(memq (cadr pattern) indicators-for-zero-or-more))) (memq (cadr pattern) indicators-for-zero-or-more)))
(define indicators-for-zero-or-more (list (string->symbol "...") '---)) (define indicators-for-zero-or-more (list (string->symbol "...") '---))
(lambda (exp r c) (lambda (exp r c)
(define %input (r '%input)) ;Gensym these, if you like. (define %input (r '%input)) ;Gensym these, if you like.
@ -84,36 +84,36 @@
(define subkeywords (cadr exp)) (define subkeywords (cadr exp))
(define (make-transformer rules) (define (make-transformer rules)
`(lambda (,%input ,%rename ,%compare) `(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input))) (let ((,%tail (cdr ,%input)))
(cond ,@(map process-rule rules) (cond ,@(map process-rule rules)
(else (else
(syntax-error (syntax-error
"use of macro doesn't match definition" "use of macro doesn't match definition"
,%input)))))) ,%input))))))
(define (process-rule rule) (define (process-rule rule)
(cond ((and (pair? rule) (if (and (pair? rule)
(pair? (cdr rule)) (pair? (cdr rule))
(null? (cddr rule))) (null? (cddr rule)))
(let ((pattern (cdar rule)) (let ((pattern (cdar rule))
(template (cadr rule))) (template (cadr rule)))
`((and ,@(process-match %tail pattern)) `((and ,@(process-match %tail pattern))
(let* ,(process-pattern pattern (let* ,(process-pattern pattern
%tail %tail
(lambda (x) x)) (lambda (x) x))
,(process-template template ,(process-template template
0 0
(meta-variables pattern 0 '())))))) (meta-variables pattern 0 '())))))
(syntax-error "ill-formed syntax rule" rule))) (syntax-error "ill-formed syntax rule" rule)))
;; Generate code to test whether input expression matches pattern ;; Generate code to test whether input expression matches pattern
(define (process-match input pattern) (define (process-match input pattern)
(cond ((name? pattern) (cond ((name? pattern)
(cond ((member pattern subkeywords) (if (member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern)))) `((,%compare ,input (,%rename ',pattern)))
(#t `()))) `()))
((segment-pattern? pattern) ((segment-pattern? pattern)
(process-segment-match input (car pattern))) (process-segment-match input (car pattern)))
((pair? pattern) ((pair? pattern)
@ -125,35 +125,33 @@
`((eq? ,input ',pattern))) `((eq? ,input ',pattern)))
(else (else
`((equal? ,input ',pattern))))) `((equal? ,input ',pattern)))))
(define (process-segment-match input pattern) (define (process-segment-match input pattern)
(let ((conjuncts (process-match '(car l) pattern))) (let ((conjuncts (process-match '(car l) pattern)))
(cond ((null? conjuncts) (if (null? conjuncts)
`((list? ,input))) ;+++ `((list? ,input)) ;+++
(#t `((let loop ((l ,input)) `((let loop ((l ,input))
(or (null? l) (or (null? l)
(and (pair? l) (and (pair? l)
,@conjuncts ,@conjuncts
(loop (cdr l)))))))))) (loop (cdr l)))))))))
;; Generate code to take apart the input expression ;; Generate code to take apart the input expression
;; This is pretty bad, but it seems to work (can't say why). ;; This is pretty bad, but it seems to work (can't say why).
(define (process-pattern pattern path mapit) (define (process-pattern pattern path mapit)
(cond ((name? pattern) (cond ((name? pattern)
(cond ((memq pattern subkeywords) (if (memq pattern subkeywords)
'()) '()
(#t (list (list pattern (mapit path)))))
(list (list pattern (mapit path))))))
((segment-pattern? pattern) ((segment-pattern? pattern)
(process-pattern (car pattern) (process-pattern (car pattern)
%temp %temp
(lambda (x) ;temp is free in x (lambda (x) ;temp is free in x
(mapit (cond ((eq? %temp x) (mapit (if (eq? %temp x)
path) ;+++ path ;+++
(#t `(map (lambda (,%temp) ,x)
`(map (lambda (,%temp) ,x) ,path))))))
,path)))))))
((pair? pattern) ((pair? pattern)
(append (process-pattern (car pattern) `(car ,path) mapit) (append (process-pattern (car pattern) `(car ,path) mapit)
(process-pattern (cdr pattern) `(cdr ,path) mapit))) (process-pattern (cdr pattern) `(cdr ,path) mapit)))
@ -164,29 +162,28 @@
(define (process-template template rank env) (define (process-template template rank env)
(cond ((name? template) (cond ((name? template)
(let ((probe (assq template env))) (let ((probe (assq template env)))
(cond (probe (if probe
(cond ((<= (cdr probe) rank) (if (<= (cdr probe) rank)
template) template
(#t (syntax-error "template rank error (too few ...'s?)" (syntax-error "template rank error (too few ...'s?)"
template)))) template))
(#t `(,%rename ',template))))) `(,%rename ',template))))
((segment-template? template) ((segment-template? template)
(let ((vars (let ((vars
(free-meta-variables (car template) (+ rank 1) env '()))) (free-meta-variables (car template) (+ rank 1) env '())))
(cond ((null? vars) (if (null? vars)
(syntax-error "too many ...'s" template)) (syntax-error "too many ...'s" template)
(#t (let* ((x (process-template (car template) (let* ((x (process-template (car template)
(+ rank 1) (+ rank 1)
env)) env))
(gen (cond ((equal? (list x) vars) (gen (if (equal? (list x) vars)
x) ;+++ x ;+++
(#t `(map (lambda ,vars ,x) `(map (lambda ,vars ,x)
,@vars))))) ,@vars))))
(cond ((null? (cddr template)) (if (null? (cddr template))
gen) ;+++ gen ;+++
(else `(append ,gen ,(process-template (cddr template)
`(append ,gen ,(process-template (cddr template) rank env)))))))
rank env)))))))))
((pair? template) ((pair? template)
`(cons ,(process-template (car template) rank env) `(cons ,(process-template (car template) rank env)
,(process-template (cdr template) rank env))) ,(process-template (cdr template) rank env)))
@ -196,9 +193,9 @@
(define (meta-variables pattern rank vars) (define (meta-variables pattern rank vars)
(cond ((name? pattern) (cond ((name? pattern)
(cond ((memq pattern subkeywords) (if (memq pattern subkeywords)
vars) vars
(else (cons (cons pattern rank) vars)))) (cons (cons pattern rank) vars)))
((segment-pattern? pattern) ((segment-pattern? pattern)
(meta-variables (car pattern) (+ rank 1) vars)) (meta-variables (car pattern) (+ rank 1) vars))
((pair? pattern) ((pair? pattern)
@ -210,11 +207,11 @@
(define (free-meta-variables template rank env free) (define (free-meta-variables template rank env free)
(cond ((name? template) (cond ((name? template)
(cond ((and (not (memq template free)) (if (and (not (memq template free))
(let ((probe (assq template env))) (let ((probe (assq template env)))
(and probe (>= (cdr probe) rank)))) (and probe (>= (cdr probe) rank))))
(cons template free)) (cons template free)
(else free))) free))
((segment-template? template) ((segment-template? template)
(free-meta-variables (car template) (free-meta-variables (car template)
rank env rank env

51
test/let-syntax.test Normal file
View file

@ -0,0 +1,51 @@
;;; -*-scheme-*-
;;; Mes --- Maxwell Equations of Software
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.
(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)