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
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 $^

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
;;; 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
;;; under the terms of the GNU General Public License as published by

151
syntax.mes
View file

@ -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,20 +57,20 @@
;; (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-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 (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 indicators-for-zero-or-more (list (string->symbol "...") '---))
(lambda (exp r c)
@ -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)
@ -128,32 +128,30 @@
(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

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)