Commit f42a0212 authored by mikel's avatar mikel
Browse files

Add support for modern Allegro CL. Should be good for versions >

darcs-hash:20060113053525-6497f-b5faed2ec4b18c47caa091c1dc5749c6fe16e1c1.gz
parent efac2980
......@@ -43,8 +43,9 @@
((:file "package")
(:file "depdefs")
(:file "clx")
#-(or openmcl) (:file "dependent")
#-(or openmcl allegro) (:file "dependent")
#+openmcl (:file "dep-openmcl")
#+allegro (:file "dep-allegro")
(:file "macros")
(:file "bufmac")
(:file "buffer")
......@@ -61,6 +62,8 @@
(:file "manager")
(:file "image")
(:file "resource")
#+allegro
(:file "excldep" :pathname "excldep.lisp")
(:module extensions
:pathname #.(make-pathname :directory '(:relative))
:components
......@@ -102,7 +105,6 @@
(:legacy-file "exclREADME")
(:legacy-file "exclcmac" :pathname "exclcmac.lisp")
(:legacy-file "excldepc" :pathname "excldep.c")
(:legacy-file "excldep" :pathname "excldep.lisp")
(:legacy-file "sockcl" :pathname "sockcl.lisp")
(:legacy-file "socket" :pathname "socket.c")
(:legacy-file "defsystem" :pathname "defsystem.lisp")
......
......@@ -36,11 +36,11 @@
(unless *display*
#+:cmu
(multiple-value-setq (*display* *screen*) (ext:open-clx-display))
#+sbcl
#+(or sbcl allegro)
(progn
(setf *display* (xlib::open-default-display))
(setf *screen* (xlib:display-default-screen *display*)))
#-(or cmu sbcl)
#-(or cmu sbcl allegro)
(progn
;; Portable method
(setf *display* (xlib:open-display (machine-instance)))
......
This diff is collapsed.
......@@ -400,10 +400,10 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
;; FIXME: maybe we should reevaluate this?
(defvar *def-clx-class-use-defclass*
#+Genera t
#+(or Genera allegro) t
#+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
#+(and cmu (not pcl)) nil
#-(or Genera cmu) nil
#-(or Genera cmu allegro) nil
"Controls whether DEF-CLX-CLASS uses DEFCLASS.
If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of
......
......@@ -30,7 +30,7 @@
(eval-when (eval compile load)
(let ((x '#(1)))
(if (not (eq 0 (sys::memref x
#.(comp::mdparam 'comp::md-svector-data0-adj)
#.(sys::mdparam 'comp::md-lvector-data0-norm)
0 :unsigned-byte)))
(pushnew :little-endian *features*)
(pushnew :big-endian *features*))))
......@@ -184,6 +184,10 @@
;; Return t if there is a character available for reading or on error,
;; otherwise return nil.
#-(version>= 6 0)
(progn
#-(or (version>= 4 2) mswindows)
(defun fd-char-avail-p (fd)
(multiple-value-bind (available-p errcode)
(comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
......@@ -191,6 +195,19 @@
then t
else available-p)))
#+(and (version>= 4 2) (not mswindows))
(defun fd-char-avail-p (fd)
(excl::filesys-character-available-p fd))
#+mswindows
(defun fd-char-avail-p (socket-stream)
(listen socket-stream))
)
#+(version>= 6 0)
(defun fd-char-avail-p (socket-stream)
(excl::read-no-hang-p socket-stream))
(defmacro with-interrupt-checking-on (&body body)
`(locally (declare (optimize (safety 1)))
,@body))
......@@ -199,54 +216,23 @@
;; Start storing at index 'start-index' and read exactly 'length' bytes.
;; Return t if an error or eof occurred, nil otherwise.
(defun fd-read-bytes (fd vector start-index length)
(declare (fixnum fd start-index length)
(type (simple-array (unsigned-byte 8) (*)) vector))
;; Read from the given stream fd into 'vector', which has element type card8.
;; Start storing at index 'start-index' and read exactly 'length' bytes.
;; Return t if an error or eof occurred, nil otherwise.
(declare (fixnum next-index start-index length))
(with-interrupt-checking-on
(do ((rest length))
((eq 0 rest) nil)
(declare (fixnum rest))
(multiple-value-bind (numread errcode)
(comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector
start-index rest)
(declare (fixnum numread))
(excl:if* errcode
then (if (not (eq errcode
excl::*error-code-interrupted-system-call*))
(return t))
elseif (eq 0 numread)
then (return t)
else (decf rest numread)
(incf start-index numread))))))
(when (plusp (ff:get-entry-points
(make-array 1 :initial-contents
(list (ff:convert-to-lang "fd_wait_for_input")))
(make-array 1 :element-type '(unsigned-byte 32))))
(ff:remove-entry-point (ff:convert-to-lang "fd_wait_for_input"))
(load "excldep.o"))
(when (plusp (ff:get-entry-points
(make-array 1 :initial-contents
(list (ff:convert-to-lang "connect_to_server")))
(make-array 1 :element-type '(unsigned-byte 32))))
(ff:remove-entry-point (ff:convert-to-lang "connect_to_server" :language :c))
(load "socket.o"))
(ff:defforeign-list `((connect-to-server
:entry-point
,(ff:convert-to-lang "connect_to_server")
:return-type :fixnum
:arg-checking nil
:arguments (string fixnum))
(fd-wait-for-input
:entry-point ,(ff:convert-to-lang "fd_wait_for_input")
:return-type :fixnum
:arg-checking nil
:call-direct t
:callback nil
:allow-other-keys t
:arguments (fixnum fixnum))))
(let ((end-index (+ start-index length)))
(loop
(let ((next-index (excl:read-vector vector fd
:start start-index
:end end-index)))
(excl:if* (eq next-index start-index)
then ; end of file before was all filled up
(return t)
elseif (eq next-index end-index)
then ; we're all done
(return nil)
else (setq start-index next-index)))))))
;; special patch for CLX (various process fixes)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment