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

define-syntax...

Browse source
This commit is contained in:
Jan Nieuwenhuizen 2016-07-16 21:53:32 +02:00
parent d53ea79a5d
commit 21a5e16a88
1 changed files with 247 additions and 150 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

397
syntax.mes
View file

@ -1,22 +1,100 @@
(define else #t)
(define (syntax-error message thing)
(display "syntax-error:")
(display message)
(display ":")
;;(display thing)
(newline))
(display "define-syntax...") (display "define-syntax...")
(define-macro define-syntax ;;(define (caddr x) (car (cdr (cdr x))))
(lambda (form expander) ;; (define (caddr x)
(expander `(define-macro ,(cadr form) ;; (display "wanna caddr:")
(let ((transformer ,(caddr form))) ;; (display x)
(lambda (form expander) ;; (newline))
(expander (transformer form
(lambda (x) x) ;; (define-macro define-syntax
eq?) ;; (lambda (form expander)
expander)))) ;; (expander `(define-macro ,(cadr form)
expander))) ;; (let ((transformer ,(caddr form)))
;; (lambda (form expander)
;; (expander (transformer form
;; (lambda (x) x)
;; eq?)
;; expander))))
;; expander)))
;; (define (dinges form expander)
;; (display "dinges form:")
;; (display form)
;; (newline)
;; `(define-macro BOO ;;;,(cadr form)
;; (let ((transformer ,(caddr form)))
;; (lambda (form expander)
;; (expander (transformer form
;; (lambda (x) x)
;; eq?)
;; expander)))))
;; (define-macro (define-syntax form expander)
;; `(expander (dinges form expander)
;; expander))
(define-macro (define-syntax macro-name transformer . stuff)
;; (display "define-syntax:")
;; (newline)
;; (display `(define-macro (,macro-name . args)
;; (,transformer (cons ',macro-name args)
;; (lambda (x) x)
;; eq?)))
;; (newline)
`(define-macro (,macro-name . args)
(
,transformer (cons ',macro-name args)
(lambda (x) x)
eq?
)
)
)
;; (define-macro (define-syntax form expander)
;; (expander `(define-macro ,(cadr form)
;; (let ((transformer ,(caddr form)))
;; (lambda (form expander)
;; (expander (transformer form
;; (lambda (x) x)
;; eq?)
;; expander))))
;; expander))
;; (define-macro (define-syntax form expander)
;; (expander `(define-macro ((cadr form) form expander)
;; (let ((transformer (caddr form)))
;; (expander (transformer form
;; (lambda (x) x)
;; eq?)
;; expander)))
;; expander))
(newline) (newline)
(display "define-syntax when...") (display "define-syntax syntax-rules...")
(newline)
;; (define-macro (syntax-rules exp r c))
;; (define-syntax syntax-rules
;; (let ()
;; (lambda (exp r c)
;; (display "hallo")
;; (display "newline"))))
;; (define-syntax syntax-rules
;; (lambda (exp r c)
;; (display "hallo")
;; (display "newline")))
(define-syntax syntax-rules (define-syntax syntax-rules
(let () (let ()
@ -25,16 +103,16 @@
(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.
@ -46,163 +124,179 @@
(define rules (cddr exp)) (define rules (cddr exp))
(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)
(if (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)
(if (member pattern subkeywords) (if (member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern))) `((,%compare ,input (,%rename ',pattern)))
`())) `()))
((segment-pattern? pattern) ((segment-pattern? pattern)
(process-segment-match input (car pattern))) (process-segment-match input (car pattern)))
((pair? pattern) ((pair? pattern)
`((let ((,%temp ,input)) `((let ((,%temp ,input))
(and (pair? ,%temp) (and (pair? ,%temp)
,@(process-match `(car ,%temp) (car pattern)) ,@(process-match `(car ,%temp) (car pattern))
,@(process-match `(cdr ,%temp) (cdr pattern)))))) ,@(process-match `(cdr ,%temp) (cdr pattern))))))
((or (null? pattern) (boolean? pattern) (char? pattern)) ((or (null? pattern) (boolean? pattern) (char? pattern))
`((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)))
(if (null? conjuncts) (if (null? conjuncts)
`((list? ,input)) ;+++ `((list? ,input)) ;+++
`((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)
(if (memq pattern subkeywords) (if (memq pattern subkeywords)
'() '()
(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 (if (eq? %temp x) (mapit (if (eq? %temp x)
path ;+++ path ;+++
`(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)))
(else '()))) (else '())))
; Generate code to compose the output expression according to template ;; Generate code to compose the output expression according to template
(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)))
(if probe (if probe
(if (<= (cdr probe) rank) (if (<= (cdr probe) rank)
template template
(syntax-error "template rank error (too few ...'s?)" (syntax-error "template rank error (too few ...'s?)"
template)) template))
`(,%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 '())))
(if (null? vars) (if (null? vars)
(syntax-error "too many ...'s" template) (syntax-error "too many ...'s" template)
(let* ((x (process-template (car template) (let* ((x (process-template (car template)
(+ rank 1) (+ rank 1)
env)) env))
(gen (if (equal? (list x) vars) (gen (if (equal? (list x) vars)
x ;+++ x ;+++
`(map (lambda ,vars ,x) `(map (lambda ,vars ,x)
,@vars)))) ,@vars))))
(if (null? (cddr template)) (if (null? (cddr template))
gen ;+++ gen ;+++
`(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)))
(else `(quote ,template)))) (else `(quote ,template))))
; Return an association list of (var . rank) ; Return an association list of (var . rank)
(define (meta-variables pattern rank vars) (define (meta-variables pattern rank vars)
(cond ((name? pattern) (cond ((name? pattern)
(if (memq pattern subkeywords) (if (memq pattern subkeywords)
vars vars
(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)
(meta-variables (car pattern) rank (meta-variables (car pattern) rank
(meta-variables (cdr pattern) rank vars))) (meta-variables (cdr pattern) rank vars)))
(else vars))) (else vars)))
; Return a list of meta-variables of given higher rank ; Return a list of meta-variables of given higher rank
(define (free-meta-variables template rank env free) (define (free-meta-variables template rank env free)
(cond ((name? template) (cond ((name? template)
(if (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)
free)) free))
((segment-template? template) ((segment-template? template)
(free-meta-variables (car template) (free-meta-variables (car template)
rank env rank env
(free-meta-variables (cddr template) (free-meta-variables (cddr template)
rank env free))) rank env free)))
((pair? template) ((pair? template)
(free-meta-variables (car template) (free-meta-variables (car template)
rank env rank env
(free-meta-variables (cdr template) (free-meta-variables (cdr template)
rank env free))) rank env free)))
(else free))) (else free)))
c ;ignored ;;c ;ignored
;; Kludge for Scheme48 linker. ;; Kludge for Scheme48 linker.
;; `(cons ,(make-transformer rules) ;; `(cons ,(make-transformer rules)
;; ',(find-free-names-in-syntax-rules subkeywords rules)) ;; ',(find-free-names-in-syntax-rules subkeywords rules))
(make-transformer rules)))) (make-transformer rules))))
;; (define-syntax or
;; (syntax-rules ()
;; ((or) #f)
;; ((or e) e)
;; ((or e1 e ...) (let ((temp e1))
;; (if temp temp (or e ...))))))
;; (define-syntax when ;; (define-syntax xwhen
;; (syntax-rules () ;; (syntax-rules ()
;; ((when condition exp ...) ;; ((when condition exp ...)
;; (if condition ;; (if condition
;; (begin exp ...))))) ;; (begin exp ...)))))
;; (display "define-when: ")
;; (display
;; (define-syntax xwhen
;; (syntax-rules ()
;; ((when condition exp ...)
;; (if condition
;; (begin exp ...))))))
;; (newline)
;; (display (xwhen #t "hello syntax world"))
;; (define-macro (when cond exp . rest) ;; (define-macro (when cond exp . rest)
;; `(if ,cond ;; `(if ,cond
;; (begin ,exp . ,rest))) ;; (begin ,exp . ,rest)))
@ -211,3 +305,6 @@
;; (define-macro (when clause . rest) ;; (define-macro (when clause . rest)
;; (list 'cond (list clause (list 'let '() rest)))) ;; (list 'cond (list clause (list 'let '() rest))))
(newline) (newline)
'boo
EOF
'()