dotemacs

My Emacs configuration
git clone git://git.entf.net/dotemacs
Log | Files | Refs | LICENSE

slynk-macrostep.lisp (7754B)


      1 ;;; slynk-macrostep.lisp -- fancy macro-expansion via macrostep.el
      2 ;;
      3 ;; Authors: Luís Oliveira <luismbo@gmail.com>
      4 ;;          Jon Oddie <j.j.oddie@gmail.com>
      5 ;;          João Távora <joaotavora@gmail.com>
      6 ;;
      7 ;; License: Public Domain
      8 
      9 (in-package #:slynk-macrostep)
     10 
     11 
     12 (defslyfun macrostep-expand-1 (string compiler-macros? context)
     13   (with-buffer-syntax ()
     14     (let ((form (read-from-string string)))
     15       (multiple-value-bind (expansion error-message)
     16 	  (expand-form-once form compiler-macros? context)
     17 	(if error-message
     18             `(:error ,error-message)
     19 	    (multiple-value-bind (macros compiler-macros)
     20 		(collect-macro-forms-in-context expansion context)
     21 	      (let* ((all-macros (append macros compiler-macros))
     22 		     (pretty-expansion (pprint-to-string expansion))
     23 		     (positions (collect-form-positions expansion
     24 							pretty-expansion
     25 							all-macros))
     26                      (subform-info
     27                       (loop
     28                          for form in all-macros
     29                          for (start end) in positions
     30                          when (and start end)
     31                          collect (let ((op-name (to-string (first form)))
     32                                        (op-type
     33                                         (if (member form macros)
     34                                             :macro
     35                                             :compiler-macro)))
     36                                    (list op-name
     37                                          op-type
     38                                          start)))))
     39 		`(:ok ,pretty-expansion ,subform-info))))))))
     40 
     41 (defun expand-form-once (form compiler-macros? context)
     42   (multiple-value-bind (expansion expanded?)
     43       (macroexpand-1-in-context form context)
     44     (if expanded?
     45 	(values expansion nil)
     46 	(if (not compiler-macros?)
     47 	    (values nil "Not a macro form")
     48 	    (multiple-value-bind (expansion expanded?)
     49 		(compiler-macroexpand-1 form)
     50 	      (if expanded?
     51 		  (values expansion nil)
     52 		  (values nil "Not a macro or compiler-macro form")))))))
     53 
     54 (defslyfun macro-form-p (string compiler-macros? context)
     55   (with-buffer-syntax ()
     56     (let ((form
     57            (handler-case
     58                (read-from-string string)
     59              (error (condition)
     60                (unless (debug-on-slynk-error)
     61                  (return-from macro-form-p
     62                    `(:error ,(format nil "Read error: ~A" condition))))))))
     63       `(:ok ,(macro-form-type form compiler-macros? context)))))
     64 
     65 (defun macro-form-type (form compiler-macros? context)
     66   (cond
     67     ((or (not (consp form))
     68          (not (symbolp (car form))))
     69      nil)
     70     ((multiple-value-bind (expansion expanded?)
     71          (macroexpand-1-in-context form context)
     72        (declare (ignore expansion))
     73        expanded?)
     74      :macro)
     75     ((and compiler-macros?
     76           (multiple-value-bind (expansion expanded?)
     77               (compiler-macroexpand-1 form)
     78             (declare (ignore expansion))
     79             expanded?))
     80      :compiler-macro)
     81     (t
     82      nil)))
     83 
     84 
     85 ;;;; Hacks to support macro-expansion within local context
     86 
     87 (defparameter *macrostep-tag* (gensym))
     88 
     89 (defparameter *macrostep-placeholder* '*macrostep-placeholder*)
     90 
     91 (define-condition expansion-in-context-failed (simple-error)
     92   ())
     93 
     94 (defmacro throw-expansion (form &environment env)
     95   (throw *macrostep-tag* (macroexpand-1 form env)))
     96 
     97 (defmacro throw-collected-macro-forms (form &environment env)
     98   (throw *macrostep-tag* (collect-macro-forms form env)))
     99 
    100 (defun macroexpand-1-in-context (form context)
    101   (handler-case
    102       (macroexpand-and-catch
    103        `(throw-expansion ,form) context)
    104     (error ()
    105       (macroexpand-1 form))))
    106 
    107 (defun collect-macro-forms-in-context (form context)
    108   (handler-case
    109       (macroexpand-and-catch
    110        `(throw-collected-macro-forms ,form) context)
    111     (error ()
    112       (collect-macro-forms form))))
    113 
    114 (defun macroexpand-and-catch (form context)
    115   (catch *macrostep-tag*
    116     (macroexpand-all (enclose-form-in-context form context))
    117     (error 'expansion-in-context-failed)))
    118 
    119 (defun enclose-form-in-context (form context)
    120   (with-buffer-syntax ()
    121     (destructuring-bind (prefix suffix) context
    122       (let* ((placeholder-form
    123               (read-from-string
    124                (concatenate
    125                 'string
    126                 prefix (prin1-to-string *macrostep-placeholder*) suffix)))
    127              (substituted-form (subst form *macrostep-placeholder*
    128                                       placeholder-form)))
    129         (if (not (equal placeholder-form substituted-form))
    130             substituted-form
    131             (error 'expansion-in-context-failed))))))
    132 
    133 
    134 ;;;; Tracking Pretty Printer
    135 
    136 (defun marker-char-p (char)
    137   (<= #xe000 (char-code char) #xe8ff))
    138 
    139 (defun make-marker-char (id)
    140   ;; using the private-use characters U+E000..U+F8FF as markers, so
    141   ;; that's our upper limit for how many we can use.
    142   (assert (<= 0 id #x8ff))
    143   (code-char (+ #xe000 id)))
    144 
    145 (defun marker-char-id (char)
    146   (assert (marker-char-p char))
    147   (- (char-code char) #xe000))
    148 
    149 (defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32)))
    150 
    151 (defun whitespacep (char)
    152   (member char +whitespace+))
    153 
    154 (defun pprint-to-string (object &optional pprint-dispatch)
    155   (let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*)))
    156     (with-bindings *macroexpand-printer-bindings*
    157       (to-string object))))
    158 
    159 #-clisp
    160 (defun collect-form-positions (expansion printed-expansion forms)
    161   (loop for (start end)
    162      in (collect-marker-positions
    163          (pprint-to-string expansion (make-tracking-pprint-dispatch forms))
    164          (length forms))
    165      collect (when (and start end)
    166                (list (find-non-whitespace-position printed-expansion start)
    167                      (find-non-whitespace-position printed-expansion end)))))
    168 
    169 ;; The pprint-dispatch table constructed by
    170 ;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack
    171 ;; overflow under CLISP version 2.49.  Make the COLLECT-FORM-POSITIONS
    172 ;; entry point a no-op in thi case, so that basic macro-expansion will
    173 ;; still work (without detection of inner macro forms)
    174 #+clisp
    175 (defun collect-form-positions (expansion printed-expansion forms)
    176   nil)
    177 
    178 (defun make-tracking-pprint-dispatch (forms)
    179   (let ((original-table *print-pprint-dispatch*)
    180         (table (copy-pprint-dispatch)))
    181     (flet ((maybe-write-marker (position stream)
    182              (when position
    183                (write-char (make-marker-char position) stream))))
    184       (set-pprint-dispatch 'cons
    185                            (lambda (stream cons)
    186                              (let ((pos (position cons forms)))
    187                                (maybe-write-marker pos stream)
    188                                ;; delegate printing to the original table.
    189                                (funcall (pprint-dispatch cons original-table)
    190                                         stream
    191                                         cons)
    192                                (maybe-write-marker pos stream)))
    193                            most-positive-fixnum
    194                            table))
    195     table))
    196 
    197 (defun collect-marker-positions (string position-count)
    198   (let ((positions (make-array position-count :initial-element nil)))
    199     (loop with p = 0
    200           for char across string
    201           unless (whitespacep char)
    202             do (if (marker-char-p char)
    203                    (push p (aref positions (marker-char-id char)))
    204                    (incf p)))
    205     (map 'list #'reverse positions)))
    206 
    207 (defun find-non-whitespace-position (string position)
    208   (loop with non-whitespace-position = -1
    209         for i from 0 and char across string
    210         unless (whitespacep char)
    211           do (incf non-whitespace-position)
    212         until (eql non-whitespace-position position)
    213         finally (return i)))
    214 
    215 (provide :slynk-macrostep)