[Gcl-commits] gcl debianchangelog cmpnew/gcl_cmpmain.lsp cmpn...

[Camm Maguire]

CVSROOT:        /cvsroot/gcl
Module name:    gcl
Changes by:     Camm Maguire <camm>     06/06/19 00:52:08

Modified files:
        debian         : changelog 
        cmpnew         : gcl_cmpmain.lsp gcl_cmptype.lsp 
        lsp            : gcl_callhash.lsp gcl_iolib.lsp gcl_top.lsp 

Log message:
        integrate temp-file facility into do-recompile

CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/gcl/debian/changelog?cvsroot=gcl&r1=1.1091&r2=1.1092
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmpmain.lsp?cvsroot=gcl&r1=1.48&r2=1.49
http://cvs.savannah.gnu.org/viewcvs/gcl/cmpnew/gcl_cmptype.lsp?cvsroot=gcl&r1=1.35&r2=1.36
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_callhash.lsp?cvsroot=gcl&r1=1.4&r2=1.5
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_iolib.lsp?cvsroot=gcl&r1=1.13&r2=1.14
http://cvs.savannah.gnu.org/viewcvs/gcl/lsp/gcl_top.lsp?cvsroot=gcl&r1=1.17&r2=1.18

Patches:
Index: debian/changelog
===================================================================
RCS file: /cvsroot/gcl/gcl/debian/changelog,v
retrieving revision 1.1091
retrieving revision 1.1092
diff -u -b -r1.1091 -r1.1092
--- debian/changelog    18 Jun 2006 16:16:41 -0000      1.1091
+++ debian/changelog    19 Jun 2006 00:52:07 -0000      1.1092
@@ -182,8 +182,9 @@
     definition to set up the prototype (removes a number of * returns)
   * eq uniq types, values return type autoproclamation support
   * preliminary temp stream facility
+  * integrate temp-file facility into do-recompile
 
- -- Camm Maguire <address@hidden>  Sun, 18 Jun 2006 16:16:21 +0000
+ -- Camm Maguire <address@hidden>  Mon, 19 Jun 2006 00:51:53 +0000
 
 gclcvs (2.7.0-53) unstable; urgency=low
 

Index: cmpnew/gcl_cmpmain.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmpmain.lsp,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -b -r1.48 -r1.49
--- cmpnew/gcl_cmpmain.lsp      5 Jun 2006 22:02:45 -0000       1.48
+++ cmpnew/gcl_cmpmain.lsp      19 Jun 2006 00:52:07 -0000      1.49
@@ -408,26 +408,6 @@
          (values)
          )))))
 
