;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible 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
(defmethod finalize-module ((module module))
(let* ((pset (module-pset module))
- (class (get-property pset :lisp-class :symbol 'module)))
+ (class (get-property pset :module-class :symbol 'module)))
;; Always call `change-class', even if it's the same one; this will
;; exercise the property-set fiddling in `shared-initialize' and we can
;; catch unknown-property errors.
(change-class module class :state t :pset pset)
- (check-unused-properties pset)
- module))
+ (check-unused-properties pset)))
;;;--------------------------------------------------------------------------
;;; Module objects.
-(defparameter *module-map* (make-hash-table :test #'equal)
+(defvar-unbound *module-map*
"Hash table mapping true names to module objects.")
+(define-clear-the-decks reset-module-map
+ (setf *module-map* (make-hash-table :test #'equal)))
(defun build-module
(name thunk &key (truename (probe-file name)) location)
(when truename
(setf (gethash truename *module-map*) *module*))
(unwind-protect
- (call-with-module-environment (lambda ()
- (module-import *builtin-module*)
- (funcall thunk)
- (finalize-module *module*)))
+ (with-module-environment ()
+ (module-import *builtin-module*)
+ (funcall thunk)
+ (finalize-module *module*)
+ *module*)
(when (and truename (not (eq (module-state *module*) t)))
(remhash truename *module-map*)))))
+(defun call-with-module-environment (thunk &optional (module *module*))
+ "Invoke THUNK with bindings for the module variables in scope.
+
+ This is the guts of `with-module-environment', which you should probably
+ use instead."
+ (progv
+ (mapcar #'car *module-bindings-alist*)
+ (module-variables module)
+ (unwind-protect (funcall thunk)
+ (setf (module-variables module)
+ (mapcar (compose #'car #'symbol-value)
+ *module-bindings-alist*)))))
+
(defun call-with-temporary-module (thunk)
"Invoke THUNK in the context of a temporary module, returning its values.
(let ((*module* (make-instance 'module
:name "<temp>"
:state nil)))
- (call-with-module-environment
- (lambda ()
- (module-import *builtin-module*)
- (funcall thunk)))))
+ (with-module-environment ()
+ (module-import *builtin-module*)
+ (funcall thunk))))
;;;--------------------------------------------------------------------------
;;; Type definitions.
;;;--------------------------------------------------------------------------
;;; Code fragments.
-(export 'c-fragment)
+(export '(c-fragment c-fragment-text))
(defclass c-fragment ()
- ((location :initarg :location :type file-location
- :accessor c-fragment-location)
- (text :initarg :text :type string :accessor c-fragment-text))
+ ((location :initarg :location :type file-location :reader file-location)
+ (text :initarg :text :type string :reader c-fragment-text))
(:documentation
"Represents a fragment of C code to be written to an output file.
A C fragment is aware of its original location, and will bear proper #line
markers when written out."))
-(defun output-c-excursion (stream location thunk)
- "Invoke THUNK surrounding it by writing #line markers to STREAM.
+(defun output-c-excursion (stream location func)
+ "Invoke FUNC surrounding it by writing #line markers to STREAM.
The first marker describes LOCATION; the second refers to the actual
output position in STREAM. If LOCATION doesn't provide a line number then
no markers are output after all. If the output stream isn't
- position-aware then no final marker is output."
-
- (let* ((location (file-location location))
- (line (file-location-line location))
- (filename (file-location-filename location)))
- (cond (line
- (format stream "~&#line ~D~@[ ~S~]~%" line filename)
- (funcall thunk)
- (when (typep stream 'position-aware-stream)
- (fresh-line stream)
- (format stream "~&#line ~D ~S~%"
- (1+ (position-aware-stream-line stream))
- (namestring (stream-pathname stream)))))
- (t
- (funcall thunk)))))
+ position-aware then no final marker is output.
+
+ FUNC is passed the output stream as an argument. Complicated games may be
+ played with interposed streams. Try not to worry about it."
+
+ (flet ((doit (stream)
+ (let* ((location (file-location location))
+ (line (file-location-line location))
+ (filename (file-location-filename location)))
+ (cond (line
+ (when (typep stream 'position-aware-stream)
+ (format stream "~&#line ~D~@[ ~S~]~%" line filename))
+ (funcall func stream)
+ (when (typep stream 'position-aware-stream)
+ (fresh-line stream)
+ (format stream "#line ~D ~S~%"
+ (1+ (position-aware-stream-line stream))
+ (let ((path (stream-pathname stream)))
+ (if path (namestring path)
+ "<sod-output>")))))
+ (t
+ (funcall func stream))))))
+ (print-ugly-stuff stream #'doit)))
(defmethod print-object ((fragment c-fragment) stream)
(let ((text (c-fragment-text fragment))
- (location (c-fragment-location fragment)))
+ (location (file-location fragment)))
(if *print-escape*
(print-unreadable-object (fragment stream :type t)
(when location
(prin1 (subseq text 0 37) stream)
(write-string "..." stream))))
(output-c-excursion stream location
- (lambda () (write-string text stream))))))
+ (lambda (stream) (write-string text stream))))))
(defmethod make-load-form ((fragment c-fragment) &optional environment)
(make-load-form-saving-slots fragment :environment environment))
-(export 'code-fragment-item)
+(export '(code-fragment-item code-fragment code-fragment-reason
+ code-fragment-name code-fragment-constraints))
(defclass code-fragment-item ()
- ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
+ ((fragment :initarg :fragment :type (or string c-fragment)
+ :reader code-fragment)
(reason :initarg :reason :type keyword :reader code-fragment-reason)
(name :initarg :name :type t :reader code-fragment-name)
(constraints :initarg :constraints :type list
(:documentation
"A plain fragment of C to be dropped in at top-level."))
-(defmacro define-fragment ((reason name) &body things)
- (categorize (thing things)
- ((constraints (listp thing))
- (frags (typep thing '(or string c-fragment))))
- (when (null frags)
- (error "Missing code fragment"))
- (when (cdr frags)
- (error "Multiple code fragments"))
- `(add-to-module
- *module*
- (make-instance 'code-fragment-item
- :fragment ',(car frags)
- :name ,name
- :reason ,reason
- :constraints (list ,@(mapcar (lambda (constraint)
- (cons 'list constraint))
- constraints))))))
-
;;;--------------------------------------------------------------------------
;;; File searching.
~mdw / sod / blobdiff