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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Module 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 ;;; Module basics.
  30
  31 (defmethod module-import ((module module))
  32   (dolist (item (module-items module))
  33     (module-import item)))
  34
  35 (defmethod add-to-module ((module module) item)
  36   (setf (module-items module)
  37         (nconc (module-items module) (list item)))
  38   (module-import item))
  39
  40 (defmethod shared-initialize :after ((module module) slot-names &key pset)
  41   "Tick off known properties on the property set."
  42   (declare (ignore slot-names))
  43   (dolist (prop '(:guard))
  44     (get-property pset prop nil)))
  45
  46 (defmethod finalize-module ((module module))
  47   (let* ((pset (module-pset module))
  48          (class (get-property pset :lisp-class :symbol 'module)))
  49
  50     ;; Always call `change-class', even if it's the same one; this will
  51     ;; exercise the property-set fiddling in `shared-initialize' and we can
  52     ;; catch unknown-property errors.
  53     (change-class module class :state t :pset pset)
  54     (check-unused-properties pset)
  55     module))
  56
  57 ;;;--------------------------------------------------------------------------
  58 ;;; Module objects.
  59
  60 (defparameter *module-map* (make-hash-table :test #'equal)
  61   "Hash table mapping true names to module objects.")
  62
  63 (defun build-module
  64     (name thunk &key (truename (probe-file name)) location)
  65   "Construct a new module.
  66
  67    This is the functionality underlying `define-module'."
  68
  69   (let ((*module* (make-instance 'module
  70                                  :name (pathname name)
  71                                  :state (file-location location))))
  72     (when truename
  73       (setf (gethash truename *module-map*) *module*))
  74     (unwind-protect
  75          (call-with-module-environment (lambda ()
  76                                          (module-import *builtin-module*)
  77                                          (funcall thunk)
  78                                          (finalize-module *module*)))
  79       (when (and truename (not (eq (module-state *module*) t)))
  80         (remhash truename *module-map*)))))
  81
  82 ;;;--------------------------------------------------------------------------
  83 ;;; Type definitions.
  84
  85 (export 'type-item)
  86 (defclass type-item ()
  87   ((name :initarg :name :type string :reader type-name))
  88   (:documentation
  89    "A note that a module exports a type.
  90
  91    We can only export simple types, so we only need to remember the name.
  92    The magic simple-type cache will ensure that we get the same type object
  93    when we do the import."))
  94
  95 (defmethod module-import ((item type-item))
  96   (let* ((name (type-name item))
  97          (def (gethash name *module-type-map*))
  98          (type (make-simple-type name)))
  99     (cond ((not def)
 100            (setf (gethash name *module-type-map*) type))
 101           ((not (eq def type))
 102            (error "Conflicting types `~A'" name)))))
 103
 104 (defmethod module-import ((class sod-class))
 105   (record-sod-class class))
 106
 107 ;;;--------------------------------------------------------------------------
 108 ;;; Code fragments.
 109
 110 (export 'c-fragment)
 111 (defclass c-fragment ()
 112   ((location :initarg :location :type file-location
 113              :accessor c-fragment-location)
 114    (text :initarg :text :type string :accessor c-fragment-text))
 115   (:documentation
 116    "Represents a fragment of C code to be written to an output file.
 117
 118    A C fragment is aware of its original location, and will bear proper #line
 119    markers when written out."))
 120
 121 (defun output-c-excursion (stream location thunk)
 122   "Invoke THUNK surrounding it by writing #line markers to STREAM.
 123
 124    The first marker describes LOCATION; the second refers to the actual
 125    output position in STREAM.  If LOCATION doesn't provide a line number then
 126    no markers are output after all.  If the output stream isn't
 127    position-aware then no final marker is output."
 128
 129   (let* ((location (file-location location))
 130          (line (file-location-line location))
 131          (filename (file-location-filename location)))
 132     (cond (line
 133            (format stream "~&#line ~D~@[ ~S~]~%" line filename)
 134            (funcall thunk)
 135            (when (typep stream 'position-aware-stream)
 136              (fresh-line stream)
 137              (format stream "~&#line ~D ~S~%"
 138                      (1+ (position-aware-stream-line stream))
 139                      (namestring (stream-pathname stream)))))
 140           (t
 141            (funcall thunk)))))
 142
 143 (defmethod print-object ((fragment c-fragment) stream)
 144   (let ((text (c-fragment-text fragment))
 145         (location (c-fragment-location fragment)))
 146     (if *print-escape*
 147         (print-unreadable-object (fragment stream :type t)
 148           (when location
 149             (format stream "~A " location))
 150           (cond ((< (length text) 40)
 151                  (prin1 text stream) stream)
 152                 (t
 153                  (prin1 (subseq text 0 37) stream)
 154                  (write-string "..." stream))))
 155         (output-c-excursion stream location
 156                             (lambda () (write-string text stream))))))
 157
 158 (defmethod make-load-form ((fragment c-fragment) &optional environment)
 159   (make-load-form-saving-slots fragment :environment environment))
 160
 161 (export 'code-fragment-item)
 162 (defclass code-fragment-item ()
 163   ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
 164    (reason :initarg :reason :type keyword :reader code-fragment-reason)
 165    (name :initarg :name :type t :reader code-fragment-name)
 166    (constraints :initarg :constraints :type list
 167                 :reader code-fragment-constraints))
 168   (:documentation
 169    "A plain fragment of C to be dropped in at top-level."))
 170
 171 (defmacro define-fragment ((reason name) &body things)
 172   (categorize (thing things)
 173       ((constraints (listp thing))
 174        (frags (typep thing '(or string c-fragment))))
 175     (when (null frags)
 176       (error "Missing code fragment"))
 177     (when (cdr frags)
 178       (error "Multiple code fragments"))
 179     `(add-to-module
 180       *module*
 181       (make-instance 'code-fragment-item
 182                      :fragment ',(car frags)
 183                      :name ,name
 184                      :reason ,reason
 185                      :constraints (list ,@(mapcar (lambda (constraint)
 186                                                     (cons 'list constraint))
 187                                                   constraints))))))
 188
 189 ;;;----- That's all, folks --------------------------------------------------