-(defun get-temp-dir ()
-  (dolist (x `(,@(mapcar 'si::getenv #-winnt '("TMPDIR" "TMP") #+winnt 
'("TEMP" "TMP")) #-winnt "/tmp" ""))
-    (when x
-      (let* ((x (pathname x))
-            (x (if (pathname-name x) x 
-                 (merge-pathnames
-                  (make-pathname :directory (butlast (pathname-directory x)) 
-                                 :name (car (last (pathname-directory x))))
-                  x))))
-       (when (directory x) 
-         (return-from 
-          get-temp-dir 
-          (namestring 
-           (make-pathname 
-            :device (pathname-device x)
-            :directory (when (or (pathname-directory x) (pathname-name x))
-                         (append (pathname-directory x) (list (pathname-name 
x))))))))))))
-
-(defvar *tmp-dir* (get-temp-dir))
-
 (defun gazonk-name ()
   (dotimes (i 1000)
     (let ((tem (merge-pathnames 

Index: cmpnew/gcl_cmptype.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/cmpnew/gcl_cmptype.lsp,v
retrieving revision 1.35
retrieving revision 1.36
diff -u -b -r1.35 -r1.36
--- cmpnew/gcl_cmptype.lsp      17 Jun 2006 19:26:58 -0000      1.35
+++ cmpnew/gcl_cmptype.lsp      19 Jun 2006 00:52:07 -0000      1.36
@@ -73,6 +73,7 @@
 (import 'si::proclaim-from-argd 'compiler)
 (import 'si::+array-types+ 'compiler)
 (import 'si::+aet-type-object+ 'compiler)
+(import 'si::*tmp-dir* 'compiler)
 
 (let ((p (find-package "DEFPACKAGE")))
   (when p

Index: lsp/gcl_callhash.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_callhash.lsp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -b -r1.4 -r1.5
--- lsp/gcl_callhash.lsp        17 Jun 2006 19:26:58 -0000      1.4
+++ lsp/gcl_callhash.lsp        19 Jun 2006 00:52:08 -0000      1.5
@@ -3,6 +3,7 @@
 
 (*make-special '*pahl*)
 (*make-special '*boot*)
+(*make-special '*tmp-dir*)
 (eval-when (load eval)
           (setq *pahl* nil)
           (setq *boot* nil))
@@ -23,6 +24,7 @@
             (defvar *needs-recompile* (make-array 10 :fill-pointer 0 
:adjustable t))
             (defvar *ach* (make-hash-table :test 'eq))
             (defvar *acr* (make-hash-table :test 'eq))
+            (setq *tmp-dir* (get-temp-dir))
             (setq *boot* t)
             (mapc 'eval (nreverse *pahl*))
             (setq *pahl* nil))))
@@ -167,12 +169,12 @@
     (dolist (l syms) (add-hash l nil (list (list n)) nil))
     n))
     
+(defun temp-prefix nil
+  (concatenate 'string *tmp-dir* "gazonk_" (write-to-string (abs 
(si::getpid))) "_"))
     
-
-(defun recompile (fn &optional (pn "/tmp/recompile.lsp" pnp))
-  (unless pnp (when (probe-file pn) (delete-file pn)))
-  (with-open-file
-   (s pn :direction :output :if-exists :append :if-does-not-exist :create)
+(defun recompile (fn)
+  (with-temp-file 
+      (s tpn) ((temp-prefix) "lsp")
    (let ((*print-radix* nil)
         (*print-base* 10)
         (*print-circle* t)
@@ -187,24 +189,43 @@
      (let* ((src (function-src fn)))
        (if src (prin1 `(defun ,fn ,@(cdr src)) s)
         (remove-recompile fn))
-       (load (compile-file pn :system-p t :c-file t :h-file t :data-file 
t))))))
+         (let ((o (compile-file tpn)))
+           (load o)
+           (delete-file o))))))
+
+(defun get-temp-dir ()
+  (dolist (x `(,@(mapcar 'si::getenv '("TMPDIR" "TMP" "TEMP")) "/tmp" ""))
+    (when x
+      (let* ((x (pathname x))
+            (x (if (pathname-name x) x 
+                 (merge-pathnames
+                  (make-pathname :directory (butlast (pathname-directory x)) 
+                                 :name (car (last (pathname-directory x))))
+                  x))))
+       (when (directory x) 
+         (return-from 
+          get-temp-dir 
+          (namestring 
+           (make-pathname 
+            :device (pathname-device x)
+            :directory (when (or (pathname-directory x) (pathname-name x))
+                         (append (pathname-directory x) (list (pathname-name 
x))))))))))))
 
-(defun do-recompile (&optional (pn "/tmp/recompile.lsp" pnp))
+(defun do-recompile (&optional pn)
   (unless (or *disable-recompile* (= 0 (length *needs-recompile*)))
     (let ((*disable-recompile* t))
       (clrhash *ach*)
       (clrhash *acr*)
-      (setq *needs-recompile* 
-           (sort *needs-recompile* ;FIXME
+      (sort *needs-recompile*
                  (lambda (x y) 
-                   (member (car x) (all-callees (car y) nil)))))
+             (member (car x) (all-callees (car y) nil))))
       (maphash (lambda (x y) (when (call-sig y) (proclaim `(ftype (function 
,@(call-sig y)) ,x)))) *call-hash-table*)
-      (unless pnp (when (probe-file pn) (delete-file pn)))
       (map nil (lambda (fn)
                 (format t "Callee ~s sigchange ~s to ~s, recompiling ~s~%" 
                         (cadr fn) (caddr fn) (cadddr fn) (car fn))) 
*needs-recompile*)
-       (with-open-file
-       (s pn :direction :output :if-exists :append :if-does-not-exist :create)
+      (let ((f (when pn (open1 pn :direction :output :if-exists :append 
:if-does-not-exist :create))))
+       (with-temp-file 
+           (s tpn) ((temp-prefix) "lsp")
        (let ((*print-radix* nil)
              (*print-base* 10)
              (*print-circle* t)
@@ -219,10 +240,16 @@
          (dotimes (i (length *needs-recompile*))
            (let* ((fn (car (aref *needs-recompile* i)))
                   (src (function-src fn)))
-             (if src (prin1 `(defun ,fn ,@(cdr src)) s)
-               (remove-recompile fn))))))
-      (load (compile-file pn :system-p t :c-file t :h-file t :data-file t)))
-    (do-recompile pn)))
+                 (cond (src 
+                        (prin1 `(defun ,fn ,@(cdr src)) s)
+                        (when f (prin1 `(defun ,fn ,@(cdr src)) f)))
+                       ((remove-recompile fn))))))
+           (when f (close f))
+           (let ((o (compile-file tpn)))
+             (load o)
+             (delete-file o)))))
+    (cond ((> (length *needs-recompile*) 0) (do-recompile pn))
+         (pn (compile-file pn :system-p t :c-file t :h-file t :data-file t)))))
 
 ;FIXME!!!
 (defun is-eq-test-item-list (x y z w)

Index: lsp/gcl_iolib.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_iolib.lsp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -b -r1.13 -r1.14
--- lsp/gcl_iolib.lsp   18 Jun 2006 16:16:41 -0000      1.13
+++ lsp/gcl_iolib.lsp   19 Jun 2006 00:52:08 -0000      1.14
@@ -233,7 +233,7 @@
 (defmacro with-temp-file ((s pn) (tmp ext) &rest body) 
   `(let* ((,s (temp-stream ,tmp ,ext)) 
          (,pn (stream-object1 ,s))) 
-     (unwind-protect (progn ,@body) (close ,s))))
+     (unwind-protect (progn ,@body) (progn (close ,s) (delete-file ,s)))))
 
 (defmacro with-open-file ((stream . filespec) . body)
   (declare (optimize (safety 1)))

Index: lsp/gcl_top.lsp
===================================================================
RCS file: /cvsroot/gcl/gcl/lsp/gcl_top.lsp,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -b -r1.17 -r1.18
--- lsp/gcl_top.lsp     5 Jun 2006 22:02:45 -0000       1.17
+++ lsp/gcl_top.lsp     19 Jun 2006 00:52:08 -0000      1.18
@@ -185,11 +185,8 @@
              (unless (boundp '*system-banner*) (setq *system-banner* 
(default-system-banner))))
            (when (boundp '*system-banner*)
              (format t "~a~%" *system-banner*))
-           (let* ((c (find-package "COMPILER"))
-                  (tmp (and c (find-symbol "*TMP-DIR*" c))))
-             (when tmp
-               (setf (symbol-value tmp) (funcall (find-symbol "GET-TEMP-DIR" 
c)))
-       (format t "Temporary directory for compiler files set to ~a~%" 
(symbol-value tmp))))))
+           (setq *tmp-dir* (get-temp-dir))
+           (format t "Temporary directory for compiler files set to ~a~%" 
*tmp-dir*)))
    (setq *ihs-top* 1)
    (in-package 'system::user) (incf system::*ihs-top* 2)
    (top-level1))