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 @@ ...@@ -43,8 +43,9 @@
((:file "package") ((:file "package")
(:file "depdefs") (:file "depdefs")
(:file "clx") (:file "clx")
#-(or openmcl) (:file "dependent") #-(or openmcl allegro) (:file "dependent")
#+openmcl (:file "dep-openmcl") #+openmcl (:file "dep-openmcl")
#+allegro (:file "dep-allegro")
(:file "macros") (:file "macros")
(:file "bufmac") (:file "bufmac")
(:file "buffer") (:file "buffer")
...@@ -61,6 +62,8 @@ ...@@ -61,6 +62,8 @@
(:file "manager") (:file "manager")
(:file "image") (:file "image")
(:file "resource") (:file "resource")
#+allegro
(:file "excldep" :pathname "excldep.lisp")
(:module extensions (:module extensions
:pathname #.(make-pathname :directory '(:relative)) :pathname #.(make-pathname :directory '(:relative))
:components :components
...@@ -102,7 +105,6 @@ ...@@ -102,7 +105,6 @@
(:legacy-file "exclREADME") (:legacy-file "exclREADME")
(:legacy-file "exclcmac" :pathname "exclcmac.lisp") (:legacy-file "exclcmac" :pathname "exclcmac.lisp")
(:legacy-file "excldepc" :pathname "excldep.c") (:legacy-file "excldepc" :pathname "excldep.c")
(:legacy-file "excldep" :pathname "excldep.lisp")
(:legacy-file "sockcl" :pathname "sockcl.lisp") (:legacy-file "sockcl" :pathname "sockcl.lisp")
(:legacy-file "socket" :pathname "socket.c") (:legacy-file "socket" :pathname "socket.c")
(:legacy-file "defsystem" :pathname "defsystem.lisp") (:legacy-file "defsystem" :pathname "defsystem.lisp")
......
...@@ -36,11 +36,11 @@ ...@@ -36,11 +36,11 @@
(unless *display* (unless *display*
#+:cmu #+:cmu
(multiple-value-setq (*display* *screen*) (ext:open-clx-display)) (multiple-value-setq (*display* *screen*) (ext:open-clx-display))
#+sbcl #+(or sbcl allegro)
(progn (progn
(setf *display* (xlib::open-default-display)) (setf *display* (xlib::open-default-display))
(setf *screen* (xlib:display-default-screen *display*))) (setf *screen* (xlib:display-default-screen *display*)))
#-(or cmu sbcl) #-(or cmu sbcl allegro)
(progn (progn
;; Portable method ;; Portable method
(setf *display* (xlib:open-display (machine-instance))) (setf *display* (xlib:open-display (machine-instance)))
......
This diff is collapsed.
...@@ -400,10 +400,10 @@ ...@@ -400,10 +400,10 @@
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
;; FIXME: maybe we should reevaluate this? ;; FIXME: maybe we should reevaluate this?
(defvar *def-clx-class-use-defclass* (defvar *def-clx-class-use-defclass*
#+Genera t #+(or Genera allegro) t
#+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP) #+(and cmu pcl) '(XLIB:DRAWABLE XLIB:WINDOW XLIB:PIXMAP)
#+(and cmu (not pcl)) nil #+(and cmu (not pcl)) nil
#-(or Genera cmu) nil #-(or Genera cmu allegro) nil
"Controls whether DEF-CLX-CLASS uses DEFCLASS. "Controls whether DEF-CLX-CLASS uses DEFCLASS.
If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of If it is a list, it is interpreted by DEF-CLX-CLASS to be a list of
......
...@@ -30,7 +30,7 @@ ...@@ -30,7 +30,7 @@
(eval-when (eval compile load) (eval-when (eval compile load)
(let ((x '#(1))) (let ((x '#(1)))
(if (not (eq 0 (sys::memref x (if (not (eq 0 (sys::memref x
#.(comp::mdparam 'comp::md-svector-data0-adj) #.(sys::mdparam 'comp::md-lvector-data0-norm)
0 :unsigned-byte))) 0 :unsigned-byte)))
(pushnew :little-endian *features*) (pushnew :little-endian *features*)
(pushnew :big-endian *features*)))) (pushnew :big-endian *features*))))
...@@ -184,6 +184,10 @@ ...@@ -184,6 +184,10 @@
;; Return t if there is a character available for reading or on error, ;; Return t if there is a character available for reading or on error,
;; otherwise return nil. ;; otherwise return nil.
#-(version>= 6 0)
(progn
#-(or (version>= 4 2) mswindows)
(defun fd-char-avail-p (fd) (defun fd-char-avail-p (fd)
(multiple-value-bind (available-p errcode) (multiple-value-bind (available-p errcode)
(comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd) (comp::.primcall-sargs 'sys::filesys excl::fs-char-avail fd)
...@@ -191,6 +195,19 @@ ...@@ -191,6 +195,19 @@
then t then t
else available-p))) 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) (defmacro with-interrupt-checking-on (&body body)
`(locally (declare (optimize (safety 1))) `(locally (declare (optimize (safety 1)))
,@body)) ,@body))
...@@ -199,54 +216,23 @@ ...@@ -199,54 +216,23 @@
;; Start storing at index 'start-index' and read exactly 'length' bytes. ;; Start storing at index 'start-index' and read exactly 'length' bytes.
;; Return t if an error or eof occurred, nil otherwise. ;; Return t if an error or eof occurred, nil otherwise.
(defun fd-read-bytes (fd vector start-index length) (defun fd-read-bytes (fd vector start-index length)
(declare (fixnum fd start-index length) ;; Read from the given stream fd into 'vector', which has element type card8.
(type (simple-array (unsigned-byte 8) (*)) vector)) ;; 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 (with-interrupt-checking-on
(do ((rest length)) (let ((end-index (+ start-index length)))
((eq 0 rest) nil) (loop
(declare (fixnum rest)) (let ((next-index (excl:read-vector vector fd
(multiple-value-bind (numread errcode) :start start-index
(comp::.primcall-sargs 'sys::filesys excl::fs-read-bytes fd vector :end end-index)))
start-index rest) (excl:if* (eq next-index start-index)
(declare (fixnum numread)) then ; end of file before was all filled up
(excl:if* errcode (return t)
then (if (not (eq errcode elseif (eq next-index end-index)
excl::*error-code-interrupted-system-call*)) then ; we're all done
(return t)) (return nil)
elseif (eq 0 numread) else (setq start-index next-index)))))))
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))))
;; special patch for CLX (various process fixes) ;; 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