X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/44929d946ed4afd2792bb1355f4bd1226bea6449..12949379840101e2d65883f29c5e8f0f6de49e9c:/src/module-impl.lisp diff --git a/src/module-impl.lisp b/src/module-impl.lisp index 873e091..fc068d3 100644 --- a/src/module-impl.lisp +++ b/src/module-impl.lisp @@ -25,6 +25,56 @@ (cl:in-package #:sod) +;; Establish a standard environment within the body of a module. This is an +;; attempt -- but not a wholly successful one -- to present the same +;; environment to a module independent of the context in which we imported +;; it. + +;;;-------------------------------------------------------------------------- +;;; Module variables. + +(eval-when (:load-toplevel :execute) + (macrolet ((fix (var &optional (value var)) + (once-only (value) + `(add-module-binding ',var (lambda () ,value))))) + + ;; Use `sod-user' package by default. This seems the most useful. Alas, + ;; some tenants might not keep it as tidy as we'd like, but there are + ;; probably useful ways to side-effect the package too. + (fix *package* (find-package "SOD-USER")) + + ;; Stream bindings. Hope that the values we find at load time are + ;; sufficiently sensible. + (fix *debug-io*) + (fix *error-output*) + (fix *query-io*) + (fix *standard-input*) + (fix *standard-output*) + (fix *terminal-io*) + (fix *trace-output*) + + ;; Print state. + (fix *print-array* t) + (fix *print-base* 10) + (fix *print-case* :upcase) + (fix *print-circle* nil) + (fix *print-escape* t) + (fix *print-gensym* t) + (fix *print-length* nil) + (fix *print-level* nil) + (fix *print-lines* nil) + (fix *print-miser-width*) + (fix *print-pretty* t) + (fix *print-radix* nil) + (fix *print-readably* nil) + (fix *print-right-margin*) + + ;; Read state. + (fix *read-base* 10) + (fix *read-eval* t) + (fix *read-suppress* nil) + (fix *readtable* (copy-readtable nil)))) + ;;;-------------------------------------------------------------------------- ;;; Module basics. @@ -56,8 +106,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 +123,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 +153,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 +202,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 +245,10 @@ (prin1 (subseq text 0 37) stream) (write-string "..." stream)))) (output-c-excursion stream location - (lambda () (write-string text stream)))))) + (lambda (stream) + (awhen (file-location-column location) + (dotimes (i it) (write-char #\space stream))) + (write-string text stream)))))) (defmethod make-load-form ((fragment c-fragment) &optional environment) (make-load-form-saving-slots fragment :environment environment)) @@ -199,7 +256,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 +281,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 +298,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