ast.lisp

   1 ;;; Abstract Syntax Tree-ish tools for m68k-assembler.
   2 ;;;
   3 ;;; Julian Squires / 2005
   4 ;;;
   5
   6 (in-package :m68k-assembler)
   7
   8 ;;;; PARSE TREE MANIPULATORS
   9
  10 ;;; XXX Not the most efficient way to get a list of operands, but I am
  11 ;;; getting tired.
  12 (defun extract-operands (parse-tree)
  13   (labels ((inner-fn (parse-tree)
  14              (let ((list))
  15                (dolist (x parse-tree)
  16                  (when (consp x)
  17                    (when (eql (car x) 'operand)
  18                      (push (cadr x) list))
  19                    (when (eql (car x) 'operands)
  20                      (setf list (nconc (inner-fn x) list)))))
  21                list)))
  22     (reverse (inner-fn parse-tree))))
  23
  24
  25 (defun simplify-operand (tree)
  26   (case (car tree)
  27     (immediate (simplify-immediate tree))
  28     (register-list (simplify-register-list tree))
  29     (absolute (simplify-absolute tree))
  30     (indirect (simplify-indirect tree))
  31     (t tree)))
  32
  33 ;;;; Addressing mode simplifiers.
  34
  35 (defun simplify-immediate (tree)
  36   (assert (and (eql (car tree) 'immediate)
  37                (eql (caadr tree) 'hash)))
  38   (list 'immediate (simplify-expression (third tree))))
  39
  40 (defun simplify-absolute (tree)
  41   (assert (eql (car tree) 'absolute))
  42   (list 'absolute (simplify-expression (second tree))))
  43
  44 (defun simplify-indirect (tree)
  45   (assert (eql (car tree) 'indirect))
  46   (case (caadr tree)
  47     (displacement-indirect
  48      (cond ((= (length (cadr tree)) 5)
  49             (list (caadr tree) (simplify-expression (second (cadr tree)))
  50                   (fourth (cadr tree))))
  51            ((= (length (cadr tree)) 4)
  52             (list (caadr tree) (third (cadr tree))))
  53            (t (error "Weird parse tree: ~A." tree))))
  54     (indexed-indirect
  55      (cond ((= (length (cadr tree)) 7)
  56             (list (caadr tree) (simplify-expression (second (cadr tree)))
  57                   (fourth (cadr tree)) (sixth (cadr tree))))
  58            ((= (length (cadr tree)) 6)
  59             (list (caadr tree) (third (cadr tree)) (fifth (cadr tree))))
  60            (t (error "Weird parse tree: ~A." tree))))
  61     (postincrement-indirect
  62      (list (caadr tree) (third (cadr tree))))
  63     (predecrement-indirect
  64      (list (caadr tree) (fourth (cadr tree))))
  65     (t (error "Weird indirect: ~A." tree))))
  66
  67 (defun interpolate-registers (start end)
  68   (let ((s (register-idx start :both-sets t))
  69         (e (register-idx end :both-sets t)))
  70     (when (> s e) (psetf s e e s))
  71     (loop for i from s to e
  72           collecting `(register
  73                        ,(cons (car (aref *asm-register-table* i)) nil)))))
  74
  75 ;;; XXX could use some work.
  76 (defun simplify-register-list (tree)
  77   (labels ((simplify (tree)
  78              (assert (eql (car tree) 'register-list))
  79              (cond ((= (length tree) 2) (list 'register-list
  80                                               (second tree)))
  81                    ((= (length tree) 4)
  82                     (cond ((eql (car (third tree)) '/)
  83                            (cons 'register-list
  84                                  (append
  85                                   (cdr (simplify (second tree)))
  86                                   (cdr (simplify (fourth tree))))))
  87                           ((eql (car (third tree)) '-)
  88                            (cons 'register-list
  89                                  (interpolate-registers (second tree)
  90                                                         (fourth tree))))
  91                           (t (error "Strange register list."))))
  92                    (t (error "Strange parse tree.")))))
  93     ;; If this is a register list of a single register, return just
  94     ;; the register.
  95     (let ((v (simplify tree)))
  96       (if (= (length v) 2) (second v) v))))
  97
  98 ;;;; Expression simplifiers.
  99
 100 ;;; Because we know expressions only contain certain kinds of
 101 ;;; elements, we can easily reduce them down to "almost" lisp
 102 ;;; expressions.
 103 (defun simplify-operator (tree)
 104   (assert (member (first tree) '(adding-operator multiplying-operator
 105                                  bitwise-operator unary-operator)))
 106   (car (second tree)))
 107
 108 (defun simplify-value (tree)
 109   (second tree))
 110
 111
 112 ;; XXX change all this stuff to something data driven:
 113 ;;(factor (nil (simplify-value))
 114 ;;      (nil (simplify-operator) (simplify-value))
 115 ;;      (nil nil (simplify-expression) nil))
 116
 117 (defun simplify-factor (tree)
 118   (cond ((= (length tree) 2)
 119          (let ((v (simplify-value (second tree))))
 120            (if (eql (car v) 'constant) (second v) v)))
 121         ((= (length tree) 3) (list (simplify-operator (second tree))
 122                                    (simplify-value (third tree))))
 123         ((= (length tree) 4) (simplify-expression (third tree)))
 124         (t (error "Strange parse tree."))))
 125
 126 (defun simplify-term (tree)
 127   (cond ((= (length tree) 2) (simplify-factor (second tree)))
 128         ((= (length tree) 4)
 129          (list (simplify-operator (third tree))
 130                (simplify-term (second tree))
 131                (simplify-factor (fourth tree))))
 132         (t (error "Strange parse tree."))))
 133
 134 (defun simplify-term2 (tree)
 135   (cond ((= (length tree) 2) (simplify-term (second tree)))
 136         ((= (length tree) 4)
 137          (list (simplify-operator (third tree))
 138                (simplify-term2 (second tree))
 139                (simplify-term (fourth tree))))
 140         (t (error "Strange parse tree."))))
 141
 142 (defun simplify-expression (tree)
 143   (cond ((= (length tree) 2) (simplify-term2 (second tree)))
 144         ((= (length tree) 4)
 145          (list (simplify-operator (third tree))
 146                (simplify-expression (second tree))
 147                (simplify-term2 (fourth tree))))
 148         (t (error "Strange parse tree."))))
 149
 150 ;;;; UNCLUTTER/STRIP-POSITION
 151
 152 (defun unclutter-line (tree)
 153   "Takes a parse tree, strips the individual token position
 154 information, and returns two values -- the uncluttered parse tree, and
 155 a single representative item of position information."
 156   (let ((position nil))
 157     (labels ((strip (branch)
 158                (cond ((atom branch))
 159                      ((terminal-p (car branch))
 160                       (assert (is-position-info-p (third branch)))
 161                       ;; XXX would be nice to improve this "merge" to be
 162                       ;; a bit more heuristic (watch for merging pos from
 163                       ;; separate files, for example... !)
 164                       (when (null position) (setf position (third branch)))
 165                       (setf (cddr branch) nil))
 166                      (t
 167                       (dolist (leaf branch) (strip leaf))))))
 168       (strip tree)
 169       (values tree position))))
 170
 171
 172 ;;;; EOF ast.lisp