Major effort to plug slot-name leaks.

[sod] / src / codegen-impl.lisp

;;; -*-lisp-*-
;;;
;;; Code generation protocol implementation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Temporary names.

(export '(temporary-argument temporary-function))
(defclass temporary-argument (temporary-name) ())
(defclass temporary-function (temporary-name) ())

(export 'temporary-variable)
(defclass temporary-variable (temporary-name)
  ((in-use-p :initarg :in-use-p :initform nil
             :type boolean :accessor var-in-use-p)))

(defmethod commentify-argument-name ((name temporary-name))
  nil)

(defun temporary-function ()
  "Return a temporary function name."
  (make-instance 'temporary-function
                 :tag (prog1 *temporary-index* (incf *temporary-index*))))

(defmethod format-temporary-name ((var temporary-name) stream)
  (format stream "~A" (temp-tag var)))
(defmethod format-temporary-name ((var temporary-argument) stream)
  (format stream "sod__a~A" (temp-tag var)))
(defmethod format-temporary-name ((var temporary-variable) stream)
  (format stream "sod__v~A" (temp-tag var)))
(defmethod format-temporary-name ((var temporary-function) stream)
  (format stream "sod__f~A" (temp-tag var)))

(defmethod print-object ((var temporary-name) stream)
  (if *print-escape*
      (print-unreadable-object (var stream :type t)
        (prin1 (temp-tag var) stream))
      (format-temporary-name var stream)))

;;;--------------------------------------------------------------------------
;;; Instruction types.

;; Compound statements.

;; HACK: use gensyms for the `condition' slots to avoid leaking the slot
;; names, since the symbol `condition' actually comes from the `common-lisp'
;; package.  The `definst' machinery will symbolicate the various associated
;; methods correctly despite this subterfuge.

(definst if (stream :export t) (#1=#:condition consequent alternative)
  (format-compound-statement (stream consequent alternative)
    (format stream "if (~A)" #1#))
  (when alternative
    (format-compound-statement (stream alternative)
      (write-string "else" stream))))

(definst while (stream :export t) (#1=#:condition body)
  (format-compound-statement (stream body)
    (format stream "while (~A)" #1#)))

(definst do-while (stream :export t) (body #1=#:condition)
  (format-compound-statement (stream body :space)
    (write-string "do" stream))
  (format stream "while (~A);" #1#))

;; Special varargs hacks.

(definst va-start (stream :export t) (ap arg)
  (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))

(definst va-copy (stream :export t) (to from)
  (format stream "va_copy(~@<~A, ~_~A~:>);" to from))

(definst va-end (stream :export t) (ap)
  (format stream "va_end(~A);" ap))

;; Expressions.

;; HACK: use a gensym for the `func' slot to avoid leaking the slot name,
;; since the symbol `func' is exported from our package.
(definst call (stream :export t) (#1=#:func args)
  (format stream "~A(~@<~{~A~^, ~_~}~:>)" #1# args))

;;;--------------------------------------------------------------------------
;;; Code generator objects.

(defclass basic-codegen ()
  ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
   (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
   (temp-index :initarg :temp-index :initform 0
               :type fixnum :accessor codegen-temp-index))
  (:documentation
   "Base class for code generator state.

   This contains the bare essentials for supporting the `emit-inst' and
   `ensure-var' protocols; see the documentation for those generic functions
   for more details.

   This class isn't abstract.  A full `codegen' object uses instances of this
   to keep track of pending functions which haven't been completed yet.

   Just in case that wasn't clear enough: this is nothing to do with the
   BASIC language."))

(defmethod emit-inst ((codegen basic-codegen) inst)
  (push inst (codegen-insts codegen)))

(defmethod emit-insts ((codegen basic-codegen) insts)
  (asetf (codegen-insts codegen) (revappend insts it)))

(defmethod emit-decl ((codegen basic-codegen) inst)
  (push inst (codegen-vars codegen)))

(defmethod emit-decls ((codegen basic-codegen) insts)
  (asetf (codegen-vars codegen) (revappend insts it)))

(defmethod ensure-var ((codegen basic-codegen) name type &optional init)
  (let* ((vars (codegen-vars codegen))
         (var (find name
                    (remove-if-not (lambda (var) (typep var 'var-inst)) vars)
                    :key #'inst-name :test #'equal)))
    (cond ((not var)
           (setf (codegen-vars codegen)
                 (cons (make-var-inst name type init) vars)))
          ((not (c-type-equal-p type (inst-type var)))
           (error "(Internal) Redefining type for variable ~A." name)))
    name))

(export 'codegen)
(defclass codegen (basic-codegen)
  ((functions :initform nil :type list :accessor codegen-functions)
   (stack :initform nil :type list :accessor codegen-stack))
  (:documentation
   "A full-fat code generator which can generate and track functions.

   This is the real deal.  Subclasses may which to attach additional state
   for convenience's sake, but this class is self-contained.  It supports the
   `codegen-push', `codegen-pop' and `codegen-pop-function' protocols."))

(defmethod codegen-push ((codegen codegen))
  (with-slots (vars insts temp-index stack) codegen
    (push (make-instance 'basic-codegen
                         :vars vars
                         :insts insts
                         :temp-index temp-index)
          stack)
    (setf vars nil insts nil temp-index 0)))

(defmethod codegen-pop ((codegen codegen))
  (with-slots (vars insts temp-index stack) codegen
    (multiple-value-prog1
        (values (nreverse vars) (nreverse insts))
      (let ((sub (pop stack)))
        (setf vars (codegen-vars sub)
              insts (codegen-insts sub)
              temp-index (codegen-temp-index sub))))))

(defmethod codegen-add-function ((codegen codegen) function)
  (with-slots (functions) codegen
    (setf functions (nconc functions (list function)))))

(defmethod temporary-var ((codegen basic-codegen) type)
  (with-slots (vars temp-index) codegen
    (or (some (lambda (var)
                (let ((name (inst-name var)))
                  (if (and (not (var-in-use-p name))
                           (c-type-equal-p type (inst-type var)))
                      name
                      nil)))
              (remove-if-not (lambda (var) (typep var 'var-inst)) vars))
        (let* ((name (make-instance 'temporary-variable
                                    :in-use-p t
                                    :tag (prog1 temp-index
                                           (incf temp-index)))))
          (push (make-var-inst name type nil) vars)
          name))))

;;;----- That's all, folks --------------------------------------------------