chiark - git - mdw - sod/blob - src/codegen-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Code generation protocol implementation
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensble Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Temporary names.
  30
  31 (export '(temporary-argument temporary-function))
  32 (defclass temporary-argument (temporary-name) ())
  33 (defclass temporary-function (temporary-name) ())
  34
  35 (export 'temporary-variable)
  36 (defclass temporary-variable (temporary-name)
  37   ((in-use-p :initarg :in-use-p :initform nil
  38              :type boolean :accessor var-in-use-p)))
  39
  40 (defmethod commentify-argument-name ((name temporary-name))
  41   nil)
  42
  43 (export 'temporary-function)
  44 (defun temporary-function ()
  45   "Return a temporary function name."
  46   (make-instance 'temporary-function
  47                  :tag (prog1 *temporary-index* (incf *temporary-index*))))
  48
  49 (defmethod format-temporary-name ((var temporary-name) stream)
  50   (format stream "~A" (temp-tag var)))
  51 (defmethod format-temporary-name ((var temporary-argument) stream)
  52   (format stream "sod__a~A" (temp-tag var)))
  53 (defmethod format-temporary-name ((var temporary-variable) stream)
  54   (format stream "sod__v~A" (temp-tag var)))
  55 (defmethod format-temporary-name ((var temporary-function) stream)
  56   (format stream "sod__f~A" (temp-tag var)))
  57
  58 (defmethod print-object ((var temporary-name) stream)
  59   (if *print-escape*
  60       (print-unreadable-object (var stream :type t)
  61         (prin1 (temp-tag var) stream))
  62       (format-temporary-name var stream)))
  63
  64 ;;;--------------------------------------------------------------------------
  65 ;;; Instruction types.
  66
  67 ;; Compound statements.
  68
  69 (definst if (stream :export t) (condition consequent alternative)
  70   (format-compound-statement (stream consequent alternative)
  71     (format stream "if (~A)" condition))
  72   (when alternative
  73     (format-compound-statement (stream alternative)
  74       (write-string "else" stream))))
  75
  76 (definst while (stream :export t) (condition body)
  77   (format-compound-statement (stream body)
  78     (format stream "while (~A)" condition)))
  79
  80 (definst do-while (stream :export t) (body condition)
  81   (format-compound-statement (stream body :space)
  82     (write-string "do" stream))
  83   (format stream "while (~A);" condition))
  84
  85 ;; Special varargs hacks.
  86
  87 (definst va-start (stream :export t) (ap arg)
  88   (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
  89
  90 (definst va-copy (stream :export t) (to from)
  91   (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
  92
  93 (definst va-end (stream :export t) (ap)
  94   (format stream "va_end(~A);" ap))
  95
  96 ;; Expressions.
  97
  98 (definst call (stream :export t) (func args)
  99   (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
 100
 101 ;;;--------------------------------------------------------------------------
 102 ;;; Code generator objects.
 103
 104 (defclass basic-codegen ()
 105   ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
 106    (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
 107    (temp-index :initarg :temp-index :initform 0
 108                :type fixnum :accessor codegen-temp-index))
 109   (:documentation
 110    "Base class for code generator state.
 111
 112    This contains the bare essentials for supporting the `emit-inst' and
 113    `ensure-var' protocols; see the documentation for those generic functions
 114    for more details.
 115
 116    This class isn't abstract.  A full `codegen' object uses instances of this
 117    to keep track of pending functions which haven't been completed yet.
 118
 119    Just in case that wasn't clear enough: this is nothing to do with the
 120    BASIC language."))
 121
 122 (defmethod emit-inst ((codegen basic-codegen) inst)
 123   (push inst (codegen-insts codegen)))
 124
 125 (defmethod emit-insts ((codegen basic-codegen) insts)
 126   (asetf (codegen-insts codegen) (revappend insts it)))
 127
 128 (defmethod ensure-var ((codegen basic-codegen) name type &optional init)
 129   (let* ((vars (codegen-vars codegen))
 130          (var (find name
 131                     (remove-if-not (lambda (var) (typep var 'var-inst)) vars)
 132                     :key #'inst-name :test #'equal)))
 133     (cond ((not var)
 134            (setf (codegen-vars codegen)
 135                  (cons (make-var-inst name type init) vars)))
 136           ((not (c-type-equal-p type (inst-type var)))
 137            (error "(Internal) Redefining type for variable ~A." name)))
 138     name))
 139
 140 (export 'codegen)
 141 (defclass codegen (basic-codegen)
 142   ((functions :initform nil :type list :accessor codegen-functions)
 143    (stack :initform nil :type list :accessor codegen-stack))
 144   (:documentation
 145    "A full-fat code generator which can generate and track functions.
 146
 147    This is the real deal.  Subclasses may which to attach additional state
 148    for convenience's sake, but this class is self-contained.  It supports the
 149    `codegen-push', `codegen-pop' and `codegen-pop-function' protocols."))
 150
 151 (defmethod codegen-push ((codegen codegen))
 152   (with-slots (vars insts temp-index stack) codegen
 153     (push (make-instance 'basic-codegen
 154                          :vars vars
 155                          :insts insts
 156                          :temp-index temp-index)
 157           stack)
 158     (setf vars nil insts nil temp-index 0)))
 159
 160 (defmethod codegen-pop ((codegen codegen))
 161   (with-slots (vars insts temp-index stack) codegen
 162     (multiple-value-prog1
 163         (values (nreverse vars) (nreverse insts))
 164       (let ((sub (pop stack)))
 165         (setf vars (codegen-vars sub)
 166               insts (codegen-insts sub)
 167               temp-index (codegen-temp-index sub))))))
 168
 169 (defmethod codegen-add-function ((codegen codegen) function)
 170   (with-slots (functions) codegen
 171     (setf functions (nconc functions (list function)))))
 172
 173 (defmethod temporary-var ((codegen basic-codegen) type)
 174   (with-slots (vars temp-index) codegen
 175     (or (some (lambda (var)
 176                 (let ((name (inst-name var)))
 177                   (if (and (not (var-in-use-p name))
 178                            (c-type-equal-p type (inst-type var)))
 179                       name
 180                       nil)))
 181               (remove-if-not (lambda (var) (typep var 'var-inst)) vars))
 182         (let* ((name (make-instance 'temporary-variable
 183                                     :in-use-p t
 184                                     :tag (prog1 temp-index
 185                                            (incf temp-index)))))
 186           (push (make-var-inst name type nil) vars)
 187           name))))
 188
 189 ;;;----- That's all, folks --------------------------------------------------