1 files changed, 68 insertions, 0 deletions
diff --git a/cl-support/wcl-patches.lisp b/cl-support/wcl-patches.lisp
new file mode 100644
index 0000000..3e9395c
--- /dev/null
+++ b/cl-support/wcl-patches.lisp
@@ -0,0 +1,68 @@
+(in-package "LISP")
+
+
+;;; The default version of this function has a bug with relative
+;;; pathnames.
+
+(defun pathname->string (p)
+  (let ((dirlist (pathname-directory p)))
+    (format nil "~A~{~A/~}~A~A~A"
+            (case (car dirlist)
+              (:absolute "/")
+              (:relative "./")
+              (:up "../")
+              (t ""))
+            (cdr dirlist)
+            (nil->empty-string (pathname-name p))
+            (if (null (pathname-type p)) "" ".")
+            (nil->empty-string (pathname-type p)))))
+
+
+;;; The default version of this function defaults the C file to the
+;;; wrong directory -- LOAD can't find it.
+
+(defun my-comf (file &key
+                  (output-file (merge-pathnames ".o" file))
+                  (c-file (merge-pathnames ".c" output-file))
+                  (verbose *compile-verbose*)
+                  (print *compile-print*)
+                  (config *config*)
+                  (pic? *pic?*)
+                  only-to-c?)
+  (old-comf file
+	    :output-file output-file
+	    :c-file c-file
+	    :verbose verbose
+	    :print print
+	    :config config
+	    :pic? pic?
+	    :only-to-c? only-to-c?))
+
+(when (not (fboundp 'old-comf))
+  (setf (symbol-function 'old-comf) #'comf)
+  (setf (symbol-function 'comf) #'my-comf))
+
+
+;;; WCL's evaluator tries to macroexpand everything before executing
+;;; anything.  Unfortunately, this does the wrong thing with
+;;; top-level PROGN's -- it tries to expand macros in subforms before
+;;; executing earlier subforms that set up stuff required to do the
+;;; the expansion properly.
+
+(defun eval-1 (form venv fenv tenv benv)
+  (let ((new-form  (macroexpand form *eval-macro-env*)))
+    (if (and (consp new-form)
+	     (eq (car new-form) 'progn))
+	(do ((forms (cdr new-form) (cdr forms)))
+	    ((null (cdr forms)) (eval-1 (car forms) venv fenv tenv benv))
+	    (eval-1 (car forms) venv fenv tenv benv))
+	(let ((expansion (expand new-form)))
+	  (when (and (listp expansion)
+		     (eq (car expansion) 'define-function))
+	    (setf (get (second (second expansion))
+		       :function-definition)
+		  form))
+	  (eval/5 expansion venv fenv tenv benv))
+      )))
+
+