From: Daniel Barlow Date: Wed, 9 Apr 2003 01:03:39 +0000 (+0000) Subject: 0.pre8.50 X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a09b213e5812edd1ef3e88c18bde6bd1294da547;p=sbcl.git 0.pre8.50 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 --- diff --git a/contrib/sb-grovel/Makefile b/contrib/sb-grovel/Makefile new file mode 100644 index 0000000..386c199 --- /dev/null +++ b/contrib/sb-grovel/Makefile @@ -0,0 +1,2 @@ +SYSTEM=sb-grovel +include ../asdf-module.mk diff --git a/contrib/sb-grovel/README b/contrib/sb-grovel/README new file mode 100644 index 0000000..6d640d4 --- /dev/null +++ b/contrib/sb-grovel/README @@ -0,0 +1,41 @@ +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. + diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp new file mode 100644 index 0000000..3f82a5d --- /dev/null +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -0,0 +1,101 @@ +(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)))) + diff --git a/contrib/sb-grovel/defpackage.lisp b/contrib/sb-grovel/defpackage.lisp new file mode 100644 index 0000000..ffeb518 --- /dev/null +++ b/contrib/sb-grovel/defpackage.lisp @@ -0,0 +1,4 @@ +(defpackage "SB-GROVEL" + (:export "GROVEL-CONSTANTS-FILE") + (:use "COMMON-LISP" "SB-ALIEN" "ASDF" "SB-EXT")) + diff --git a/contrib/sb-grovel/example-constants.lisp b/contrib/sb-grovel/example-constants.lisp new file mode 100644 index 0000000..29d9138 --- /dev/null +++ b/contrib/sb-grovel/example-constants.lisp @@ -0,0 +1,35 @@ +;;; -*- 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)))) + diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp new file mode 100644 index 0000000..c74c333 --- /dev/null +++ b/contrib/sb-grovel/foreign-glue.lisp @@ -0,0 +1,85 @@ +(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)) diff --git a/contrib/sb-grovel/sb-grovel.asd b/contrib/sb-grovel/sb-grovel.asd new file mode 100644 index 0000000..13d5a40 --- /dev/null +++ b/contrib/sb-grovel/sb-grovel.asd @@ -0,0 +1,13 @@ +;;; -*- 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) + diff --git a/src/code/debug.lisp b/src/code/debug.lisp index bc64c3b..6f26239 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -871,33 +871,17 @@ reset to ~S." 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) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 06e95a7..a90e96f 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1672,37 +1672,6 @@ (funcall (ansi-stream-sout target) target str 0 len) (stream-write-string target str 0 len)))) -;;;; 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))))) - ;;;; READ-SEQUENCE (defun read-sequence (seq stream &key (start 0) end) diff --git a/version.lisp-expr b/version.lisp-expr index 9c5e783..740dce8 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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"