Patches for ECL

? README.ecl
? eclx.lisp
? emacs.el
? split-sequence.lisp
Index: clx.lisp
===================================================================
RCS file: /cvsroot/clocc/clocc/src/gui/clx/clx.lisp,v
retrieving revision 1.4
diff -u -r1.4 clx.lisp
--- clx.lisp	6 Aug 2002 07:59:38 -0000	1.4
+++ clx.lisp	14 Dec 2002 17:26:20 -0000
@@ -265,13 +265,16 @@
 
 (def-clx-class (display (:include buffer)
 			(:constructor make-display-internal)
+			#-ecl
 			(:print-function print-display)
 			(:copier nil))
   (host)					; Server Host
   (display 0 :type integer)			; Display number on host
   (after-function nil)				; Function to call after every request
+  #-ecl
   (event-lock
     (make-process-lock "CLX Event Lock"))	; with-event-queue lock
+  #-ecl
   (event-queue-lock
     (make-process-lock "CLX Event Queue Lock"))	; new-events/event-queue lock
   (event-queue-tail				; last event in the event queue
Index: clx.system
===================================================================
RCS file: /cvsroot/clocc/clocc/src/gui/clx/clx.system,v
retrieving revision 1.5
diff -u -r1.5 clx.system
--- clx.system	29 Aug 2002 07:32:25 -0000	1.5
+++ clx.system	14 Dec 2002 17:26:20 -0000
@@ -2,7 +2,6 @@
 
 (in-package "COMMON-LISP-USER")
 
-(pushnew :clx-debugging *features*)
 
 (mk:defsystem :clx
     :source-pathname "cl-library:clx;"
Index: dependent.lisp
===================================================================
RCS file: /cvsroot/clocc/clocc/src/gui/clx/dependent.lisp,v
retrieving revision 1.7
diff -u -r1.7 dependent.lisp
--- dependent.lisp	29 Mar 2002 20:44:54 -0000	1.7
+++ dependent.lisp	14 Dec 2002 17:26:20 -0000
@@ -80,6 +80,7 @@
 
   )
 
+#-ecl
 (declaim (inline card8->int8 int8->card8
 		 card16->int16 int16->card16
 		 card32->int32 int32->card32))
@@ -131,6 +132,7 @@
 
   )
 
+#-ecl
 (declaim (inline aref-card8 aset-card8 aref-int8 aset-int8))
 
 
@@ -371,6 +373,7 @@
 ;;; This stuff transforms chars to ascii codes in card8's and back.
 ;;; You might have to hack it a little to get it to work for your machine.
 
+#-ecl
 (declaim (inline char->card8 card8->char))
 
 (macrolet ((char-translators ()
@@ -492,7 +495,7 @@
 ;;; MAKE-PROCESS-LOCK: Creating a process lock.
 
 (defun make-process-lock (name)
-  #-(or sbcl clisp)
+  #-(or sbcl clisp ecl)
   (port::make-lock :name name))
 
 
@@ -506,6 +509,9 @@
 			      &key timeout)
 			&body body)
   (declare (ignore display whostate timeout))
+  #+ecl
+  `(progn ,@body)
+  #-ecl
   `(port:with-lock (,lock)
      ,@body))
 
@@ -527,6 +533,7 @@
 
 (defun process-block (whostate predicate &rest predicate-args)
   (declare (type function predicate))
+  #-ecl
   (apply #'port:process-wait
          whostate
          predicate
@@ -540,7 +547,7 @@
 
 (defun process-wakeup (process)
   (declare (ignore process))
-  #-(or clisp sbcl)
+  #-(or clisp sbcl ecl)
   (port:process-yield))
 
 ;;; CURRENT-PROCESS: Return the current process object for input locking and
@@ -551,7 +558,7 @@
 ;;; Default return NIL, which is acceptable even if there is a scheduler.
 
 (defun current-process ()
-  #-(or sbcl clisp)
+  #-(or sbcl clisp ecl)
   (port:current-process))
 
 ;;; WITHOUT-INTERRUPTS -- provide for atomic operations.
@@ -620,18 +627,26 @@
              ;;
              ;; clisp doesn't have sockets, but special code for
              ;; X connections:
-             #-clisp
+             #-(or ecl clisp)
              (port::open-unix-socket (format nil
                                              "~A~D"
                                              +X-unix-socket-path+
                                              display)
                                      :kind :stream
                                      :bin t)
+	     #+ecl
+	     (sys::open-unix-socket-stream (format nil
+						   "~A~D"
+						   +X-unix-socket-path+
+						   display))
              ;; clisp doesn't have this...
              #+clisp
              (sys::make-socket-stream "" 0)))))
     (if socket
         socket
+	#+ecl
+	(si::open-client-stream host (+ 6000 display))
+	#-ecl
         ;; try to connect by hand
         (let ((host (host-address host)))
           (when host
@@ -662,6 +677,10 @@
 	      (not (listen (display-input-stream display))))
 	 :timeout)
 	(t
+	 #+ecl
+         (unless (si::read-bytes (display-input-stream display) vector start end)
+	   (error "End of file in stream ~S." (display-input-stream display)))
+	 #-ecl
          (read-sequence vector
                         (display-input-stream display)
                         :start start
@@ -675,6 +694,10 @@
 	   (type display display)
 	   (type array-index start end))
   #.(declare-buffun)
+  #+ecl
+  (unless (si::write-bytes (display-output-stream display) vector start end)
+    (error "Error writing to stream ~S." (display-output-stream display)))
+  #-ecl
   (write-sequence vector
                   (display-output-stream display)
                   :start start
@@ -721,7 +744,7 @@
     (cond ((null stream))
 	  ((listen stream) nil)
 	  ((eql timeout 0) :timeout)
-          #-(or allegro clisp)
+          #-(or allegro clisp ecl)
 	  (t
 	   (if (port::wait-for-stream stream timeout)
 	       nil
@@ -929,7 +952,17 @@
 	     (error "Unknown host ~S" host))
 	   (no-address-error ()
 	     (error "Host ~S has no ~S address" host family)))
-    
+
+    #+ecl
+    (let ((addr (first (nth-value 3 (si::lookup-host-entry (string host))))))
+      (unless addr
+	(no-host-error))
+      (list :internet
+	    (ldb (byte 8 24) addr)
+	    (ldb (byte 8 16) addr)
+	    (ldb (byte 8  8) addr)
+	    (ldb (byte 8  0) addr)))
+    #-ecl    
     (let ((hostent (port:resolve-host-ipaddr (string host))))
       (when (not (port:hostent-addr-list hostent))
 	(no-host-error))
@@ -979,9 +1012,15 @@
 ;;; Utilities 
 
 (defun getenv (name)
+  #+ecl
+  (si:getenv name)
+  #-ecl
   (port:getenv name))
 
 (defun homedir-file-pathname (name)
+  #+ecl
+  (print (merge-pathnames (si::string-concatenate (getenv "HOME") "/") (pathname name)))
+  #-ecl
   (and #-(or unix mach) (search "Unix" (software-type) :test #'char-equal)
        (merge-pathnames
         (translate-logical-pathname
Index: display.lisp
===================================================================
RCS file: /cvsroot/clocc/clocc/src/gui/clx/display.lisp,v
retrieving revision 1.4
diff -u -r1.4 display.lisp
--- display.lisp	29 Aug 2002 07:34:00 -0000	1.4
+++ display.lisp	14 Dec 2002 17:26:20 -0000
@@ -384,7 +384,7 @@
   "This tried to gues what display you need to use.
 Returns the host,the display and the screen
 or NIL if it failed"
-  (let* ((where (port:getenv "DISPLAY"))
+  (let* ((where (#+ecl getenv #-ecl port:getenv "DISPLAY"))
          (parts  (when where
                    (split-sequence:split-sequence #\: where)))
          (host (when parts
Index: macros.lisp
===================================================================
RCS file: /cvsroot/clocc/clocc/src/gui/clx/macros.lisp,v
retrieving revision 1.2
diff -u -r1.2 macros.lisp
--- macros.lisp	13 Jul 2001 04:52:19 -0000	1.2
+++ macros.lisp	14 Dec 2002 17:26:20 -0000
@@ -941,8 +941,12 @@
 ;;; Some macros for threaded lists
 
 (defmacro threaded-atomic-push (item list next type)
+  #-threads
+  `(threaded-push ,item ,list ,next ,type)
+  #+threads
   (let ((x (gensym))
 	(y (gensym)))
+
     `(let ((,x ,item))
        (declare (type ,type ,x))
        (loop
@@ -955,6 +959,9 @@
 	     (return ,x)))))))
 
 (defmacro threaded-atomic-pop (list next type)
+  #-threads
+  `(threaded-pop ,list ,next ,type)
+  #+threads
   (let ((y (gensym)))
     `(loop
        (let ((,y ,list))

Index: ext.lisp
===================================================================
RCS file: /cvsroot/clocc/clocc/src/port/ext.lisp,v
retrieving revision 1.31
diff -u -r1.31 ext.lisp
--- ext.lisp	30 Nov 2002 22:30:22 -0000	1.31
+++ ext.lisp	14 Dec 2002 17:26:58 -0000
@@ -8,7 +8,7 @@
 ;;; See <URL:http://www.gnu.org/copyleft/lesser.html>
 ;;; for details and the precise copyright document.
 ;;;
-;;; $Id: ext.lisp,v 1.31 2002/11/30 22:30:22 sds Exp $
+;;; $Id: ext.lisp,v 1.29 2002/06/18 14:01:30 sds Exp $
 ;;; $Source: /cvsroot/clocc/clocc/src/port/ext.lisp,v $
 
 (defpackage "PORT"
@@ -19,15 +19,18 @@
    "DEFSUBST" "DEFCUSTOM" "DEFCONST"
    "MK-ARR" "MAP-IN" "WITH-GENSYMS"
    "GC" "QUIT"
-   "+EOF+" "EOF-P" "STRING-TOKENS" "REMOVE-PLIST"
+   "+EOF+" "EOF-P" "STRING-TOKENS"
    #-cmu "REQUIRED-ARGUMENT"
    "UNLOCK-PACKAGE" "RESTORE-PACKAGE-LOCK"
    "COMPOSE" "COMPOSE-F" "COMPOSE-ALL"))
 
 (in-package :port)
 
+(setf (logical-pathname-translations "clocc")
+      `(("**;*.*" "~/src/clocc/**/*.*")))
+
 (setf (logical-pathname-translations "port")
-      `(("**;*" ,(logical-pathname "clocc:src;port;**;*"))))
+      `(("**;*.*" ,(logical-pathname "clocc:src;port;**;*.*"))))
 
 ;;;
 ;;; Conditions
@@ -88,11 +91,8 @@
 (defmacro with-gensyms (syms &body body)
   "Bind symbols to gensyms.  First sym is a string - `gensym' prefix.
 Inspired by Paul Graham, <On Lisp>, p. 145."
-  `(let (,@(mapcar (lambda (sy)
-                     `(,sy (gensym ,(concatenate 'string (car syms)
-                                                 (symbol-name sy) "-"))))
-                   (cdr syms)))
-     ,@body))
+  `(let (,@(mapcar (lambda (sy) `(,sy (gensym ,(car syms)))) (cdr syms)))
+    ,@body))
 
 (defmacro map-in (fn seq &rest seqs)
   "`map-into' the first sequence, evaluating it once.
@@ -100,6 +100,7 @@
   (with-gensyms ("MI-" mi)
     `(let ((,mi ,seq)) (map-into ,mi ,fn ,mi ,@seqs))))
 
+#-ecl
 (defun gc ()
   "Invoke the garbage collector."
   #+allegro (excl:gc)
@@ -113,6 +114,7 @@
   #-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
   (error 'not-implemented :proc (list 'gc)))
 
+#-ecl
 (defun quit (&optional code)
   #+allegro (excl:exit code)
   #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
@@ -152,17 +154,6 @@
         (read-from-string (concatenate 'string "(" string ")")
                           t nil :start start))))
 
-(defun remove-plist (plist &rest keys)
-  "Remove the keys from the plist.
-Useful for re-using the &REST arg after removing some options."
-  (do (copy rest)
-      ((null (setq rest (nth-value 2 (get-properties plist keys))))
-       (nreconc copy plist))
-    (do () ((eq plist rest))
-      (push (pop plist) copy)
-      (push (pop plist) copy))
-    (setq plist (cddr plist))))
-
 #+cmu (progn
         (import 'ext:required-argument :port)
         (export 'ext:required-argument :port))
@@ -194,7 +185,11 @@
   `(eval-when (:compile-toplevel :load-toplevel)
      (setf *lock-package-saved-value* lw:*handle-warn-on-redefinition*
            lw:*handle-warn-on-redefinition* nil))
-  #-(or allegro clisp lispworks)
+  #+ecl
+  `(eval-when (:compile-toplevel)
+     (let ((pa (find-package ,pack)))
+       (setf *lock-package-saved-value* (si:package-lock pa t))))
+  #-(or allegro clisp lispworks ecl)
   ;; nothing to be done
   (declare (ignore pack)))
 
@@ -213,7 +208,11 @@
   `(eval-when (:compile-toplevel :load-toplevel)
      (setf lw:*handle-warn-on-redefinition* *lock-package-saved-value*)
      (makunbound '*lock-package-saved-value*))
-  #-(or allegro clisp lispworks)
+  #+ecl
+  `(eval-when (:compile-toplevel)
+     (si:package-lock (find-package ,pack) *lock-package-saved-value*)
+     (makunbound '*lock-package-saved-value*))
+  #-(or allegro clisp lispworks ecl)
   ;; nothing to be done
   (declare (ignore pack)))