1; SketchyLISP -- An interpreter for purely applicative Scheme
2; Copyright (C) 2006,2007 Nils M Holm <nmh@t3x.org>
3; See the file LICENSE for conditions of use.
4
5(package 'core)
6
7; Syntax transformer
8
9; (define (d x) (begin (display "D--> ") (write x) (newline) x))
10
11; Extend environment
12(define (ext-env name x v env)
13  (cond ((assq x env)
14      (bottom (append (list name ':)
15                      '(duplicate variable in pattern:)
16                      (list x))))
17    (else (cons (cons x v) env))))
18
19; Match an ellipsis.
20; HEAD is the part to be associated with the ellipsis.
21; TAIL is the remaining form to match after the ellipsis.
22; Thus function uses a longest match first approach, so
23; (match-ellipsis '(x x k k k) '(k) 'n '(k) ())
24;   => ((... . (x x k k)))
25
26(define (match-ellipsis form pattern name lits env)
27  (letrec
28    ((try-match (lambda (head tail)
29      (let ((v (match tail pattern name lits env)))
30        (cond (v (ext-env name '... (reverse head) v))
31          ((null? head) #f)
32          (else (try-match (cdr head)
33                (cons (car head) tail))))))))
34    (try-match (reverse form) ())))
35
36; Match form against pattern.
37; name - name of syntax transformer;
38; lits - literals (keywords) of syntax-rules;
39; env - initial environment.
40; Returns an environment with bindings of
41; pattern variables to subforms or #F in
42; cass form does not match pattern.
43
44(define (match form pattern name lits env)
45  (letrec
46    ((_match (lambda (form pattern env)
47      (cond ((eq? pattern '_)
48          (if (eq? form name) env #f))
49        ((memq pattern lits)
50          (if (eq? form pattern) env #f))
51        ((and (pair? pattern) (eq? (car pattern) '...))
52          (match-ellipsis form (cdr pattern)
53                          name lits env))
54        ((symbol? pattern)
55          (if (memq pattern lits)
56              (if (eq? pattern form) env #f)
57              (ext-env name pattern form env)))
58        ((and (pair? pattern)
59              (pair? form))
60          (let ((e (_match (car form) (car pattern) env)))
61            (and e (_match (cdr form) (cdr pattern) e))))
62        (else (if (equal? form pattern) env #f))))))
63    (_match form pattern env)))
64
65; Find rule with a pattern that matches the given form.
66; rules - list of rules to try;
67; name - name of syntax transformer;
68; lits - literals (keywords) of syntax-rules.
69
70(define (find-rule form rules name lits)
71  (cond ((null? rules)
72      (bottom name ': 'bad 'syntax))
73    (else (let ((e (match form (caar rules) name lits '())))
74          (cond (e (list (caar rules) (cadar rules) e))
75            (else (find-rule form (cdr rules) name lits)))))))
76
77; Replace OLD by NEW in FORM.
78(define (replace old new form)
79  (cond ((equal? form old) new)
80    ((pair? form)
81      (cons (replace old new (car form))
82            (replace old new (cdr form))))
83    (else form)))
84
85; Substitute keys of A by values of A in X.
86(define (substitute x a)
87  (let ((v (assoc x a)))
88    (cond (v (cdr v))
89      ((pair? x)
90        (cons (substitute (car x) a)
91              (substitute (cdr x) a)))
92      (else x))))
93
94; Substitute forms matching an ellipsis
95(define (subst-rest rest ptrn form)
96  (cond ((pair? ptrn)
97      (let ((p (car ptrn))
98            (f (car form)))
99        (map (lambda (x)
100               (let ((e (cons x (replace p x f))))
101                 (substitute x (list e))))
102             rest)))
103    (else rest)))
104
105; Substitute variables of env by values of env in form.
106(define (tmpl->form ptrn form env)
107  (cond ((not (pair? form))
108      (let ((v (assv form env)))
109        (if v (cdr v) form)))
110    ((and (pair? form) (pair? (cdr form)) (eq? (cadr form) '...))
111      (let ((new (tmpl->form #f (car form) env))
112            (v (assq '... env)))
113        (if v (append (list new)
114                      (subst-rest (cdr v) ptrn form)
115                      (cddr form))
116              (bottom 'unmatched '... 'in 'syntax-rule))))
117    ((and (pair? form) (eq? (car form) '...))
118      (bottom '(syntax-rules: this should not happen)))
119    ((pair? form)
120      (cons (tmpl->form (if (pair? ptrn) (car ptrn) #f) (car form) env)
121            (tmpl->form (if (pair? ptrn) (cdr ptrn) #f) (cdr form) env)))
122    (else form)))
123
124; Transform the syntax of the given form.
125; This is the entry point of the syntax transformer
126; when called from the SketchyLISP core.
127
128(define (transform-syntax form)
129  (let ((syn (syntax->list (car form))))
130    (if (not syn)
131        (bottom 'bad 'syntax 'rules: form)
132        (let ((name (car syn))
133              (lits (cadr syn))
134              (rules (caddr syn)))
135          (let ((pat/rule/env (find-rule form rules name lits)))
136            (transform-all
137              (apply tmpl->form pat/rule/env)))))))
138
139; TRANSFORM-ALL *must* be defined *after* TRANSFORM-SYNTAX.
140; This is probably because TRANSFORM-SYNTAX is defined by
141; the SketchyLISP core. To be investigated!
142
143; Syntax-transform all subforms of the given form.
144(define (transform-all form)
145  (cond ((not (pair? form)) form)
146    ((eq? (car form) 'quote) form)
147    ((syntax->list (car form))
148      (transform-syntax form))
149    (else (map transform-all form))))
150
151(package)
152