| 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 Sensible 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 | (define-module-var *temporary-index* 0 |
| 41 | "Index for temporary name generation. |
| 42 | |
| 43 | This is automatically reset to zero before the output functions are |
| 44 | invoked to write a file. This way, we can ensure that the same output |
| 45 | file is always produced from the same input.") |
| 46 | |
| 47 | (define-clear-the-decks reset-codegen-index |
| 48 | (setf *temporary-index* 0)) |
| 49 | |
| 50 | (defmethod commentify-argument-name ((name temporary-name)) |
| 51 | nil) |
| 52 | |
| 53 | (defun temporary-function () |
| 54 | "Return a temporary function name." |
| 55 | (make-instance 'temporary-function |
| 56 | :tag (prog1 *temporary-index* (incf *temporary-index*)))) |
| 57 | |
| 58 | (defmethod format-temporary-name ((var temporary-name) stream) |
| 59 | (format stream "~A" (temp-tag var))) |
| 60 | (defmethod format-temporary-name ((var temporary-argument) stream) |
| 61 | (format stream "sod__a~A" (temp-tag var))) |
| 62 | (defmethod format-temporary-name ((var temporary-variable) stream) |
| 63 | (format stream "sod__v~A" (temp-tag var))) |
| 64 | (defmethod format-temporary-name ((var temporary-function) stream) |
| 65 | (format stream "sod__f~A" (temp-tag var))) |
| 66 | |
| 67 | (defmethod print-object ((var temporary-name) stream) |
| 68 | (if *print-escape* |
| 69 | (print-unreadable-object (var stream :type t) |
| 70 | (prin1 (temp-tag var) stream)) |
| 71 | (format-temporary-name var stream))) |
| 72 | |
| 73 | ;;;-------------------------------------------------------------------------- |
| 74 | ;;; Code generator objects. |
| 75 | |
| 76 | (defclass basic-codegen () |
| 77 | ((vars :initarg :vars :initform nil :type list :accessor codegen-vars) |
| 78 | (insts :initarg :insts :initform nil :type list :accessor codegen-insts) |
| 79 | (temp-index :initarg :temp-index :initform 0 |
| 80 | :type fixnum :accessor codegen-temp-index)) |
| 81 | (:documentation |
| 82 | "Base class for code generator state. |
| 83 | |
| 84 | This contains the bare essentials for supporting the `emit-inst' and |
| 85 | `ensure-var' protocols; see the documentation for those generic functions |
| 86 | for more details. |
| 87 | |
| 88 | This class isn't abstract. A full `codegen' object uses instances of this |
| 89 | to keep track of pending functions which haven't been completed yet. |
| 90 | |
| 91 | Just in case that wasn't clear enough: this is nothing to do with the |
| 92 | BASIC language.")) |
| 93 | |
| 94 | (defmethod emit-inst ((codegen basic-codegen) inst) |
| 95 | (push inst (codegen-insts codegen))) |
| 96 | |
| 97 | (defmethod emit-insts ((codegen basic-codegen) insts) |
| 98 | (asetf (codegen-insts codegen) (revappend insts it))) |
| 99 | |
| 100 | (defmethod emit-decl ((codegen basic-codegen) inst) |
| 101 | (push inst (codegen-vars codegen))) |
| 102 | |
| 103 | (defmethod emit-decls ((codegen basic-codegen) insts) |
| 104 | (asetf (codegen-vars codegen) (revappend insts it))) |
| 105 | |
| 106 | (defmethod ensure-var ((codegen basic-codegen) name type &optional init) |
| 107 | (let* ((vars (codegen-vars codegen)) |
| 108 | (var (find name |
| 109 | (remove-if-not (lambda (var) (typep var 'var-inst)) vars) |
| 110 | :key #'inst-name :test #'equal))) |
| 111 | (cond ((not var) |
| 112 | (setf (codegen-vars codegen) |
| 113 | (cons (make-var-inst name type init) vars))) |
| 114 | ((not (c-type-equal-p type (inst-type var))) |
| 115 | (error "(Internal) Redefining type for variable ~A" name))) |
| 116 | name)) |
| 117 | |
| 118 | (export 'codegen) |
| 119 | (defclass codegen (basic-codegen) |
| 120 | ((functions :initform nil :type list :accessor codegen-functions) |
| 121 | (stack :initform nil :type list :accessor codegen-stack)) |
| 122 | (:documentation |
| 123 | "A full-fat code generator which can generate and track functions. |
| 124 | |
| 125 | This is the real deal. Subclasses may which to attach additional state |
| 126 | for convenience's sake, but this class is self-contained. It supports the |
| 127 | `codegen-push', `codegen-pop' and `codegen-pop-function' protocols.")) |
| 128 | |
| 129 | (defmethod codegen-push ((codegen codegen)) |
| 130 | (with-slots (vars insts temp-index stack) codegen |
| 131 | (push (make-instance 'basic-codegen |
| 132 | :vars vars |
| 133 | :insts insts |
| 134 | :temp-index temp-index) |
| 135 | stack) |
| 136 | (setf vars nil insts nil temp-index 0))) |
| 137 | |
| 138 | (defmethod codegen-pop ((codegen codegen)) |
| 139 | (with-slots (vars insts temp-index stack) codegen |
| 140 | (multiple-value-prog1 |
| 141 | (values (nreverse vars) (nreverse insts)) |
| 142 | (let ((sub (pop stack))) |
| 143 | (setf vars (codegen-vars sub) |
| 144 | insts (codegen-insts sub) |
| 145 | temp-index (codegen-temp-index sub)))))) |
| 146 | |
| 147 | (defmethod codegen-add-function ((codegen codegen) function) |
| 148 | (with-slots (functions) codegen |
| 149 | (setf functions (nconc functions (list function))))) |
| 150 | |
| 151 | (defmethod temporary-var ((codegen basic-codegen) type) |
| 152 | (with-slots (vars temp-index) codegen |
| 153 | (or (some (lambda (var) |
| 154 | (let ((name (inst-name var))) |
| 155 | (if (and (not (var-in-use-p name)) |
| 156 | (c-type-equal-p type (inst-type var))) |
| 157 | name |
| 158 | nil))) |
| 159 | (remove-if-not (lambda (var) (typep var 'var-inst)) vars)) |
| 160 | (let* ((name (make-instance 'temporary-variable |
| 161 | :in-use-p t |
| 162 | :tag (prog1 temp-index |
| 163 | (incf temp-index))))) |
| 164 | (push (make-var-inst name type) vars) |
| 165 | name)))) |
| 166 | |
| 167 | ;;;----- That's all, folks -------------------------------------------------- |