Eclector, Walker and Source Tracking Example

(defparameter *input* "(if x (cons 1 2))")

(read-and-walk *input*)

  1: #.(progn
  2:     #1=(ql:quickload '(:concrete-syntax-tree
  3:                        :concrete-syntax-tree-lambda-list
  4:                        :concrete-syntax-tree-destructuring
  5: 
  6:                        :eclector
  7:                        :eclector-concrete-syntax-tree))
  8:     '#1#)
  9: 
 10: (cl:defpackage #:eclector.examples.shinmera.environment
 11:   (:use
 12:    #:common-lisp
 13:    #:alexandria)
 14: 
 15:   ;; Environment protocol
 16:   (:export
 17:    #:parent
 18:    #:lookup) ; also setf
 19: 
 20:   ;; Class standard-environment
 21:   (:export
 22:    #:standard-environment)
 23: 
 24:   ;; Utilities
 25:   (:export
 26:    #:augment-environment!
 27:    #:augmented-environment))
 28: 
 29: (cl:in-package #:eclector.examples.shinmera.environment)
 30: 
 31: (defclass standard-environment ()
 32:   ((parent     :initarg  :parent
 33:                :reader   parent
 34:                :initform nil)
 35:    (namespaces :reader   spaces
 36:                :initform (make-hash-table :test #'eq))))
 37: 
 38: (defun namespace (namespace environment)
 39:   (gethash namespace (spaces environment)))
 40: 
 41: (defun ensure-namespace (namespace environment)
 42:   (ensure-gethash namespace (spaces environment)
 43:                   (make-hash-table :test #'eq)))
 44: 
 45: (defmethod lookup ((name t) (namespace t) (environment standard-environment))
 46:   (multiple-value-bind (value defined?)
 47:       (when-let ((namespace (namespace namespace environment)))
 48:         (gethash name namespace))
 49:     (if defined?
 50:         (values value defined?)
 51:         (when-let ((parent (parent environment)))
 52:           (lookup name namespace parent)))))
 53: 
 54: (defmethod (setf lookup) ((new-value   t)
 55:                           (name        t)
 56:                           (namespace   t)
 57:                           (environment standard-environment))
 58:   (let ((namespace (ensure-namespace namespace environment)))
 59:     (setf (gethash name namespace) new-value)))
 60: 
 61: (defun augment-environment! (environment names values)
 62:   (map nil (lambda (name value)
 63:              (etypecase name
 64:                (symbol
 65:                 (setf (lookup name 'variable environment) value))
 66:                ((cons symbol symbol)
 67:                 (destructuring-bind (name . namespace) name
 68:                   (setf (lookup name namespace environment) value)))))
 69:        names values)
 70:   environment)
 71: 
 72: (defun augmented-environment (parent names values
 73:                               &key (class (class-of parent)))
 74:   (let ((environment (make-instance class :parent parent)))
 75:     (augment-environment! environment names values)
 76:     environment))
 77: 
 78: (cl:defpackage #:eclector.examples.shinmera
 79:   (:use
 80:    #:common-lisp
 81:    #:alexandria)
 82: 
 83:   (:local-nicknames
 84:    (#:cst    #:concrete-syntax-tree)
 85: 
 86:    (#:env    #:eclector.examples.shinmera.environment)
 87: 
 88:    (#:reader #:eclector.reader)
 89:    (#:result #:eclector.parse-result)))
 90: 
 91: (cl:in-package #:eclector.examples.shinmera)
 92: 
 93: ;;; Source tracking reader that produces CST instances.
 94: 
 95: (defclass client (eclector.concrete-syntax-tree::cst-client)
 96:   ())
 97: 
 98: #+no (defmethod result:source-position ((stream t) (client client))
 99:   (file-position stream))
100: 
101: (defmethod reader:evaluate-expression ((client client) (expression t))
102:   (eval expression))
103: 
104: ;;; lambda-list Parameter conversion
105: 
106: (defmethod walk-lambda-list ((cst t) (environment t))
107:   (let ((lambda-list (cst:parse-ordinary-lambda-list t cst)))
108:     (walk-lambda-list lambda-list environment)))
109: 
110: (defmethod walk-lambda-list ((cst cst:ordinary-lambda-list) (environment t))
111:   (flet ((parameter (type)
112:            (when-let ((group (find-if (of-type type) (cst:children cst))))
113:              (cst:parameter group)))
114:          (parameters (type)
115:            (when-let ((group (find-if (of-type type) (cst:children cst))))
116:              (cst:parameters group))))
117:     (let ((ordinary (parameters 'cst:ordinary-required-parameter-group))
118:           (optional (parameters 'cst:ordinary-optional-parameter-group))
119:           (rest     (parameter  'cst:ordinary-rest-parameter-group))
120:           (key      (parameters 'cst:key-parameter-group)))
121:       (mappend (rcurry #'walk environment)
122:                (append ordinary optional (when rest (list rest)) key)))))
123: 
124: (defmethod walk ((cst cst:simple-variable) (environment t))
125:   (list (walk (cst:name cst) environment)))
126: 
127: (defmethod walk ((cst cst:ordinary-optional-parameter) (environment t))
128:   (list* (walk (cst:name cst) environment)
129:          (when-let ((supplied-p (cst:supplied-p cst)))
130:            (list (walk supplied-p environment)))))
131: 
132: (defmethod walk ((cst cst:ordinary-key-parameter) (environment t))
133:   (list* (walk (cst:name cst) environment)
134:          (when-let ((supplied-p (cst:supplied-p cst)))
135:            (list (walk supplied-p environment)))))
136: 
137: ;;; Utilities
138: 
139: ;; TODO rename to parse-* (or rename everything else to convert-*)
140: (defun walk-forms (cst environment)
141:   (labels ((one-form (forms)
142:              (let ((first (cst:first forms))
143:                    (rest  (cst:rest forms)))
144:                `(:abstraction
145:                  ,(cst:source cst)
146:                  ((:variable-reference nil))
147:                  ,(if (cst:consp rest)
148:                       `(:application
149:                         (one-form rest)
150:                         (list (parse first environment)))
151:                       (walk first environment))))))
152:     (cond
153:       ((cst:null cst)
154:        (error "not yet handled"))
155:       ((cst:null (cst:rest cst))
156:        (walk (cst:first cst) environment))
157:       (t
158:        `(:application
159:          ,(cst:source cst)
160:          ,(one-form cst) (list `(:literal -1)))))))
161: 
162: (defun walk-body (cst environment)
163:   (multiple-value-bind (declarations forms)
164:       (cst:separate-ordinary-body cst)
165:     (declare (ignore declarations))
166:     (walk-forms forms environment)))
167: 
168: (defun walk-lambda-like (cst environment)
169:   (cst:db source (operator-or-name lambda-list . body) cst
170:     (declare (ignore source operator-or-name))
171:     (let ((variables (walk-lambda-list lambda-list environment)))
172:       (multiple-value-bind (declarations documentation forms)
173:           (cst:separate-function-body body)
174:         (declare (ignore declarations documentation))
175:         `(:abstraction ,(cst:source cst) ,variables ,(walk-forms forms environment))))))
176: 
177: ;;;
178: 
179: (defmethod walk :around ((cst cst:cst) (environment t))
180:   (restart-case
181:       (call-next-method)
182:     (continue (&optional condition)
183:       :report (lambda (stream)
184:                 (format stream "~@<Replace form with ~S~@:>" nil))
185:       (declare (ignore condition))
186:           ; TODO
187:           )))
188: 
189: (defmethod walk ((cst cst:atom-cst) (environment t))
190:   (let ((result (walk-atom (cst:raw cst) environment)))
191:     (setf (second result) (cst:source cst))
192:     result))
193: 
194: (defmethod walk ((cst cst:cons-cst) (environment t))
195:   (walk-form (cst:raw (cst:first cst)) cst environment))
196: 
197: (defmethod walk-atom ((atom symbol) (environment t))
198:   (typecase atom
199:     ((or keyword boolean)
200:      `(:literal nil ,atom))
201:     (t
202:      `(:variable-reference nil ,atom))))
203: 
204: (defmethod walk-atom ((atom t) (environment t))
205:   `(:literal nil ,atom))
206: 
207: (macrolet
208:     ((define-walk-compound-form
209:          (operator (cst-var &optional (environment-var (gensym "ENVIRONMENT")))
210:           &body body)
211:        (with-unique-names (operator-var)
212:          `(defmethod walk-form ((,operator-var    ,(case operator
213:                                                      ((t) 't)
214:                                                      (t   `(eql ',operator))))
215:                                 (,cst-var         cst:cons-cst)
216:                                 (,environment-var t))
217:             (flet ((walk (cst &optional (environment ,environment-var))
218:                      (walk cst environment))
219:                    (walk-forms (cst &optional (environment ,environment-var))
220:                      (walk-forms cst environment)))
221:               (declare (ignorable #'walk #'walk-forms))
222:               ,@body)))))
223: 
224:   (define-walk-compound-form eval-when (cst)
225:     (cst:db source (operator situations . body) cst
226:       (declare (ignore source operator situations))
227:       (walk-forms body)))
228: 
229:   (define-walk-compound-form quote (cst)
230:     (let ((material (cst:second cst)))
231:       `(:literal ,(cst:source cst) ,(cst:raw material))))
232: 
233:   (define-walk-compound-form the (cst)
234:     (cst:db source (operator type form) cst
235:       (declare (ignore source operator type))
236:       (walk form)))
237: 
238:   (define-walk-compound-form locally (cst environment)
239:     (cst:db source (operator . body) cst
240:       (declare (ignore source operator))
241:       (walk-body body environment)))
242: 
243:   (define-walk-compound-form function (cst)
244:     (cst:db source (operator function-designator) cst
245:       (declare (ignore source operator))
246:       (if (and (cst:consp function-designator)
247:                (eq (cst:raw (cst:first function-designator)) 'lambda))
248:           (walk function-designator)
249:           `(:variable-reference
250:             ,(cst:source cst)
251:             ,(if (consp (cst:raw function-designator)) ; TODO hack
252:                  (second (cst:raw function-designator))
253:                  (cst:raw function-designator))))))
254: 
255:   (define-walk-compound-form lambda (cst environment)
256:     (walk-lambda-like cst environment))
257: 
258:   (define-walk-compound-form labels (cst environment)
259:     (cst:db source (operator definitions . body) cst
260:       (declare (ignore source operator))
261:       (let* ((definitions (cst:listify definitions))
262:              (names       (map 'list #'cst:first definitions)))
263:         `(:labels
264:           ,(cst:source cst)
265:           ,(map 'list #'walk names)
266:           ,(map 'list (lambda (definition)
267:                         (walk-lambda-like definition environment)) ; TODO wrong environment
268:                 definitions)
269:           ,(walk-body body environment)))))
270: 
271:   (define-walk-compound-form flet (cst environment) ; TODO same as LABELS
272:     (cst:db source (operator definitions . body) cst
273:       (declare (ignore source operator))
274:       (let* ((definitions (cst:listify definitions))
275:              (names       (map 'list #'cst:first definitions)))
276:         `(:flet
277:           ,(cst:source cst)
278:           ,(map 'list #'walk names)
279:           ,(map 'list (lambda (definition)
280:                         (walk-lambda-like definition environment))
281:                 definitions)
282:           ,(walk-body body environment)))))
283: 
284:   (define-walk-compound-form if (cst)
285:     (cst:db source (operator test then . else) cst ; TODO this accepts (if 1 2 3 4)
286:       (declare (ignore source operator))
287:       `(:conditional
288:         ,(cst:source cst)
289:         ,(walk test) ,(walk then) ,@(unless (cst:null else)
290:                                       (list (walk (cst:first else)))))))
291: 
292:   (define-walk-compound-form let (cst)
293:     (cst:db source (operator definitions . body) cst
294:       (declare (ignore source operator))
295:       (let ((definitions (cst:listify definitions)))
296:         (multiple-value-bind (declarations forms)
297:             (cst:separate-ordinary-body body)
298:           (declare (ignore declarations))
299:           `(:let
300:             ,(cst:source cst)
301:             ,(map 'list (compose #'walk #'cst:first) definitions)
302:             ,(map 'list (compose #'walk #'cst:second) definitions)
303:             ,(walk-forms forms))))))
304: 
305:   (define-walk-compound-form let* (cst) ; TODO
306:     (cst:db source (operator definitions . body) cst
307:       (declare (ignore source operator))
308:       (let ((definitions (cst:listify definitions)))
309:         (multiple-value-bind (declarations forms)
310:             (cst:separate-ordinary-body body)
311:           (declare (ignore declarations))
312:           `(:let*
313:             ,(cst:source cst)
314:             ,(map 'list (compose #'walk #'cst:first) definitions)
315:             ,(map 'list (compose #'walk #'cst:second) definitions)
316:             ,(walk-forms forms))))))
317: 
318:   (define-walk-compound-form block (cst environment)
319:     (cst:db source (operator name . body) cst
320:       (declare (ignore source operator))
321:       (let ((name/raw (cst:raw name)))
322:         (unless (symbolp name/raw)
323:           (error "~@<Block name must be a symbol, not ~S.~@:>" name/raw))
324:         (walk-forms body (env:augmented-environment
325:                           environment `((,name/raw . :block-name)) '(t))))))
326: 
327:   (define-walk-compound-form return-from (cst environment)
328:     (cst:db source (operator name value) cst
329:       (declare (ignore source operator))
330:       (let ((name/raw (cst:raw name)))
331:         (unless (symbolp name/raw)
332:           (error "~@<Block name must be a symbol, not ~S.~@:>" name/raw))
333:         (if-let ((name* (env:lookup name/raw :block-name environment)))
334:           (walk value)
335:           (error "~@<Unknown block name: ~S.~@:>" name/raw)))))
336: 
337:   (define-walk-compound-form tagbody (cst environment)
338:     (cst:db source (operator . body) cst
339:       (declare (ignore source operator))
340:       (let* ((sections (list (cons nil '())))
341:              (section  (first sections)))
342:         (labels ((visit (first rest)
343:                    (cond
344:                      ((cst:atom first)
345:                       (when (equal sections '((nil . nil)))
346:                         (setf sections '()))
347:                       (let ((tag/raw (cst:raw first)))
348:                         (unless (typep tag/raw '(or symbol integer))
349:                           (error "~@<Tag must be a symbol or integer, not ~S.~@:>" tag/raw))
350:                         (when-let ((other (car (find tag/raw sections
351:                                                      :key (compose #'cst:raw #'car)))))
352:                           (error "~@<Repeated tag: ~S.~@:>" tag/raw))
353:                         (setf (cdr section) (nreverse (cdr section))
354:                               section       (cons first '()))
355:                         (push section sections)))
356:                      (t
357:                       (push first (cdr section))))
358:                    (when (cst:consp rest)
359:                      (visit (cst:first rest) (cst:rest rest)))))
360:           (if (cst:consp body)
361:               (visit (cst:first body) (cst:rest body))
362:               (error "not implemented")))
363:         (setf (cdr section) (nreverse (cdr section)))
364:         (let ((env (env:augmented-environment
365:                     environment
366:                     (map 'list (lambda (section)
367:                                  (cons (cst:raw (car section)) :tag))
368:                          sections)
369:                     (map 'list (lambda (section)
370:                                  t)
371:                          sections))))
372:           `(:labels
373:              ,(cst:source cst)
374:              ,(map 'list (lambda (section)
375:                            (let ((tag (car section)))
376:                              `(:variable-reference ,(cst:source cst) ,(cst:raw tag))))
377:                  sections)
378:              ,(map 'list (lambda (section)
379:                            `(:abstraction
380:                              ,(cst:source cst)
381:                              '()
382:                              ,(walk (first (cdr section)) env) ; TODO fallthrough
383:                                         ; (convert-forms (first (cdr section)) environment)
384:                              ))
385:                    sections)
386:              `(:application ,(cst:source cst) (:variable-reference ,(cst:source cst) ,(cst:raw (car (first sections)))) '()))))))
387: 
388:   (define-walk-compound-form go (cst environment)
389:     (cst:db source (operator tag) cst
390:       (declare (ignore source operator))
391:       (let ((tag/raw (cst:raw tag)))
392:         (unless (typep tag/raw '(or symbol integer))
393:           (error "~@<Tag must be a symbol or integer, not ~S.~@:>" tag/raw))
394:         (if-let ((tag* (env:lookup tag/raw :tag environment))) ; TODO store the variable in the environment?
395:           `(:application
396:             ,(cst:source cst)
397:             (:variable-reference ,(cst:source cst) ,tag/raw)
398:             '()) ; TODO
399:           (error "~@<Unknown tag: ~S.~@:>" tag/raw)))))
400: 
401:   (define-walk-compound-form progn (cst)
402:     (let ((rest (cst:rest cst)))
403:       (if (cst:null (cst:rest rest))
404:           (walk (cst:first rest))
405:           (walk-forms rest))))
406: 
407: ;;; Since special operators should have been dealt with, functions
408: ;;; and macros remain.
409:   (define-walk-compound-form t (cst environment)
410:     (cst:db source (operator . arguments) cst
411:       (declare (ignore source))
412:       (if (cst:atom operator)
413:           (if-let ((expander (macro-function (cst:raw operator))))
414:             (let ((expansion (perform-and-record-macro-expansion expander cst)))
415:               (walk expansion))
416:             `(:application
417:               ,(cst:source cst)
418:               ,(walk operator)
419:               ,(map 'list #'walk (cst:listify arguments))))
420:           (error "~@<Non-atom operator not yet implemented: ~S~:@>" cst)))))
421: 
422: ;;; Macro expansion
423: 
424: (defun perform-and-record-macro-expansion (expander cst)
425:   (let* ((expansion/raw (funcall expander (cst:raw cst) nil))
426:          (reconstructed (cst:reconstruct expansion/raw cst t)))
427:       (labels ((record (node source-and-targets &optional root?)
428:                  (push node (cdr source-and-targets))
429:                  (when (cst:consp node)
430:                    (record (cst:first node) source-and-targets)
431:                    (record (cst:rest node)  source-and-targets))
432:                  #+no (when root?
433:                    (trace:add-trace* (trace:make-trace (car source-and-targets)
434:                                                        (nreverse (cdr source-and-targets)))))))
435:         (record reconstructed (cons cst '()) t)
436:         reconstructed)))
437: 
438: ;;; Entry point
439: 
440: (defun read-and-walk (input)
441:   (let* (;; Read
442:          (client      (make-instance 'client))
443:          (tlfs        (with-input-from-string (stream input)
444:                         (loop :for top-level-form = (restart-case
445:                                                         (result:read client stream nil '#1=#.(make-symbol "EOF"))
446:                                                       (continue ()
447:                                                         :report "Skip the top-level form"
448:                                                         nil))
449:                               :until (eq top-level-form '#1#)
450:                               :collect top-level-form)))
451:          ;; Walk
452:          (environment (make-instance 'env:standard-environment))
453:          (result      (map 'list (rcurry #'walk environment) tlfs)))
454:     result))