#:*asdf-revision*
#:operation-error #:compile-failed #:compile-warned #:compile-error
+ #:error-component #:error-operation
#:system-definition-error
#:missing-component
#:missing-dependency
(c-string-pointer name "char *" "p_name")
((* (* t)) aliases "char **" "p_aliases")
(integer proto "int" "p_proto")))
- (:function getprotobyname ("getprotobyname" (* t)
+ (:function getprotobyname ("getprotobyname" (* protoent)
(name c-string)))
(:integer inaddr-any "INADDR_ANY")
(:structure in-addr ("struct in_addr"
;(define-condition no-recovery-error (socket-error)) ; name server error
;(define-condition try-again-error (socket-error)) ; temporary
-(defun get-host-by-name (host-name)
- "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition.
-HOST-NAME may also be an IP address in dotted quad notation or some other
-weird stuff - see gethostbyname(3) for grisly details."
- (make-host-ent (sockint::gethostbyname host-name)))
-
-(defun get-host-by-address (address)
- "Returns a HOST-ENT instance for ADDRESS, which should be a vector of
- (integer 0 255), or throws some kind of error. See gethostbyaddr(3) for
-grisly details."
- (sockint::with-in-addr packed-addr ()
- (let ((addr-vector (coerce address 'vector)))
- (loop for i from 0 below (length addr-vector)
- do (setf (sb-alien:deref (sockint::in-addr-addr packed-addr) i)
- (elt addr-vector i)))
- (make-host-ent (sockint::gethostbyaddr packed-addr
- 4
- sockint::af-inet)))))
-
(defun make-host-ent (h)
(if (sb-grovel::foreign-nullp h) (name-service-error "gethostbyname"))
(let* ((length (sockint::hostent-length h))
for al = (sb-alien:deref (sockint::hostent-aliases h) i)
while al
collect al))
- (address0 (sockint::hostent-addresses h))
(addresses
(loop for i = 0 then (1+ i)
- for ad = (sb-alien:deref address0 i)
+ for ad = (sb-alien:deref (sockint::hostent-addresses h) i)
until (sb-alien:null-alien ad)
collect (ecase (sockint::hostent-type h)
(#.sockint::af-inet
:aliases aliases
:addresses addresses)))
+(defun get-host-by-name (host-name)
+ "Returns a HOST-ENT instance for HOST-NAME or throws some kind of condition.
+HOST-NAME may also be an IP address in dotted quad notation or some other
+weird stuff - see gethostbyname(3) for grisly details."
+ (make-host-ent (sockint::gethostbyname host-name)))
+
+(defun get-host-by-address (address)
+ "Returns a HOST-ENT instance for ADDRESS, which should be a vector of
+ (integer 0 255), or throws some kind of error. See gethostbyaddr(3) for
+grisly details."
+ (sockint::with-in-addr packed-addr ()
+ (let ((addr-vector (coerce address 'vector)))
+ (loop for i from 0 below (length addr-vector)
+ do (setf (sb-alien:deref (sockint::in-addr-addr packed-addr) i)
+ (elt addr-vector i)))
+ (make-host-ent (sockint::gethostbyaddr packed-addr
+ 4
+ sockint::af-inet)))))
+
;;; The remainder is my fault - gw
(defvar *name-service-errno* 0
(defclass grovel-constants-file (asdf:cl-source-file)
((package :accessor constants-package :initarg :package)))
+(define-condition c-compile-failed (compile-failed) ()
+ (:report (lambda (c s)
+ (format s "~@<C compiler failed when performing ~A on ~A.~@:>"
+ (error-operation c) (error-component c)))))
+(define-condition a-dot-out-failed (compile-failed) ()
+ (:report (lambda (c s)
+ (format s "~@<a.out failed when performing ~A on ~A.~@:>"
+ (error-operation c) (error-component c)))))
+
(defmethod asdf:perform ((op asdf:compile-op)
(component grovel-constants-file))
;; we want to generate all our temporary files in the fasl directory
(terpri)
(funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
filename tmp-c-source (constants-package component))
- (and
- (= (run-shell-command "gcc ~A -o ~S ~S"
- (if (sb-ext:posix-getenv "EXTRA_CFLAGS")
- (sb-ext:posix-getenv "EXTRA_CFLAGS")
- "")
- (namestring tmp-a-dot-out)
- (namestring tmp-c-source)) 0)
- (= (run-shell-command "~A >~A"
- (namestring tmp-a-dot-out)
- (namestring tmp-constants)) 0)
- (compile-file tmp-constants :output-file output-file))))
+ (let ((code (run-shell-command "gcc ~A -o ~S ~S"
+ (if (sb-ext:posix-getenv "EXTRA_CFLAGS")
+ (sb-ext:posix-getenv "EXTRA_CFLAGS")
+ "")
+ (namestring tmp-a-dot-out)
+ (namestring tmp-c-source))))
+ (unless (= code 0)
+ (case (operation-on-failure op)
+ (:warn (warn "~@<C compiler failure when performing ~A on ~A.~@:>"
+ op component))
+ (:error
+ (error 'c-compile-failed :operation op :component component)))))
+ (let ((code (run-shell-command "~A >~A"
+ (namestring tmp-a-dot-out)
+ (namestring tmp-constants))))
+ (unless (= code 0)
+ (case (operation-on-failure op)
+ (:warn (warn "~@<a.out failure when performing ~A on ~A.~@:>"
+ op component))
+ (:error
+ (error 'a-dot-out-failed :operation op :component component)))))
+ (multiple-value-bind (output warnings-p failure-p)
+ (compile-file tmp-constants :output-file output-file)
+ (when warnings-p
+ (case (operation-on-warnings op)
+ (:warn (warn
+ (formatter "~@<COMPILE-FILE warned while ~
+ performing ~A on ~A.~@:>")
+ op component))
+ (:error (error 'compile-warned :component component :operation op))
+ (:ignore nil)))
+ (when failure-p
+ (case (operation-on-failure op)
+ (:warn (warn
+ (formatter "~@<COMPILE-FILE failed while ~
+ performing ~A on ~A.~@:>")
+ op component))
+ (:error (error 'compile-failed :component component :operation op))
+ (:ignore nil)))
+ (unless output
+ (error 'compile-error :component component :operation op)))))
+
;; unfortunately; and it will only accept unquoted type
;; forms.
`(sb-alien:array ,elt-type ,(or array-size
- (/ size (eval `(sb-alien:alien-size ,elt-type :bytes))))))
- `(vector t))))
+ (/ size (eval `(sb-alien:alien-size ,elt-type :bytes))))))
+ t)))
(defun retrieve-type-for (type size table)
(multiple-value-bind (type-fn found)
:type `(array char ,len)
:offset offset
:size len
- :name (gensym "PADDING")))
+ :name (gentemp "PADDING")))
(defun mk-struct (offset &rest children)
- (make-instance 'struct :name (gensym "STRUCT")
+ (make-instance 'struct :name (gentemp "STRUCT")
:children (remove nil children)
:offset offset))
(defun mk-union (offset &rest children)
- (make-instance 'union :name (gensym "UNION")
+ (make-instance 'union :name (gentemp "UNION")
:children (remove nil children)
:offset offset))
(defun mk-val (name type h-type offset size)
(defgeneric accessor-modifier-for (element-type accessor-type))
-(defun identity-1 (thing &rest ignored)
+(defmacro identity-1 (thing &rest ignored)
(declare (ignore ignored))
thing)
(defun (setf identity-1) (new-thing place &rest ignored)
(defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
(accessor-type (eql :setter)))
'c-string->lisp-string)
-(defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
- (accessor-type (eql :getter)))
- 'c-string->lisp-string)
(defun c-string->lisp-string (string &optional limit)
(declare (ignore limit))
(symbol-name (name root)))))
(labels ((accessor (root rpath)
(apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root))))))
- `((defun ,(intern accessor-name) (struct)
- (declare (cl:type (alien ,struct-name) struct)
+ `((declaim (inline ,(intern accessor-name)
+ (setf ,(intern accessor-name))))
+ (defun ,(intern accessor-name) (struct)
+ (declare (cl:type (alien (* ,struct-name)) struct)
(optimize (speed 3)))
(,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel))
:getter)
,(accessor root rpath) ,(size root)))
(defun (setf ,(intern accessor-name)) (new-val struct)
- (declare (cl:type (alien ,struct-name) struct)
+ (declare (cl:type (alien (* ,struct-name)) struct)
(cl:type ,(lisp-type-for (type root) (size root)) new-val)
(optimize (speed 3)))
,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root)
(size root)))))
(generate-struct-definition name root nil))
`(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (sb-alien:define-alien-type ,@(first struct-elements)))
+ (sb-alien:define-alien-type ,@(first struct-elements))
,@accessors
(defmacro ,(intern (format nil "WITH-~A" name)) (var (&rest field-values) &body body)
(labels ((field-name (x)
(defun foreign-nullp (c)
"C is a pointer to 0?"
- (null-alien c))
\ No newline at end of file
+ (null-alien c))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.12.39"
+"0.8.12.40"
projects / sbcl.git / commitdiff