From 846b7fba5e5be59b682b3bf46934edf95e280624 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Tue, 11 Mar 2014 21:37:01 -0400
Subject: [PATCH] Load and compile CL code using a predictable, standard
 syntax. No more leakage from past files or to future files.

---
 find-system.lisp |  2 +-
 lisp-action.lisp | 13 ++++++++++---
 uiop/stream.lisp |  5 +++++
 3 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/find-system.lisp b/find-system.lisp
index 564d135..a5f6880 100644
--- a/find-system.lisp
+++ b/find-system.lisp
@@ -277,7 +277,7 @@ Going forward, we recommend new users should be using the source-registry.
   (defmacro with-system-definitions ((&optional) &body body)
     `(call-with-system-definitions #'(lambda () ,@body)))
 
-  (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
+  (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *standard-readtable*) (print-pprint-dispatch *standard-print-pprint-dispatch*))
     ;; Tries to load system definition with canonical NAME from PATHNAME.
     (with-system-definitions ()
       (with-standard-io-syntax
diff --git a/lisp-action.lisp b/lisp-action.lisp
index 0622c42..c2b9ffb 100644
--- a/lisp-action.lisp
+++ b/lisp-action.lisp
@@ -33,7 +33,14 @@
   (defclass basic-load-op (operation) ())
   (defclass basic-compile-op (operation)
     ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
-     (flags :initarg :flags :accessor compile-op-flags :initform nil))))
+     (flags :initarg :flags :accessor compile-op-flags :initform nil)))
+
+  (defclass cl-reading-op (operation) ())) ;; operations that read CL source
+  (defmethod perform :around ((o cl-reading-op) (c cl-source-file))
+    (with-standard-io-syntax
+      (let ((*package* (find-package :asdf-user))
+            (*print-readably* nil))
+        (call-next-method))))
 
 ;;; Our default operations: loading into the current lisp image
 (with-upgradability ()
@@ -44,12 +51,12 @@
     ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
     ;; so we need to directly depend on prepare-op for its side-effects in the current image.
     ((selfward-operation :initform '(prepare-op compile-op) :allocation :class)))
-  (defclass compile-op (basic-compile-op downward-operation selfward-operation)
+  (defclass compile-op (basic-compile-op cl-reading-op downward-operation selfward-operation)
     ((selfward-operation :initform 'prepare-op :allocation :class)))
 
   (defclass prepare-source-op (upward-operation sideway-operation)
     ((sideway-operation :initform 'load-source-op :allocation :class)))
-  (defclass load-source-op (basic-load-op downward-operation selfward-operation)
+  (defclass load-source-op (basic-load-op cl-reading-op downward-operation selfward-operation)
     ((selfward-operation :initform 'prepare-source-op :allocation :class)))
 
   (defclass test-op (selfward-operation)
diff --git a/uiop/stream.lisp b/uiop/stream.lisp
index 464e933..bd620e1 100644
--- a/uiop/stream.lisp
+++ b/uiop/stream.lisp
@@ -11,6 +11,7 @@
    #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
    #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
    #:*default-encoding* #:*utf-8-external-format*
+   #:*standard-readtable* #:*standard-print-pprint-dispatch*
    #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
    #:with-output #:output-string #:with-input
    #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
@@ -146,6 +147,10 @@ going through all the proper hooks."
     "The standard readtable, implementing the syntax specified by the CLHS.
 It must never be modified, though only good implementations will even enforce that.")
 
+  (defvar *standard-print-pprint-dispatch* (with-standard-io-syntax *print-pprint-dispatch*)
+    "The standard pprint dispatch table, implementing the syntax specified by the CLHS.
+It must never be modified, though only good implementations will even enforce that.")
+
   (defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
     "Establish safe CL reader options around the evaluation of BODY"
     `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
-- 
1.9.0.279.gdc9e3eb

