Re: 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	15 Dec 2002 13:52:47 -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: 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	15 Dec 2002 13:52:47 -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	15 Dec 2002 13:52:47 -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	15 Dec 2002 13:52:48 -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))

I have hacked the CLOCC version of CLX to run with ECL. I (the
maintainer of ECL) am responsible for the errors introduced in this
version. I will try my fixes be included in the CLOCC library,
although this has low priority right now because the rest of CLOCC
does not work with ECL.

To compile CLX follow these steps:

1) Compile and install ECL

2) Start an ECL session

3) Type, at the prompt,
	(load "eclx.lsp")
   This should compile all files.

4) To test it, make sure you have a X windows server running and do
	(load "eclx.so")
	(load "demo/hello.lisp")
	(xlib::hello-world "")

5) Copy the library (either eclx.so or eclx.a) to your ECL system
   directory, $(prefix)/lib/ecl/

You can also run CLX interpreted. Just do
    (defvar *only-load* t)
    (load "eclx.lsp")
The HELLO-WORLD application should now work.

Please report any errors regarding CLX to the ECL mailing list
([email protected]).

Happy hacking!

      Juanjo

;;;; SPLIT-SEQUENCE
;;;
;;; This code was based on Arthur Lemmens' in
;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
;;;
;;; changes include:
;;;
;;; * altering the behaviour of the :from-end keyword argument to
;;; return the subsequences in original order, for consistency with
;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
;;; affects the answer if :count is less than the number of
;;; subsequences, by analogy with the above-referenced functions).
;;;   
;;; * changing the :maximum keyword argument to :count, by analogy
;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
;;;
;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
;;; than SPLIT.
;;;
;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
;;;
;;; * The second return value is now an index rather than a copy of a
;;; portion of the sequence; this index is the `right' one to feed to
;;; CL:SUBSEQ for continued processing.

;;; There's a certain amount of code duplication here, which is kept
;;; to illustrate the relationship between the SPLIT-SEQUENCE
;;; functions and the CL:POSITION functions.

;;; Examples:
;;;
;;; * (split-sequence #\; "a;;b;c")
;;; -> ("a" "" "b" "c"), 6
;;;
;;; * (split-sequence #\; "a;;b;c" :from-end t)
;;; -> ("a" "" "b" "c"), 0
;;;
;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
;;; -> ("c"), 4
;;;
;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
;;; -> ("a" "b" "c"), 6
;;;
;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
;;;
;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
;;; -> ("ab" "a" "a" "ab" "a"), 11 
;;;
;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
;;; -> ("oo" "bar" "b"), 9

(defpackage "SPLIT-SEQUENCE"
  (:use "CL")
  (:nicknames "PARTITION")
  (:export "SPLIT-SEQUENCE" "SPLIT-SEQUENCE-IF" "SPLIT-SEQUENCE-IF-NOT"
	   "PARTITION" "PARTITION-IF" "PARTITION-IF-NOT"))

(in-package "SPLIT-SEQUENCE")

(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
  "Return a list of subsequences in seq delimited by delimiter.

If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded.  All other keywords
work analogously to those for CL:SUBSTITUTE.  In particular, the
behaviour of :from-end is possibly different from other versions of
this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
  (let ((len (length seq))
        (other-keys (nconc (when test-supplied 
                             (list :test test))
                           (when test-not-supplied 
                             (list :test-not test-not))
                           (when key-supplied 
                             (list :key key)))))
    (unless end (setq end len))
    (if from-end
        (loop for right = end then left
              for left = (max (or (apply #'position delimiter seq 
					 :end right
					 :from-end t
					 other-keys)
				  -1)
			      (1- start))
              unless (and (= right (1+ left))
                          remove-empty-subseqs) ; empty subseq we don't want
              if (and count (>= nr-elts count))
              ;; We can't take any more. Return now.
              return (values (nreverse subseqs) right)
              else 
              collect (subseq seq (1+ left) right) into subseqs
              and sum 1 into nr-elts
              until (< left start)
              finally (return (values (nreverse subseqs) (1+ left))))
      (loop for left = start then (+ right 1)
            for right = (min (or (apply #'position delimiter seq 
					:start left
					other-keys)
				 len)
			     end)
            unless (and (= right left) 
                        remove-empty-subseqs) ; empty subseq we don't want
            if (and count (>= nr-elts count))
            ;; We can't take any more. Return now.
            return (values subseqs left)
            else
            collect (subseq seq left right) into subseqs
            and sum 1 into nr-elts
            until (>= right end)
            finally (return (values subseqs right))))))

(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
  "Return a list of subsequences in seq delimited by items satisfying
predicate.

If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded.  All other keywords
work analogously to those for CL:SUBSTITUTE-IF.  In particular, the
behaviour of :from-end is possibly different from other versions of
this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
  (let ((len (length seq))
        (other-keys (when key-supplied 
		      (list :key key))))
    (unless end (setq end len))
    (if from-end
        (loop for right = end then left
              for left = (max (or (apply #'position-if predicate seq 
					 :end right
					 :from-end t
					 other-keys)
				  -1)
			      (1- start))
              unless (and (= right (1+ left))
                          remove-empty-subseqs) ; empty subseq we don't want
              if (and count (>= nr-elts count))
              ;; We can't take any more. Return now.
              return (values (nreverse subseqs) right)
              else 
              collect (subseq seq (1+ left) right) into subseqs
              and sum 1 into nr-elts
              until (< left start)
              finally (return (values (nreverse subseqs) (1+ left))))
      (loop for left = start then (+ right 1)
            for right = (min (or (apply #'position-if predicate seq 
					:start left
					other-keys)
				 len)
			     end)
            unless (and (= right left) 
                        remove-empty-subseqs) ; empty subseq we don't want
            if (and count (>= nr-elts count))
            ;; We can't take any more. Return now.
            return (values subseqs left)
            else
            collect (subseq seq left right) into subseqs
            and sum 1 into nr-elts
            until (>= right end)
            finally (return (values subseqs right))))))

(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
  "Return a list of subsequences in seq delimited by items satisfying
(CL:COMPLEMENT predicate).

If :remove-empty-subseqs is NIL, empty subsequences will be included
in the result; otherwise they will be discarded.  All other keywords
work analogously to those for CL:SUBSTITUTE-IF-NOT.  In particular,
the behaviour of :from-end is possibly different from other versions
of this function; :from-end values of NIL and T are equivalent unless
:count is supplied. The second return value is an index suitable as an
argument to CL:SUBSEQ into the sequence indicating where processing
stopped."
  (let ((len (length seq))
	(other-keys (when key-supplied 
		      (list :key key))))
    (unless end (setq end len))
    (if from-end
        (loop for right = end then left
              for left = (max (or (apply #'position-if-not predicate seq 
					 :end right
					 :from-end t
					 other-keys)
				  -1)
			      (1- start))
              unless (and (= right (1+ left))
                          remove-empty-subseqs) ; empty subseq we don't want
              if (and count (>= nr-elts count))
              ;; We can't take any more. Return now.
              return (values (nreverse subseqs) right)
              else 
              collect (subseq seq (1+ left) right) into subseqs
              and sum 1 into nr-elts
              until (< left start)
              finally (return (values (nreverse subseqs) (1+ left))))
      (loop for left = start then (+ right 1)
            for right = (min (or (apply #'position-if-not predicate seq 
					:start left
					other-keys)
				 len)
			     end)
            unless (and (= right left) 
                        remove-empty-subseqs) ; empty subseq we don't want
            if (and count (>= nr-elts count))
            ;; We can't take any more. Return now.
            return (values subseqs left)
            else
            collect (subseq seq left right) into subseqs
            and sum 1 into nr-elts
            until (>= right end)
            finally (return (values subseqs right))))))

;;; clean deprecation

(defun partition (&rest args)
  (apply #'split-sequence args))

(defun partition-if (&rest args)
  (apply #'split-sequence-if args))

(defun partition-if-not (&rest args)
  (apply #'split-sequence-if-not args))

(define-compiler-macro partition (&whole form &rest args)
  (declare (ignore args))
  (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.")
  form)

(define-compiler-macro partition-if (&whole form &rest args)
  (declare (ignore args))
  (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.")
  form)

(define-compiler-macro partition-if-not (&whole form &rest args)
  (declare (ignore args))
  (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead")
  form)

(pushnew :split-sequence *features*)

;;; -*- Mode: Lisp; Package: USER; Base: 10; Syntax: Common-Lisp -*-

(in-package "COMMON-LISP-USER")

(load "sys:cmp.so")

;;; Aid function:

(defvar *only-load* nil)

;;; Then compile and load the true system:

(proclaim '(optimize (safety 2) (speed 1)))

(let* ((files (list 
	       "split-sequence"
               "package"
               "depdefs"
               "clx"
               "dependent"
               "macros"				; these are just macros
               "bufmac"				; these are just macros
               "buffer"
               "display"
               "gcontext"
               "input"
               "requests"
               "fonts"
               "graphics"
               "text"
               "attributes"
               "translate"
               "keysyms"
               "manager"
               "image"
               "resource"))
       (objects (mapcar #'(lambda (x)
			    (load (setq x (merge-pathnames ".lisp" x)))
			    (unless *only-load*
			      (compile-file x :system-p t)))
			files)))
  (unless *only-load*
    #-dlopen
    (c::build-static-library "eclx" :lisp-files objects)
    #+dlopen
    (c::build-shared-library "eclx" :lisp-files objects)))

;(load "clx2/demo/hello.lisp")
;(xlib::hello-world "")

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	15 Dec 2002 14:00:52 -0000
@@ -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)
@@ -194,7 +196,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 +219,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)))