Chopped out unused (largely unimplemented) stream-command mechanism.
Experiemntal "sb-grovel" contrib is a turbo-charged
grovel_headers replacement, which has seen use in
sb-bsd-sockets and is now being made available separately to
see if other packages find it useful too. See sbcl-devel
message "sb-grovel contrib FFI helper code" for more info
--- /dev/null
+SYSTEM=sb-grovel
+include ../asdf-module.mk
--- /dev/null
+Many of the structure offsets and symbolic constants necessary to do
+FFI vary between architectures and operating systems. To avoid a
+maintenance nightmare, we derive them automatically by creating and
+running a small C program. The C program is created by
+def-to-lisp.lisp with input from a GROVEL-CONSTANTS-FILE
+
+The ASDF component type GROVEL-CONSTANTS-FILE has its PERFORM
+operation defined to write out a C source file, compile it, and run
+it. The output from this program is Lisp, which is then itself
+compiled.
+
+How to use it from your own system
+
+1) Create a Lisp package for the foreign constants/functions to go into.
+It needs to use SB-GROVEL and SB-ALIEN
+
+2) Make your system depend on the "sb-grovel" system
+
+3) Create a grovel-constants data file - see example-constants.lisp in
+this directory
+
+4) Add it as a component in your system. e.g.
+
+(defsystem sbcl-hemlock
+ :depends-on (sb-grovel)
+ :components
+ ((:module "sbcl"
+ :components
+ ((:file "defpackage")
+ (sb-grovel:grovel-constants-file "example-constants"
+ :package :sbcl-hemlock
+ )))))
+
+Make sure to specify the package you chose in step 1
+
+5) Build stuff
+
+---
+
+Note that we assume that the C type char has 8 bits.
+
--- /dev/null
+(in-package :SB-GROVEL)
+(defvar *export-symbols* nil)
+
+(defun c-for-structure (stream lisp-name c-struct)
+ (destructuring-bind (c-name &rest elements) c-struct
+ (format stream "printf(\"(sb-grovel::define-c-struct ~A %d)\\n\",sizeof (~A));~%" lisp-name c-name)
+ (dolist (e elements)
+ (destructuring-bind (lisp-type lisp-el-name c-type c-el-name) e
+ (format stream "printf(\"(sb-grovel::define-c-accessor ~A-~A ~A ~A \");~%"
+ lisp-name lisp-el-name lisp-name lisp-type)
+ ;; offset
+ (format stream "{ ~A t;printf(\"%d \",((unsigned long)&(t.~A)) - ((unsigned long)&(t)) ); }~%"
+ c-name c-el-name)
+ ;; length
+ (format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%"
+ c-name c-el-name)
+ (format stream "printf(\")\\n\");~%")))))
+
+(defun c-for-function (stream lisp-name alien-defn)
+ (destructuring-bind (c-name &rest definition) alien-defn
+ (let ((*print-right-margin* nil))
+ (format stream "printf(\"(declaim (inline ~A))\\n\");~%"
+ lisp-name)
+ (princ "printf(\"(sb-grovel::define-foreign-routine (" stream)
+ (princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream)
+ (princ lisp-name stream)
+ (princ " ) " stream)
+ (dolist (d definition)
+ (write d :length nil
+ :right-margin nil :stream stream)
+ (princ " " stream))
+ (format stream ")\\n\");")
+ (terpri stream))))
+
+
+(defun print-c-source (stream headers definitions package-name)
+ (let ((*print-right-margin* nil))
+ (loop for i in headers
+ do (format stream "#include <~A>~%" i))
+ (format stream "main() { ~%
+printf(\"(in-package ~S)\\\n\");~%" package-name)
+ (format stream "printf(\"(deftype int () '(signed-byte %d))\\\n\",8*sizeof (int));~%")
+ (format stream "printf(\"(deftype char () '(unsigned-byte %d))\\\n\",8*sizeof (char));~%")
+ (format stream "printf(\"(deftype long () '(unsigned-byte %d))\\\n\",8*sizeof (long));~%")
+ (dolist (def definitions)
+ (destructuring-bind (type lispname cname &optional doc) def
+ (cond ((eq type :integer)
+ (format stream
+ "printf(\"(defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%"
+ lispname doc cname))
+ ((eq type :string)
+ (format stream
+ "printf(\"(defvar ~A %S \\\"~A\\\")\\\n\",~A);~%"
+ lispname doc cname))
+ ((eq type :function)
+ (c-for-function stream lispname cname))
+ ((eq type :structure)
+ (c-for-structure stream lispname cname))
+ (t
+ (format stream
+ "printf(\";; Non hablo Espagnol, Monsieur~%")))))
+ (format stream "exit(0);~%}")))
+
+(defun c-constants-extract (filename output-file package)
+ (with-open-file (f output-file :direction :output)
+ (with-open-file (i filename :direction :input)
+ (let* ((headers (read i))
+ (definitions (read i)))
+ (print-c-source f headers definitions package)))))
+
+(defclass grovel-constants-file (asdf:cl-source-file)
+ ((package :accessor constants-package :initarg :package)))
+
+(defmethod asdf:perform ((op asdf:compile-op)
+ (component grovel-constants-file))
+ ;; we want to generate all our temporary files in the fasl directory
+ ;; because that's where we have write permission. Can't use /tmp;
+ ;; it's insecure (these files will later be owned by root)
+ (let* ((output-file (car (output-files op component)))
+ (filename (component-pathname component))
+ (real-output-file
+ (if (typep output-file 'logical-pathname)
+ (translate-logical-pathname output-file)
+ (pathname output-file)))
+ (tmp-c-source (merge-pathnames #p"foo.c" real-output-file))
+ (tmp-a-dot-out (merge-pathnames #p"a.out" real-output-file))
+ (tmp-constants (merge-pathnames #p"constants.lisp-temp"
+ real-output-file)))
+ (princ (list filename output-file real-output-file
+ tmp-c-source tmp-a-dot-out tmp-constants))
+ (terpri)
+ (funcall (intern "C-CONSTANTS-EXTRACT" (find-package "SB-GROVEL"))
+ filename tmp-c-source (constants-package component))
+ (and
+ (= (run-shell-command "gcc -o ~S ~S" (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))))
+
--- /dev/null
+(defpackage "SB-GROVEL"
+ (:export "GROVEL-CONSTANTS-FILE")
+ (:use "COMMON-LISP" "SB-ALIEN" "ASDF" "SB-EXT"))
+
--- /dev/null
+;;; -*- Lisp -*- - well, that's stretching a point. code=data != data=code
+
+;;; first, the headers necessary to find definitions of everything
+("sys/types.h" "sys/socket.h" "sys/stat.h" "unistd.h" "sys/un.h"
+ "netinet/in.h" "netinet/in_systm.h" "netinet/ip.h" "net/if.h"
+ "netdb.h" "errno.h" "netinet/tcp.h" "fcntl.h" "signal.h" )
+
+;;; then the stuff we're looking for
+((:integer af-inet "AF_INET" "IP Protocol family")
+ (:integer af-unspec "AF_UNSPEC" "Unspecified.")
+ (:integer af-local
+ #+(or sunos solaris) "AF_UNIX"
+ #-(or sunos solaris) "AF_LOCAL"
+ "Local to host (pipes and file-domain).")
+ (:integer sigterm "SIGTERM")
+ (:structure stat ("struct stat"
+ (integer dev "dev_t" "st_dev")
+ (integer atime "time_t" "st_atime")))
+
+
+ (:function accept ("accept" int
+ (socket int)
+ (my-addr (* t))
+ (addrlen int :in-out)))
+ (:function bind ("bind" int
+ (sockfd int)
+ (my-addr (* t))
+ (addrlen int)))
+ (:function getpid ("getpid" int ))
+ (:function getppid ("getppid" int))
+ (:function kill ("kill" int
+ (pid int) (signal int)))
+ (:function mkdir ("mkdir" int
+ (name c-string))))
+
--- /dev/null
+(in-package :sb-grovel)
+
+;;;; The macros defined here are called from #:Gconstants.lisp, which was
+;;;; generated from constants.lisp by the C compiler as driven by that
+;;;; wacky def-to-lisp thing.
+
+;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
+;;; C-CALL:C-STRING) (BUF (* T)) )
+
+;;; I can't help thinking this was originally going to do something a
+;;; lot more complex
+(defmacro define-foreign-routine
+ (&whole it (c-name lisp-name) return-type &rest args)
+ (declare (ignorable c-name lisp-name return-type args))
+ `(define-alien-routine ,@(cdr it)))
+#||
+(define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2)
+(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2)
+||#
+;;; define-c-accessor makes us a setter and a getter for changing
+;;; memory at the appropriate offset
+
+;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4)
+
+
+(defmacro define-c-accessor (el structure type offset length)
+ (declare (ignore structure))
+ (let* ((ty (cond
+ ((eql type 'integer) `(,type ,(* 8 length)))
+ ((eql (car type) '*) `(unsigned ,(* 8 length)))
+ ((eql type 'c-string) `(unsigned ,(* 8 length)))
+ ((eql (car type) 'array) (cadr type))))
+ (sap-ref-? (intern (format nil "~ASAP-REF-~A"
+ (if (member (car ty) '(INTEGER SIGNED))
+ "SIGNED-" "")
+ (cadr ty))
+ (find-package "SB-SYS"))))
+ (labels ((template (before after)
+ `(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address ptr))))
+ (sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset)))))
+ (,before (,sap-ref-? sap index) ,after))))
+ `(progn
+ ;;(declaim (inline ,el (setf ,el)))
+ (defun ,el (ptr &optional (index 0))
+ (declare (optimize (speed 3)))
+ (sb-sys:without-gcing
+ ,(template 'prog1 nil)))
+ (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset)
+ (defun (setf ,el) (newval ptr &optional (index 0))
+ (declare (optimize (speed 3)))
+ (sb-sys:without-gcing
+ ,(template 'setf 'newval)))))))
+
+
+;;; make memory allocator for appropriately-sized block of memory, and
+;;; a constant to tell us how big it was anyway
+(defmacro define-c-struct (name size)
+ (labels ((p (x) (intern (concatenate 'string x (symbol-name name))
+ (symbol-package name))))
+ `(progn
+ (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0
+ :element-type '(unsigned-byte 8)))
+ (defconstant ,(p "SIZE-OF-") ,size)
+ (defun ,(p "FREE-" ) (p) (declare (ignore p))))))
+
+(defun foreign-nullp (c)
+ "C is a pointer to 0?"
+ (= 0 (sb-sys:sap-int (sb-alien:alien-sap c))))
+
+;;; this could be a lot faster if I cared enough to think about it
+(defun foreign-vector (pointer size length)
+ "Compose a vector of the words found in foreign memory starting at
+POINTER. Each word is SIZE bytes long; LENGTH gives the number of
+elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO"
+ (assert (= size 1))
+ (let ((ptr
+ (typecase pointer
+ (sb-sys:system-area-pointer
+ (sap-alien pointer (* (sb-alien:unsigned 8))))
+ (t
+ (sb-alien:cast pointer (* (sb-alien:unsigned 8))))))
+ (result (make-array length :element-type '(unsigned-byte 8))))
+ (loop for i from 0 to (1- length) by size
+ do (setf (aref result i) (sb-alien:deref ptr i)))
+ result))
--- /dev/null
+;;; -*- Lisp -*-
+
+(defpackage #:sb-grovel-system (:use #:asdf #:cl))
+(in-package #:sb-grovel-system)
+
+(defsystem sb-grovel
+ :version "0.01"
+ :components ((:file "defpackage")
+ (:file "def-to-lisp" :depends-on ("defpackage"))))
+
+(defmethod perform ((o test-op) (c (eql (find-system :sb-grovel))))
+ t)
+
level)
(debug-prompt *debug-io*)
(force-output *debug-io*)
- (let ((input (sb!int:get-stream-command *debug-io*)))
- (cond (input
- (let ((cmd-fun (debug-command-p
- (sb!int:stream-command-name input)
- restart-commands)))
- (cond
- ((not cmd-fun)
- (error "unknown stream-command: ~S" input))
- ((consp cmd-fun)
- (error "ambiguous debugger command: ~S" cmd-fun))
- (t
- (apply cmd-fun
- (sb!int:stream-command-args input))))))
+ (let* ((exp (read *debug-io*))
+ (cmd-fun (debug-command-p exp restart-commands)))
+ (cond ((not cmd-fun)
+ (debug-eval-print exp))
+ ((consp cmd-fun)
+ (format t "~&Your command, ~S, is ambiguous:~%"
+ exp)
+ (dolist (ele cmd-fun)
+ (format t " ~A~%" ele)))
(t
- (let* ((exp (read *debug-io*))
- (cmd-fun (debug-command-p exp
- restart-commands)))
- (cond ((not cmd-fun)
- (debug-eval-print exp))
- ((consp cmd-fun)
- (format t
- "~&Your command, ~S, is ambiguous:~%"
- exp)
- (dolist (ele cmd-fun)
- (format t " ~A~%" ele)))
- (t
- (funcall cmd-fun)))))))))))))))
+ (funcall cmd-fun))))))))))))
;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
(defun debug-eval-print (expr)
(funcall (ansi-stream-sout target) target str 0 len)
(stream-write-string target str 0 len))))
\f
-;;;; stream commands
-
-(defstruct (stream-command (:constructor make-stream-command
- (name &optional args))
- (:copier nil))
- (name nil :type symbol)
- (args nil :type list))
-(def!method print-object ((obj stream-command) str)
- (print-unreadable-object (obj str :type t :identity t)
- (prin1 (stream-command-name obj) str)))
-
-;;; Take a stream and wait for text or a command to appear on it. If
-;;; text appears before a command, return NIL, otherwise return a
-;;; command.
-;;;
-;;; We can't simply call the stream's misc method because NIL is an
-;;; ambiguous return value: does it mean text arrived, or does it mean
-;;; the stream's misc method had no :GET-COMMAND implementation? We
-;;; can't return NIL until there is text input. We don't need to loop
-;;; because any stream implementing :GET-COMMAND would wait until it
-;;; had some input. If the LISTEN fails, then we have some stream we
-;;; must wait on.
-(defun get-stream-command (stream)
- (let ((cmdp (funcall (ansi-stream-misc stream) stream :get-command)))
- (cond (cmdp)
- ((listen stream)
- nil)
- (t
- ;; This waits for input and returns NIL when it arrives.
- (unread-char (read-char stream) stream)))))
-\f
;;;; READ-SEQUENCE
(defun read-sequence (seq stream &key (start 0) end)
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre8.49"
+"0.pre8.50"
projects / sbcl.git / commitdiff