syntax-if.mes: TODO.
This commit is contained in:
Jan Nieuwenhuizen
parent
287c0284fe
commit
ef874c8fd3
16
GNUmakefile
16
GNUmakefile
|
|
@ -70,18 +70,18 @@ psyntax: all
|
|||
cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes psyntax.mes psyntax.pp psyntax2.mes | ./mes
|
||||
|
||||
syntax: all
|
||||
cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax.mes syntax-test.mes | ./mes
|
||||
cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax-cond.mes syntax-test.mes | ./mes
|
||||
|
||||
syntax.test: syntax.mes syntax-test.mes
|
||||
syntax.test: syntax-cond.mes syntax-test.mes
|
||||
cat $^ > $@
|
||||
|
||||
guile-syntax: syntax.test
|
||||
guile -s $^
|
||||
|
||||
syntax-case: all
|
||||
cat scm.mes syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
|
||||
cat scm.mes syntax-cond.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes | ./mes
|
||||
|
||||
syntax-case.test: syntax.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
|
||||
syntax-case.test: syntax-cond.mes syntax-case-lib.mes syntax-case.mes syntax-case-after.mes syntax-case-test.mes
|
||||
cat $^ > $@
|
||||
|
||||
guile-syntax-case: syntax-case.test
|
||||
|
|
@ -91,7 +91,7 @@ macro: all
|
|||
cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes macro.mes | ./mes
|
||||
|
||||
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
|
||||
cat scm.mes syntax-cond.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.test: 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,' > $@
|
||||
|
|
@ -105,11 +105,11 @@ clean:
|
|||
rm -f mes environment.i mes.h peg.test syntax.test
|
||||
|
||||
record: all
|
||||
cat scm.mes syntax.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
|
||||
cat scm.mes syntax-cond.mes lib/record.mes lib/record.scm lib/srfi/srfi-9.scm record.mes |./mes
|
||||
|
||||
|
||||
paren: all
|
||||
echo -e 'EOF\n___P((()))' | cat base0.mes base0-$(CONDIF).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
|
||||
echo -e 'EOF\n___P((()))' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax-cond.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.test: lib/lalr.scm paren.scm
|
||||
cat $^ > $@
|
||||
|
|
@ -118,7 +118,7 @@ guile-paren: paren.test
|
|||
echo '___P((()))' | guile -s $^
|
||||
|
||||
mescc: all
|
||||
echo ' EOF ' | cat base0.mes base0-$(CONDIF).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 c-lexer.scm mescc.scm - main.c | ./mes
|
||||
echo ' EOF ' | cat base0.mes base0-$(CONDIF).mes base.mes quasiquote.mes let.mes scm.mes syntax-cond.mes lib/srfi/srfi-0.scm lib/record.mes lib/record.scm lib/srfi/srfi-9.scm lib/lalr.mes lib/lalr.scm c-lexer.scm mescc.scm - main.c | ./mes
|
||||
|
||||
mescc.test: lib/lalr.scm c-lexer.scm mescc.scm
|
||||
cat $^ > $@
|
||||
|
|
|
|||
|
|
@ -0,0 +1,238 @@
|
|||
;; -*-scheme-*-
|
||||
|
||||
(define (syntax-error message thing)
|
||||
(display "syntax-error:")
|
||||
(display message)
|
||||
(display ":")
|
||||
(display thing)
|
||||
(newline))
|
||||
|
||||
;;; Adapted from scheme48-1.1/scheme/alt/syntax.scm
|
||||
|
||||
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
;;; scheme48-1.1/COPYING
|
||||
|
||||
;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
|
||||
;; All rights reserved.
|
||||
|
||||
;; Redistribution and use in source and binary forms, with or without
|
||||
;; modification, are permitted provided that the following conditions
|
||||
;; are met:
|
||||
;; 1. Redistributions of source code must retain the above copyright
|
||||
;; notice, this list of conditions and the following disclaimer.
|
||||
;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;; notice, this list of conditions and the following disclaimer in the
|
||||
;; documentation and/or other materials provided with the distribution.
|
||||
;; 3. The name of the authors may not be used to endorse or promote products
|
||||
;; derived from this software without specific prior written permission.
|
||||
|
||||
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
|
||||
(define-macro (define-syntax macro-name transformer . stuff)
|
||||
`(define-macro (,macro-name . args)
|
||||
(,transformer (cons ',macro-name args)
|
||||
(lambda (x) x)
|
||||
eq?)))
|
||||
|
||||
;; Rewrite-rule compiler (a.k.a. "extend-syntax")
|
||||
|
||||
;; Example:
|
||||
;;
|
||||
;; (define-syntax or
|
||||
;; (syntax-rules ()
|
||||
;; ((or) #f)
|
||||
;; ((or e) e)
|
||||
;; ((or e1 e ...) (let ((temp e1))
|
||||
;; (if temp temp (or e ...))))))
|
||||
|
||||
(define-syntax syntax-rules
|
||||
(let ()
|
||||
(define name? symbol?)
|
||||
|
||||
(define (segment-pattern? pattern)
|
||||
(and (segment-template? pattern)
|
||||
(or (null? (cddr pattern))
|
||||
(syntax-error "segment matching not implemented" pattern))))
|
||||
|
||||
(define (segment-template? pattern)
|
||||
(and (pair? pattern)
|
||||
(pair? (cdr pattern))
|
||||
(memq (cadr pattern) indicators-for-zero-or-more)))
|
||||
|
||||
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
|
||||
|
||||
(lambda (exp r c)
|
||||
|
||||
(define %input (r '%input)) ;Gensym these, if you like.
|
||||
(define %compare (r '%compare))
|
||||
(define %rename (r '%rename))
|
||||
(define %tail (r '%tail))
|
||||
(define %temp (r '%temp))
|
||||
|
||||
(define rules (cddr exp))
|
||||
(define subkeywords (cadr exp))
|
||||
|
||||
(define (make-transformer rules)
|
||||
`(lambda (,%input ,%rename ,%compare)
|
||||
(let ((,%tail (cdr ,%input)))
|
||||
(cond ,@(map process-rule rules)
|
||||
(else
|
||||
(syntax-error
|
||||
"use of macro doesn't match definition"
|
||||
,%input))))))
|
||||
|
||||
(define (process-rule rule)
|
||||
(if (and (pair? rule)
|
||||
(pair? (cdr rule))
|
||||
(null? (cddr rule)))
|
||||
(let ((pattern (cdar rule))
|
||||
(template (cadr rule)))
|
||||
`((and ,@(process-match %tail pattern))
|
||||
(let* ,(process-pattern pattern
|
||||
%tail
|
||||
(lambda (x) x))
|
||||
,(process-template template
|
||||
0
|
||||
(meta-variables pattern 0 '())))))
|
||||
(syntax-error "ill-formed syntax rule" rule)))
|
||||
|
||||
;; Generate code to test whether input expression matches pattern
|
||||
|
||||
(define (process-match input pattern)
|
||||
(cond ((name? pattern)
|
||||
(if (member pattern subkeywords)
|
||||
`((,%compare ,input (,%rename ',pattern)))
|
||||
`()))
|
||||
((segment-pattern? pattern)
|
||||
(process-segment-match input (car pattern)))
|
||||
((pair? pattern)
|
||||
`((let ((,%temp ,input))
|
||||
(and (pair? ,%temp)
|
||||
,@(process-match `(car ,%temp) (car pattern))
|
||||
,@(process-match `(cdr ,%temp) (cdr pattern))))))
|
||||
((or (null? pattern) (boolean? pattern) (char? pattern))
|
||||
`((eq? ,input ',pattern)))
|
||||
(else
|
||||
`((equal? ,input ',pattern)))))
|
||||
|
||||
(define (process-segment-match input pattern)
|
||||
(let ((conjuncts (process-match '(car l) pattern)))
|
||||
(if (null? conjuncts)
|
||||
`((list? ,input)) ;+++
|
||||
`((let loop ((l ,input))
|
||||
(or (null? l)
|
||||
(and (pair? l)
|
||||
,@conjuncts
|
||||
(loop (cdr l)))))))))
|
||||
|
||||
;; Generate code to take apart the input expression
|
||||
;; This is pretty bad, but it seems to work (can't say why).
|
||||
|
||||
(define (process-pattern pattern path mapit)
|
||||
(cond ((name? pattern)
|
||||
(if (memq pattern subkeywords)
|
||||
'()
|
||||
(list (list pattern (mapit path)))))
|
||||
((segment-pattern? pattern)
|
||||
(process-pattern (car pattern)
|
||||
%temp
|
||||
(lambda (x) ;temp is free in x
|
||||
(mapit (if (eq? %temp x)
|
||||
path ;+++
|
||||
`(map (lambda (,%temp) ,x)
|
||||
,path))))))
|
||||
((pair? pattern)
|
||||
(append (process-pattern (car pattern) `(car ,path) mapit)
|
||||
(process-pattern (cdr pattern) `(cdr ,path) mapit)))
|
||||
(else '())))
|
||||
|
||||
;; Generate code to compose the output expression according to template
|
||||
|
||||
(define (process-template template rank env)
|
||||
(cond ((name? template)
|
||||
(let ((probe (assq template env)))
|
||||
(if probe
|
||||
(if (<= (cdr probe) rank)
|
||||
template
|
||||
(syntax-error "template rank error (too few ...'s?)"
|
||||
template))
|
||||
`(,%rename ',template))))
|
||||
((segment-template? template)
|
||||
(let ((vars
|
||||
(free-meta-variables (car template) (+ rank 1) env '())))
|
||||
(if (null? vars)
|
||||
(syntax-error "too many ...'s" template)
|
||||
(let* ((x (process-template (car template)
|
||||
(+ rank 1)
|
||||
env))
|
||||
(gen (if (equal? (list x) vars)
|
||||
x ;+++
|
||||
`(map (lambda ,vars ,x)
|
||||
,@vars))))
|
||||
(if (null? (cddr template))
|
||||
gen ;+++
|
||||
`(append ,gen ,(process-template (cddr template)
|
||||
rank env)))))))
|
||||
((pair? template)
|
||||
`(cons ,(process-template (car template) rank env)
|
||||
,(process-template (cdr template) rank env)))
|
||||
(else `(quote ,template))))
|
||||
|
||||
;; Return an association list of (var . rank)
|
||||
|
||||
(define (meta-variables pattern rank vars)
|
||||
(cond ((name? pattern)
|
||||
(if (memq pattern subkeywords)
|
||||
vars
|
||||
(cons (cons pattern rank) vars)))
|
||||
((segment-pattern? pattern)
|
||||
(meta-variables (car pattern) (+ rank 1) vars))
|
||||
((pair? pattern)
|
||||
(meta-variables (car pattern) rank
|
||||
(meta-variables (cdr pattern) rank vars)))
|
||||
(else vars)))
|
||||
|
||||
;; Return a list of meta-variables of given higher rank
|
||||
|
||||
(define (free-meta-variables template rank env free)
|
||||
(cond ((name? template)
|
||||
(if (and (not (memq template free))
|
||||
(let ((probe (assq template env)))
|
||||
(and probe (>= (cdr probe) rank))))
|
||||
(cons template free)
|
||||
free))
|
||||
((segment-template? template)
|
||||
(free-meta-variables (car template)
|
||||
rank env
|
||||
(free-meta-variables (cddr template)
|
||||
rank env free)))
|
||||
((pair? template)
|
||||
(free-meta-variables (car template)
|
||||
rank env
|
||||
(free-meta-variables (cdr template)
|
||||
rank env free)))
|
||||
(else free)))
|
||||
|
||||
c ;ignored
|
||||
|
||||
;; Kludge for Scheme48 linker.
|
||||
;; `(cons ,(make-transformer rules)
|
||||
;; ',(find-free-names-in-syntax-rules subkeywords rules))
|
||||
|
||||
(make-transformer rules))))
|
||||
|
||||
(define-macro (define-syntax-rule id-pattern . template)
|
||||
`(define-syntax ,(car id-pattern)
|
||||
(syntax-rules ()
|
||||
((,(car id-pattern) . ,(cdr id-pattern)) ,@template))))
|
||||
Loading…
Reference in New Issue