mes/syntax.mes

385 lines
14 KiB
Scheme

;; -*-scheme-*-
;;(define else #t)
(define (syntax-error message thing)
(display "syntax-error:")
(display message)
(display ":")
;;(display thing)
(newline))
(display "mes:define-syntax...")
;;(define (caddr x) (car (cdr (cdr x))))
;; (define (caddr x)
;; (display "wanna caddr:")
;; (display x)
;; (newline))
;; (define-macro mes:define-syntax
;; (lambda (form expander)
;; (expander `(define-macro ,(cadr form)
;; (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 (mes:define-syntax form expander)
;; `(expander (dinges form expander)
;; expander))
(define-macro (mes:define-syntax macro-name transformer . stuff)
;; (display "mes: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 (mes: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 (mes: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)
(display "mes:define-syntax syntax-rules...")
(newline)
(mes:define-syntax syntax-rules
(let ()
;; syntax-rules uses defines that get closured-in
;; mes still has a bug here; move down
;; (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 "...") '---))
(display "BOOO")
(lambda (exp r c)
;; FIXME: mes, moved down
(define name? symbol?)
(define (segment-pattern? pattern)
(display "segment-pattern?: ")
(display pattern)
(newline)
(display "segment-template?: ")
(display (segment-template? pattern))
(newline)
(and (segment-template? pattern)
(or (null? (cddr pattern))
(syntax-error "segment matching not implemented" pattern))))
(define indicators-for-zero-or-more (list (string->symbol "...") '---))
(define (segment-template? pattern)
(and (pair? pattern)
(display "pair?: ")
(display (pair? pattern))
(newline)
(pair? (cdr pattern))
(display "pair? cdr: ")
(display (pair? (cdr pattern)))
(newline)
;; (display "indicators: ")
;; (display indicators-for-zero-or-more)
;; (newline)
(display "cadr pattern: ")
(display (cadr pattern))
(newline)
(display "memq?: ")
;;(memq (cadr pattern) indicators-for-zero-or-more)
(memq (cadr pattern) (list (string->symbol "...") '---))
;;(member (cadr pattern) indicators-for-zero-or-more)
))
;; end FIXME
(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)
(display "make-transformer") (newline)
`(lambda (,%input ,%rename ,%compare)
(let ((,%tail (cdr ,%input)))
(display "TEEL:") (display ,%tail) (newline)
(cond ,@(map process-rule rules)
(#t ;;else
(syntax-error
"use of macro doesn't match definition"
,%input))))))
(define (process-rule rule)
(display "process-rule") (newline)
(cond ((and (pair? rule)
(pair? (cdr rule))
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
(let ((xx `,(process-pattern pattern
%tail
(lambda (x) x)))
(tt `,%tail)
(yy (process-match %tail pattern)))
(display "METS>>>") (newline)
(display yy)
(newline)
(display "TEEL>>>") (newline)
(display tt)
(newline)
(display "<<<METS") (newline)
(display "PETTERN>>>") (newline)
(display xx)
(newline)
(display "<<<PETTERN") (newline)
)
`((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)
(display "process-match") (newline)
(cond ((name? pattern)
(cond ((member pattern subkeywords)
`((,%compare ,input (,%rename ',pattern))))
(#t `())))
((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)))
(#t ;;else
`((equal? ,input ',pattern)))))
(define (process-segment-match input pattern)
(display "process-segment-match") (newline)
(let ((conjuncts (process-match '(car l) pattern)))
(cond ((null? conjuncts)
`((list? ,input))) ;+++
(#t `((let loop ((l ,input))
(display "loop") (newline)
(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)
(display "process-pattern pattern=") (display pattern) (newline)
(cond ((name? pattern)
(display "name!") (newline)
(display "subkeywords: ") (display subkeywords) (newline)
(cond ((memq pattern subkeywords)
;;;;(member pattern subkeywords)
'())
(#t
(display "hiero mapit=") (display mapit)
(display " path=") (display path)
(newline)
(list (list pattern (mapit path))))))
((segment-pattern? pattern)
(display "segment!") (newline)
(process-pattern (car pattern)
%temp
(lambda (x) ;temp is free in x
(display "mapit x=") (display x) (newline)
(mapit (cond ((eq? %temp x)
;; guile: x=%temp ==> mapit==> (cdr %tail)
;; mes: x=%temp ==> mapit==> %temp
(display " x=%temp ==> mapit==> ") (display path) (newline)
path) ;+++
(#t
(display "not!")
`(map (lambda (,%temp) ,x)
,path)))))))
((pair? pattern)
(display "pair!") (newline)
(append (process-pattern (car pattern) `(car ,path) mapit)
(process-pattern (cdr pattern) `(cdr ,path) mapit)))
(#t ;;else
(display "else!") (newline)
'())))
;; Generate code to compose the output expression according to template
(define (process-template template rank env)
(display "process-template") (newline)
(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)))))
((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) ;+++
(#t `(append ,gen ,(process-template (cddr template)
rank env)))))))))
((pair? template)
`(cons ,(process-template (car template) rank env)
,(process-template (cdr template) rank env)))
(#t ;;else
`(quote ,template))))
;; Return an association list of (var . rank)
(define (meta-variables pattern rank vars)
(display "meta-variables") (newline)
(cond ((name? pattern)
(cond ((memq pattern subkeywords)
vars)
(#t (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)))
(#t ;;else
vars)))
;; Return a list of meta-variables of given higher rank
(define (free-meta-variables template rank env free)
(display "free-meta-variables") (newline)
(cond ((name? template)
(cond ((and (not (memq template free))
(let ((probe (assq template env)))
(and probe (>= (cdr probe) rank))))
(cons template free))
(#t 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)))
(#t ;;else
free)))
c ;ignored
(display "HELLO")
(newline)
;; Kludge for Scheme48 linker.
;; `(cons ,(make-transformer rules)
;; ',(find-free-names-in-syntax-rules subkeywords rules))
(make-transformer rules))))
(mes:define-syntax mes:or
(syntax-rules ()
((mes:or) #f)
((mes:or e) e)
((mes:or e1 e ...) (let ((temp e1))
(cond (temp temp) (#t (or e ...)))))))
(display "(mes:or #f (= 0 1) 'hello-syntax-world): ")
(display (mes:or #f (= 0 1) 'hello-syntax-world))
(display (mes:or #f '==>baaa))
(newline)
(mes:define-syntax mes:when
(syntax-rules ()
((when condition exp ...)
(if condition
(begin exp ...)))))
(display (mes:when #t "when:hello syntax world"))
;; (define-macro (when cond exp . rest)
;; `(if ,cond
;; (begin ,exp . ,rest)))
;; (define-macro (when clause . rest)
;; (list 'cond (list clause (list 'let '() rest))))
(newline)
'syntax-dun