X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/8ce92a8fe2d825830035b39a3dfd60969445e7ea..6eaf78e4c0b4728b464999806f5c109ab32e706b:/src/module-impl.lisp diff --git a/src/module-impl.lisp b/src/module-impl.lisp index 0bf9ff2..44aa0b8 100644 --- a/src/module-impl.lisp +++ b/src/module-impl.lisp @@ -7,7 +7,7 @@ ;;;----- 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 @@ -56,8 +56,10 @@ ;;;-------------------------------------------------------------------------- ;;; 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) @@ -71,9 +73,11 @@ (let ((existing (gethash truename *module-map*))) (cond ((null existing)) ((eq (module-state existing) t) + (when (plusp (module-errors existing)) + (error "Module `~A' contains errors" name)) (return-from build-module existing)) (t - (error "Module ~A already being imported at ~A" + (error "Module `~A' already being imported at ~A" name (module-state existing)))))) ;; Construct the new module. @@ -99,10 +103,14 @@ (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*))))) + (handler-bind ((error (lambda (cond) + (declare (ignore cond)) + (incf (slot-value module 'errors)) + :decline))) + (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. @@ -144,39 +152,35 @@ ;;;-------------------------------------------------------------------------- ;;; Code fragments. -(export '(c-fragment c-fragment-text)) -(defclass c-fragment () - ((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 - (when (typep stream 'position-aware-stream) - (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)) - (let ((path (stream-pathname stream))) - (if path (namestring path) ""))))) - (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) + ""))))) + (t + (funcall func stream)))))) + (print-ugly-stuff stream #'doit))) (defmethod print-object ((fragment c-fragment) stream) (let ((text (c-fragment-text fragment)) @@ -191,7 +195,7 @@ (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)) @@ -199,7 +203,8 @@ (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 @@ -223,10 +228,10 @@ See `find-file' for the grubby details.") (export 'find-file) -(defun find-file (scanner name what thunk) +(defun find-file (home name what thunk) "Find a file called NAME on the module search path, and call THUNK on it. - The file is searched for relative to the SCANNER's current file, and also + The file is searched for relative to the HOME file or directory, and also in the directories mentioned in the `*module-dirs*' list. If the file is found, then THUNK is invoked with two arguments: the name we used to find it (which might be relative to the starting directory) and the truename @@ -240,8 +245,7 @@ THUNK is not invoked with any additional handlers defined." (handler-case - (dolist (dir (cons (pathname (scanner-filename scanner)) *module-dirs*) - (values nil nil)) + (dolist (dir (cons home *module-dirs*) (values nil nil)) (let* ((path (merge-pathnames name dir)) (probe (probe-file path))) (when probe