hax0rz..ugh + next name? test in macro.mes.
This commit is contained in:
Jan Nieuwenhuizen
parent
40bbb3dff1
commit
341d064a34
36
macro.mes
36
macro.mes
|
|
@ -58,20 +58,28 @@
|
|||
)
|
||||
|
||||
(d-s s-r
|
||||
(lambda (. n-a)
|
||||
(display "YEAH:")
|
||||
(display n-a)
|
||||
(newline)
|
||||
'(lambda (. i) ;;(i r c)
|
||||
(display "transformers")
|
||||
(newline)
|
||||
''tee-hee-hee
|
||||
)
|
||||
;; (define (foo) (display "Footje") (newline) 'f-f-f)
|
||||
;; foo
|
||||
;;"blaat"
|
||||
)
|
||||
;;(let ())
|
||||
(;; let () ;; syntax-rules uses (let () ...),
|
||||
;; mes doesn't support that yet; use ((lambda () ...))
|
||||
(lambda ()
|
||||
;; syntax-rules uses defines that get closured-in
|
||||
;; mes doesn't support that yet; move down
|
||||
;; (define name? symbol?)
|
||||
(lambda (. n-a)
|
||||
(define name? symbol?)
|
||||
|
||||
(display "YEAH:")
|
||||
(display n-a)
|
||||
(display (name? n-a))
|
||||
(newline)
|
||||
'(lambda (. i) ;;(i r c)
|
||||
(display "transformers")
|
||||
(newline)
|
||||
''tee-hee-hee
|
||||
)
|
||||
;; (define (foo) (display "Footje") (newline) 'f-f-f)
|
||||
;; foo
|
||||
;;"blaat"
|
||||
)))
|
||||
)
|
||||
|
||||
(display "calling s-r")
|
||||
|
|
|
|||
20
mes.c
20
mes.c
|
|
@ -291,6 +291,17 @@ apply_env_ (scm *fn, scm *x, scm *a)
|
|||
return begin_env (cddr (fn), pairlis (cadr (fn), x, a));
|
||||
else if (car (fn) == &scm_label)
|
||||
return apply_env (caddr (fn), x, cons (cons (cadr (fn), caddr (fn)), a));
|
||||
else if (car (fn)->type == PAIR) {
|
||||
#if DEBUG // FIXME: for macro.mes/syntax.mes this feels *wrong*
|
||||
printf ("APPLY WTF: fn=");
|
||||
display (fn);
|
||||
puts ("");
|
||||
#endif
|
||||
//return apply_env_ (eval_ (fn, a), x, a);
|
||||
scm *e = eval_ (fn, a);
|
||||
return apply_env_ (e, x, a);
|
||||
//return &scm_unspecified;
|
||||
}
|
||||
#if MACROS
|
||||
else if ((macro = assq (car (fn), cdr (assq (&scm_macro, a)))) != &scm_f) {
|
||||
#if DEBUG
|
||||
|
|
@ -302,13 +313,18 @@ apply_env_ (scm *fn, scm *x, scm *a)
|
|||
display (cdr (fn));
|
||||
puts ("");
|
||||
#endif
|
||||
scm *r = apply_env (cdr (macro), cdr (fn), a);
|
||||
//scm *r = apply_env (cdr (macro), cdr (fn), a);
|
||||
scm *r = apply_env (eval_ (cdr (macro), a), cdr (fn), a);
|
||||
#if DEBUG
|
||||
printf ("APPLY MACRO GOT: ==> ");
|
||||
display (r);
|
||||
puts ("");
|
||||
#endif
|
||||
return apply_env (r, x, a);
|
||||
//return apply_env (r, x, a);
|
||||
|
||||
scm *e = eval_ (r, a);
|
||||
return apply_env (e, x, a);
|
||||
|
||||
//return eval_ (cons (r, x), a);
|
||||
//return apply_env_ (eval (cdr (macro), a), x, a);
|
||||
//return eval (apply_env_ (cdr (macro), x, a), a);
|
||||
|
|
|
|||
346
syntax.mes
346
syntax.mes
|
|
@ -6,6 +6,8 @@
|
|||
;;(display thing)
|
||||
(newline))
|
||||
|
||||
(define (member x lst)
|
||||
(display "MEMBER x=") (display x) (newline) (memq x lst))
|
||||
(display "mes:define-syntax...")
|
||||
|
||||
;;(define (caddr x) (car (cdr (cdr x))))
|
||||
|
|
@ -81,191 +83,211 @@
|
|||
(newline)
|
||||
|
||||
(mes:define-syntax syntax-rules
|
||||
(let ()
|
||||
;;begin
|
||||
(;; let () ;; syntax-rules uses (let () ...),
|
||||
;; mes doesn't support that yet; use ((lambda () ...))
|
||||
(lambda ()
|
||||
|
||||
(define name? symbol?)
|
||||
;; syntax-rules uses defines that get closured-in
|
||||
;; mes doesn't support that yet; 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 "...") '---))
|
||||
;; (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")
|
||||
(display "BOOO")
|
||||
|
||||
(lambda (exp r c)
|
||||
(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))
|
||||
;; FIXME: mes, moved 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 "...") '---))
|
||||
;; end FIXME
|
||||
|
||||
|
||||
(define rules (cddr exp))
|
||||
(define subkeywords (cadr exp))
|
||||
(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 (make-transformer rules)
|
||||
`(lambda (,%input ,%rename ,%compare)
|
||||
(let ((,%tail (cdr ,%input)))
|
||||
(cond ,@(map process-rule rules)
|
||||
(#t ;;else
|
||||
(syntax-error
|
||||
"use of macro doesn't match definition"
|
||||
,%input))))))
|
||||
(define rules (cddr exp))
|
||||
(define subkeywords (cadr exp))
|
||||
|
||||
(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)))
|
||||
(define (make-transformer rules)
|
||||
`(lambda (,%input ,%rename ,%compare)
|
||||
(let ((,%tail (cdr ,%input)))
|
||||
(cond ,@(map process-rule rules)
|
||||
(#t ;;else
|
||||
(syntax-error
|
||||
"use of macro doesn't match definition"
|
||||
,%input))))))
|
||||
|
||||
;; Generate code to test whether input expression matches pattern
|
||||
(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)))
|
||||
|
||||
(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)))
|
||||
(#t ;;else
|
||||
`((equal? ,input ',pattern)))))
|
||||
;; Generate code to test whether input expression matches 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)))))))))
|
||||
(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)))
|
||||
(#t ;;else
|
||||
`((equal? ,input ',pattern)))))
|
||||
|
||||
;; Generate code to take apart the input expression
|
||||
;; This is pretty bad, but it seems to work (can't say why).
|
||||
(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)))))))))
|
||||
|
||||
(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)))
|
||||
(#t ;;else
|
||||
'())))
|
||||
;; Generate code to take apart the input expression
|
||||
;; This is pretty bad, but it seems to work (can't say why).
|
||||
|
||||
;; Generate code to compose the output expression according to template
|
||||
(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)))
|
||||
(#t ;;else
|
||||
'())))
|
||||
|
||||
(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)))
|
||||
(#t ;;else
|
||||
`(quote ,template))))
|
||||
;; Generate code to compose the output expression according to template
|
||||
|
||||
;; Return an association list of (var . rank)
|
||||
(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)))
|
||||
(#t ;;else
|
||||
`(quote ,template))))
|
||||
|
||||
(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)))
|
||||
(#t ;;else
|
||||
vars)))
|
||||
;; Return an association list of (var . rank)
|
||||
|
||||
;; Return a list of meta-variables of given higher 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)))
|
||||
(#t ;;else
|
||||
vars)))
|
||||
|
||||
(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)))
|
||||
(#t ;;else
|
||||
free)))
|
||||
;; Return a list of meta-variables of given higher rank
|
||||
|
||||
c ;ignored
|
||||
(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)))
|
||||
(#t ;;else
|
||||
free)))
|
||||
|
||||
(display "HELLO")
|
||||
(newline)
|
||||
c ;ignored
|
||||
|
||||
;; Kludge for Scheme48 linker.
|
||||
;; `(cons ,(make-transformer rules)
|
||||
;; ',(find-free-names-in-syntax-rules subkeywords rules))
|
||||
(display "HELLO")
|
||||
(newline)
|
||||
|
||||
(make-transformer rules))))
|
||||
;; Kludge for Scheme48 linker.
|
||||
;; `(cons ,(make-transformer rules)
|
||||
;; ',(find-free-names-in-syntax-rules subkeywords rules))
|
||||
|
||||
(make-transformer rules)))))
|
||||
|
||||
|
||||
(mes:define-syntax mes:or
|
||||
|
|
|
|||
Loading…
Reference in a new issue