3 ;;; Code generation protocol implementation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensble Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
31 (export '(temporary-argument temporary-function))
32 (defclass temporary-argument (temporary-name) ())
33 (defclass temporary-function (temporary-name) ())
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)))
40 (define-module-var *temporary-index* 0
41 "Index for temporary name generation.
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.")
47 (define-clear-the-decks reset-codegen-index
48 (setf *temporary-index* 0))
50 (defmethod commentify-argument-name ((name temporary-name))
53 (defun temporary-function ()
54 "Return a temporary function name."
55 (make-instance 'temporary-function
56 :tag (prog1 *temporary-index* (incf *temporary-index*))))
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)))
67 (defmethod print-object ((var temporary-name) stream)
69 (print-unreadable-object (var stream :type t)
70 (prin1 (temp-tag var) stream))
71 (format-temporary-name var stream)))
73 ;;;--------------------------------------------------------------------------
74 ;;; Instruction types.
76 ;; Compound statements.
78 ;; HACK: use gensyms for the `condition' slots to avoid leaking the slot
79 ;; names, since the symbol `condition' actually comes from the `common-lisp'
80 ;; package. The `definst' machinery will symbolicate the various associated
81 ;; methods correctly despite this subterfuge.
83 (definst if (stream :export t) (#1=#:cond conseq alt)
84 (format-compound-statement (stream conseq alt)
85 (format stream "if (~A)" #1#))
87 (format-compound-statement (stream alt)
88 (write-string "else" stream))))
90 (definst while (stream :export t) (#1=#:cond body)
91 (format-compound-statement (stream body)
92 (format stream "while (~A)" #1#)))
94 (definst do-while (stream :export t) (body #1=#:cond)
95 (format-compound-statement (stream body :space)
96 (write-string "do" stream))
97 (format stream "while (~A);" #1#))
99 ;; Special varargs hacks.
101 (definst va-start (stream :export t) (ap arg)
102 (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
104 (definst va-copy (stream :export t) (to from)
105 (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
107 (definst va-end (stream :export t) (ap)
108 (format stream "va_end(~A);" ap))
112 ;; HACK: use a gensym for the `func' slot to avoid leaking the slot name,
113 ;; since the symbol `func' is exported from our package.
114 (definst call (stream :export t) (#1=#:func args)
115 (format stream "~A(~@<~{~A~^, ~_~}~:>)" #1# args))
117 ;;;--------------------------------------------------------------------------
118 ;;; Code generator objects.
120 (defclass basic-codegen ()
121 ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
122 (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
123 (temp-index :initarg :temp-index :initform 0
124 :type fixnum :accessor codegen-temp-index))
126 "Base class for code generator state.
128 This contains the bare essentials for supporting the `emit-inst' and
129 `ensure-var' protocols; see the documentation for those generic functions
132 This class isn't abstract. A full `codegen' object uses instances of this
133 to keep track of pending functions which haven't been completed yet.
135 Just in case that wasn't clear enough: this is nothing to do with the
138 (defmethod emit-inst ((codegen basic-codegen) inst)
139 (push inst (codegen-insts codegen)))
141 (defmethod emit-insts ((codegen basic-codegen) insts)
142 (asetf (codegen-insts codegen) (revappend insts it)))
144 (defmethod emit-decl ((codegen basic-codegen) inst)
145 (push inst (codegen-vars codegen)))
147 (defmethod emit-decls ((codegen basic-codegen) insts)
148 (asetf (codegen-vars codegen) (revappend insts it)))
150 (defmethod ensure-var ((codegen basic-codegen) name type &optional init)
151 (let* ((vars (codegen-vars codegen))
153 (remove-if-not (lambda (var) (typep var 'var-inst)) vars)
154 :key #'inst-name :test #'equal)))
156 (setf (codegen-vars codegen)
157 (cons (make-var-inst name type init) vars)))
158 ((not (c-type-equal-p type (inst-type var)))
159 (error "(Internal) Redefining type for variable ~A." name)))
163 (defclass codegen (basic-codegen)
164 ((functions :initform nil :type list :accessor codegen-functions)
165 (stack :initform nil :type list :accessor codegen-stack))
167 "A full-fat code generator which can generate and track functions.
169 This is the real deal. Subclasses may which to attach additional state
170 for convenience's sake, but this class is self-contained. It supports the
171 `codegen-push', `codegen-pop' and `codegen-pop-function' protocols."))
173 (defmethod codegen-push ((codegen codegen))
174 (with-slots (vars insts temp-index stack) codegen
175 (push (make-instance 'basic-codegen
178 :temp-index temp-index)
180 (setf vars nil insts nil temp-index 0)))
182 (defmethod codegen-pop ((codegen codegen))
183 (with-slots (vars insts temp-index stack) codegen
184 (multiple-value-prog1
185 (values (nreverse vars) (nreverse insts))
186 (let ((sub (pop stack)))
187 (setf vars (codegen-vars sub)
188 insts (codegen-insts sub)
189 temp-index (codegen-temp-index sub))))))
191 (defmethod codegen-add-function ((codegen codegen) function)
192 (with-slots (functions) codegen
193 (setf functions (nconc functions (list function)))))
195 (defmethod temporary-var ((codegen basic-codegen) type)
196 (with-slots (vars temp-index) codegen
197 (or (some (lambda (var)
198 (let ((name (inst-name var)))
199 (if (and (not (var-in-use-p name))
200 (c-type-equal-p type (inst-type var)))
203 (remove-if-not (lambda (var) (typep var 'var-inst)) vars))
204 (let* ((name (make-instance 'temporary-variable
206 :tag (prog1 temp-index
207 (incf temp-index)))))
208 (push (make-var-inst name type nil) vars)
211 ;;;----- That's all, folks --------------------------------------------------